Merge branch 'master' into fradrive/company

CHANGELOG.md

@@ -2,6 +2,24 @@
 
 All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
 
+## [27.4.45](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.44...v27.4.45) (2023-10-18)
+
+
+### Bug Fixes
+
+* **hoogle:** remove erroneous comment ([c011d88](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c011d887cece8338920355b540aa4b233e0b994f))
+* **sap:** yet another fix for finding date intervals ([fde97b0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fde97b048ab04ab59c9e3f2a2f74bb2c1e996b22))
+
+## [27.4.44](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.43...v27.4.44) (2023-10-18)
+
+
+### Bug Fixes
+
+* **sap:** combine immediate next day licence chnages for SAP ([f4adfdf](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f4adfdf87270930d4ca6611f2a9956613fcace53))
+* **sap:** combine immediate next day licence chnages for SAP ([cbb44f1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cbb44f106ad59e0a53ca04963ade5544120b7e21))
+* **sap:** combineBlocks yet another bug squashed ([3924d14](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3924d14abd868305b42c9d04913536b4999dc45b))
+* **sap:** compileBlocks ([b4a88ab](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b4a88abcf85783c350ad2bf3a5e973d13d1eb1f6))
+
 ## [27.4.43](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.42...v27.4.43) (2023-10-13)
 
 ## [27.4.42](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.41...v27.4.42) (2023-10-12)

nix/docker/version.json

@@ -1,3 +1,3 @@
 {
-  "version": "27.4.43"
+  "version": "27.4.45"
 }

package-lock.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "27.4.43",
+  "version": "27.4.45",
   "lockfileVersion": 1,
   "requires": true,
   "dependencies": {

package.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "27.4.43",
+  "version": "27.4.45",
   "description": "",
   "keywords": [],
   "author": "",

package.yaml

@@ -1,5 +1,5 @@
 name: uniworx
-version: 27.4.43
+version: 27.4.45
 dependencies:
   - base
   - yesod

src/Audit/Types.hs

@@ -212,7 +212,7 @@ data Transaction
     }
   | TransactionQualificationUserEdit  -- Note that a renewal always entails unblocking as well!
     { transactionUser                         :: UserId                 -- qualification holder that is updated
-    , transactionQualificationUser            :: QualificationUserId  -- könnte entfernt werden
+    , transactionQualificationUser            :: QualificationUserId    -- not really necessary, maybe remove?
     , transactionQualification                :: QualificationId    
     , transactionQualificationValidUntil      :: Day
     , transactionQualificationScheduleRenewal :: Maybe Bool -- Maybe, because some update may leave it unchanged (also avoids DB Migration)
@@ -226,7 +226,12 @@ data Transaction
     { transactionUser               :: UserId                         -- qualification holder that is updated
       -- , transactionQualificationUser  :: QualificationUserId       -- not neccessary due to UniqueQualificationUser
     , transactionQualification      :: QualificationId
-    , transactionQualificationBlock :: QualificationUserBlock         -- TODO -- 
+    , transactionQualificationBlock :: QualificationUserBlock         -- full information about block
+    }
+  | TransactionQualificationUserScheduleRenewal
+    { transactionUser                         :: UserId               -- qualification holder that is updated
+    , transactionQualification                :: QualificationId
+    , transactionQualificationScheduleRenewal :: Maybe Bool           -- TRUE=will be notified upon expiry, FALSE=won't be notified; always JUST, for compatibility with TransactionQualificationUserEdit
     }
   deriving (Eq, Ord, Read, Show, Generic)
 

src/Handler/Admin/Avs.hs

@@ -431,8 +431,7 @@ getProblemAvsSynchR = do
           <*> mkLicenceTable apidStatus "avsLicDiffGrantRollfeld"  AvsNoLicence        avsLicenceDiffGrantRollfeld
 
   now <- liftIO getCurrentTime
-  let nowaday = utctDay now
+  let procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler ()
-      procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler ()
       procRes aLic (LicenceTableChangeAvsData       , apids) = do
         oks <- catchAllAvs $ setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids
         let no_req = Set.size apids
@@ -458,7 +457,7 @@ getProblemAvsSynchR = do
           uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] []
           -- addMessage Info $ text2Html $ "UIDs: " <> tshow uids -- DEBUG
           void $ qualificationUserBlocking licenceTableChangeFDriveQId uids True Nothing (Left licenceTableChangeFDriveReason) False
-          forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId nowaday licenceTableChangeFDriveEnd licenceTableChangeFDriveRenew
+          forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId now licenceTableChangeFDriveEnd licenceTableChangeFDriveRenew "Admin Resolution"
           (length uids,) <$> get404 licenceTableChangeFDriveQId
         addMessageI (bool Success Warning $ null apids) $ MsgSetFraDriveLicences (citext2string qualificationShorthand) n
         redirect ProblemAvsSynchR -- must be outside runDB

src/Handler/Admin/Crontab.hs

@@ -220,5 +220,5 @@ postAdminJobsR = do
   
     getJobName :: Value -> Maybe Text
     getJobName (Object o) 
-      | Just (String s) <- HashMap.lookup "job" o = Just s -- $ kebabToCamel s
+      | Just (String s) <- HashMap.lookup "job" o = Just s --  (kebabToCamel s)
     getJobName _ = Nothing

src/Handler/LMS.hs

@@ -735,7 +735,7 @@ postLmsR sid qsh = do
             , QualificationUserUser <-. usersList            
             , QualificationUserValidUntil <. cutoff
             ] []          
-          forM_ shortUsers $ upsertQualificationUser qid nowaday cutoff Nothing
+          forM_ shortUsers $ upsertQualificationUser qid now cutoff Nothing "E-Learning Reset"
 
         fromIntegral <$> (if isReset
             then updateWhereCount ([LmsUserQualification ==. qid, LmsUserUser <-. usersList, LmsUserResetTries ==. False, LmsUserEnded ==. Nothing] -- , LmsUserLocked ==. True] -- needs to be locked for reset, but this is counter-intuitive for users; should be harmles, but delays reset until lock is effective

src/Handler/Qualification.hs

@@ -614,14 +614,20 @@ postQualificationR sid qsh = do
       addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
       reloadKeepGetParams $ QualificationR sid qsh
     (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do      
-      runDB . forM_ selectedUsers $ upsertQualificationUser qid nowaday grantValidday Nothing
+      runDB . forM_ selectedUsers $ upsertQualificationUser qid now grantValidday Nothing "Admin"
       addMessageI  (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
       reloadKeepGetParams $ QualificationR sid qsh
-    (action, selectedUsers) | isExpiryAct action -> do
+    (action, selectedUsers) | isExpiryAct action -> do      
       let isUnexpire = action == QualificationActUnexpireData
-      upd <- runDB $ updateWhereCount
+      upd <- runDB $ do
-              [QualificationUserQualification ==. qid, QualificationUserUser <-. Set.toList selectedUsers]
+        forM_ selectedUsers $ \uid -> audit TransactionQualificationUserScheduleRenewal
-              [QualificationUserScheduleRenewal =. isUnexpire]
+          { transactionUser                         = uid
+          , transactionQualification                = qid
+          , transactionQualificationScheduleRenewal = Just isUnexpire
+          }
+        updateWhereCount
+          [QualificationUserQualification ==. qid, QualificationUserUser <-. Set.toList selectedUsers]
+          [QualificationUserScheduleRenewal =. isUnexpire]
       let msgKind = if upd > 0  then Success else Warning
           msgVal  = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire
       addMessageI msgKind msgVal

src/Handler/SAP.hs

@@ -79,18 +79,18 @@ compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)]
 compileBlocks dStart dEnd = go (dStart, True) 
   where 
     go :: (Day,Bool) -> [(Day,Bool)] -> [(Day, Day)]
-    go b@(d,s) ((d1,s1):r1@((d2,_s2):_r2))
+    go (d,s) (p1@(d1,s1):r1@((d2,s2):r2))
-      | d1 == d2 || succ d1 == d2 || s == s1 || d1 < d = go b r1  -- ignore unnecessary change
+      | s1 == s2 && d <= d1                            = go (d,s) (p1:r2)   -- ignore unnecessary 2nd change      
-    go b@(d,s) ((d1,s1):r1)
+      | d1 == d2 || succ d1 == d2 || s == s1 || d > d1 = go (d,s)     r1    -- ignore unnecessary 1st change      
-      | d1 >= dEnd        = go b []                               -- remaining days extend validity
+    go (d,s) ((d1,s1):r1)
-      | s, not s1, d < d1 = (d,d1) : go (d1,s1) r1                -- valid interval found
+      | dEnd <= d1        =          go (d ,s ) []                          -- remaining dates extend validity        
-      | s == s1           =          go  b      r1                -- no change
+      | s, not s1, d < d1 = (d,d1) : go (d1,s1) r1                          -- valid interval found
-      | otherwise         =          go (d1,s1) r1                -- ignore invalid interval
+      | s == s1           =          go (d ,s ) r1                          -- no change
+      | otherwise         =          go (d1,s1) r1                          -- ignore invalid interval
     go (d,s) []
       | s         = [(d,dEnd)]
       | otherwise = []
 
-
 -- | Deliver all employess with a successful LDAP synch within the last 3 months
 getQualificationSAPDirectR :: Handler TypedContent
 getQualificationSAPDirectR = do

src/Handler/Tutorial/Users.hs

@@ -139,8 +139,9 @@ postTUsersR tid ssh csh tutn = do
     (TutorialUserGrantQualificationData{..}, selectedUsers)
       | tuQualification `Set.member` courseQids -> do
         -- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
-        today <- utctDay <$> liftIO getCurrentTime
+        today <- liftIO getCurrentTime
-        runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing
+        let reason = "Kurs " <> CI.original (unSchoolKey ssh) <> "-" <> CI.original csh <> "-" <> CI.original tutn
+        runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing reason
         addMessageI  (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
         redirect $ CTutorialR tid ssh csh tutn TUsersR
     (TutorialUserRenewQualificationData{..}, selectedUsers)

src/Handler/Utils/Qualification.hs

@@ -133,8 +133,9 @@ selectRelevantBlock cutoff quid =
 ------------------------
 
 
-upsertQualificationUser :: QualificationId -> Day -> Day -> Maybe Bool -> UserId -> DB () -- ignores blocking
+upsertQualificationUser :: QualificationId -> UTCTime -> Day -> Maybe Bool -> Text -> UserId -> DB () -- ignores blocking
-upsertQualificationUser  qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal qualificationUserUser = do
+upsertQualificationUser  qualificationUserQualification startTime qualificationUserValidUntil mbScheduleRenewal reason qualificationUserUser = do
+  let qualificationUserLastRefresh = utctDay startTime
   Entity quid _ <- upsert
     QualificationUser
       { qualificationUserFirstHeld        = qualificationUserLastRefresh      
@@ -149,7 +150,8 @@ upsertQualificationUser  qualificationUserQualification qualificationUserLastRef
       , QualificationUserLastRefresh        =. qualificationUserLastRefresh      
       ]
     )
-  
+  authUsr <- liftHandler maybeAuthId
+  insert_ $ QualificationUserBlock quid True startTime reason authUsr
   audit TransactionQualificationUserEdit
     { transactionQualificationUser            = quid
     , transactionQualification                = qualificationUserQualification

test/Handler/SAPSpec.hs

@@ -79,6 +79,7 @@ spec = do
           w0 = fromGregorian 2001  9 22
           w1 = fromGregorian 2023  9 22
           w2 = fromGregorian 2023 10 16
+          wF = fromGregorian 2023 10 17
           w3 = fromGregorian 2023 11 17
           w4 = fromGregorian 2024 01 21
       compileBlocks wA wE []           `shouldBe` [(wA,wE)]
@@ -94,6 +95,10 @@ spec = do
       compileBlocks wA wE [(w1,False),(w1,True),(w1,False),(w1,True),(w1,False),(w2,True)] `shouldBe` [(wA,w1),(w2,wE)]
       compileBlocks wA wE [(w0,True),(w1,True),(w1,False),(w1,True),(w1,False),(w2,True),(w3,True)] `shouldBe` [(wA,w1),(w2,wE)]
       compileBlocks wA wE [(w0,False),(w1,False),(w2,True),(w3,False),(w4,True)] `shouldBe` [(wA,w1),(w2,w3),(w4,wE)]
+      compileBlocks wA wE [(w1,False),(w2,True),(wF,True ),(w3,False)] `shouldBe` [(wA,w1),(w2,w3)]
+      compileBlocks wA wE [(w1,True),(w2,False),(wF,False),(w3,True)]  `shouldBe` [(wA,w2),(w3,wE)]
+      compileBlocks wA wE [(w2,False),(wF,False),(w3,True)] `shouldBe` [(wA,w2),(w3,wE)]
+      compileBlocks wA wE [(w2,False),(wF,False)] `shouldBe` [(wA,w2) ]
 
     it "handles basic intervals" $ do
       (d1,d2,d3) <- generate $ do
@@ -112,9 +117,11 @@ spec = do
         d3 <- arbitrary `suchThat` (d1 <)
         d4 <- arbitrary `suchThat` (d3 <)
         return (d1,d2,d3,d4)
-      b <- generate arbitrary     
+      b3 <- generate arbitrary
-      let test   = compileBlocks d1 d2 [(d3,b),(d4,not b)]
+      b4 <- generate arbitrary
-          result | b         = [(d1, min d2 d4)]
+      let test   = compileBlocks d1 d2 [(d3,b3),(d4,b4)]
-                 | d2 > d4   = [(d1,d3),(d4,d2)]
+          result | b3, b4       = [(d1, d2)]
-                 | otherwise = [(d1, min d2 d3)]
+                 | b3           = [(d1, min d2 d4)]                 
+                 | b4, d2 > d4  = [(d1,d3),(d4,d2)]
+                 | otherwise    = [(d1, min d2 d3)]
       test `shouldBe` result