From ebf250bd8cc5b2dff25f56a02fac0594b3232def Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 18 Oct 2023 06:55:47 +0000 Subject: [PATCH 1/7] chore(release): 27.4.44 --- CHANGELOG.md | 10 ++++++++++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 14 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 52590b3be..e18fae0cf 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,16 @@ 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.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) diff --git a/nix/docker/version.json b/nix/docker/version.json index 09792e934..16ffa06dc 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.43" + "version": "27.4.44" } diff --git a/package-lock.json b/package-lock.json index 0ea0303ce..4434f1781 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.43", + "version": "27.4.44", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 2af7ab202..a400986a3 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.43", + "version": "27.4.44", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 3e70cba93..d838554b4 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.43 +version: 27.4.44 dependencies: - base - yesod From fde97b048ab04ab59c9e3f2a2f74bb2c1e996b22 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 18 Oct 2023 14:38:02 +0000 Subject: [PATCH 2/7] fix(sap): yet another fix for finding date intervals --- src/Handler/SAP.hs | 16 ++++++++-------- test/Handler/SAPSpec.hs | 5 +++++ 2 files changed, 13 insertions(+), 8 deletions(-) diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index 34b00b81b..be4ad973a 100644 --- a/src/Handler/SAP.hs +++ b/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)) - | d1 == d2 || succ d1 == d2 || s == s1 || d1 < d = go b r1 -- ignore unnecessary change - go b@(d,s) ((d1,s1):r1) - | d1 >= dEnd = go b [] -- remaining days extend validity - | s, not s1, d < d1 = (d,d1) : go (d1,s1) r1 -- valid interval found - | s == s1 = go b r1 -- no change - | otherwise = go (d1,s1) r1 -- ignore invalid interval + go (d,s) (p1@(d1,s1):r1@((d2,s2):r2)) + | s1 == s2 && d <= d1 = go (d,s) (p1:r2) -- ignore unnecessary 2nd change + | d1 == d2 || succ d1 == d2 || s == s1 || d > d1 = go (d,s) r1 -- ignore unnecessary 1st change + go (d,s) ((d1,s1):r1) + | dEnd <= d1 = go (d ,s ) [] -- remaining dates extend validity + | s, not s1, d < d1 = (d,d1) : go (d1,s1) r1 -- valid interval found + | 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 diff --git a/test/Handler/SAPSpec.hs b/test/Handler/SAPSpec.hs index 3f99699cf..a7e7798a0 100644 --- a/test/Handler/SAPSpec.hs +++ b/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 From 41cb7d2abcb144ca20e5134b9474af122a3aabf3 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 18 Oct 2023 15:02:20 +0000 Subject: [PATCH 3/7] chore(sap): more test for compileBlocks --- test/Handler/SAPSpec.hs | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/test/Handler/SAPSpec.hs b/test/Handler/SAPSpec.hs index a7e7798a0..ffa84ff18 100644 --- a/test/Handler/SAPSpec.hs +++ b/test/Handler/SAPSpec.hs @@ -96,7 +96,7 @@ spec = do 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 [(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) ] @@ -117,9 +117,11 @@ spec = do d3 <- arbitrary `suchThat` (d1 <) d4 <- arbitrary `suchThat` (d3 <) return (d1,d2,d3,d4) - b <- generate arbitrary - let test = compileBlocks d1 d2 [(d3,b),(d4,not b)] - result | b = [(d1, min d2 d4)] - | d2 > d4 = [(d1,d3),(d4,d2)] - | otherwise = [(d1, min d2 d3)] + b3 <- generate arbitrary + b4 <- generate arbitrary + let test = compileBlocks d1 d2 [(d3,b3),(d4,b4)] + result | b3, b4 = [(d1, d2)] + | b3 = [(d1, min d2 d4)] + | b4, d2 > d4 = [(d1,d3),(d4,d2)] + | otherwise = [(d1, min d2 d3)] test `shouldBe` result From c011d887cece8338920355b540aa4b233e0b994f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 18 Oct 2023 17:53:00 +0200 Subject: [PATCH 4/7] fix(hoogle): remove erroneous comment --- src/Handler/Admin/Crontab.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Admin/Crontab.hs b/src/Handler/Admin/Crontab.hs index 53393abb0..5806edd60 100644 --- a/src/Handler/Admin/Crontab.hs +++ b/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 \ No newline at end of file From 47987a7e0901e0a31da392fc009708183ec874d3 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 18 Oct 2023 23:46:35 +0000 Subject: [PATCH 5/7] chore(release): 27.4.45 --- CHANGELOG.md | 8 ++++++++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 12 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index e18fae0cf..5d9b7616d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,14 @@ 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) diff --git a/nix/docker/version.json b/nix/docker/version.json index 16ffa06dc..77bb560f7 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.44" + "version": "27.4.45" } diff --git a/package-lock.json b/package-lock.json index 4434f1781..31b4132f1 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.44", + "version": "27.4.45", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index a400986a3..014db6ed0 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.44", + "version": "27.4.45", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index d838554b4..42efdc6bb 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.44 +version: 27.4.45 dependencies: - base - yesod From 5d8d8cf17e634ecb950a1c329c859fb93f94ef77 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 19 Oct 2023 11:21:35 +0000 Subject: [PATCH 6/7] fix(course): grant qualifications now issues and unblocks --- src/Handler/Admin/Avs.hs | 5 ++--- src/Handler/LMS.hs | 2 +- src/Handler/Qualification.hs | 2 +- src/Handler/Tutorial/Users.hs | 5 +++-- src/Handler/Utils/Qualification.hs | 8 +++++--- 5 files changed, 12 insertions(+), 10 deletions(-) diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index e7b4fda22..a2a1db42f 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -431,8 +431,7 @@ getProblemAvsSynchR = do <*> mkLicenceTable apidStatus "avsLicDiffGrantRollfeld" AvsNoLicence avsLicenceDiffGrantRollfeld now <- liftIO getCurrentTime - let nowaday = utctDay now - procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler () + let 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 diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index cdd720509..ae49a06c5 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -739,7 +739,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 diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 6553bb300..66a4b2f75 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -617,7 +617,7 @@ 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 diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index f9be59482..5a02a6d35 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/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 - runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing + today <- liftIO getCurrentTime + 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) diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index ea9812c68..f104f0073 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -133,8 +133,9 @@ selectRelevantBlock cutoff quid = ------------------------ -upsertQualificationUser :: QualificationId -> Day -> Day -> Maybe Bool -> UserId -> DB () -- ignores blocking -upsertQualificationUser qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal qualificationUserUser = do +upsertQualificationUser :: QualificationId -> UTCTime -> Day -> Maybe Bool -> Text -> UserId -> DB () -- ignores blocking +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 From cd9b542265d2e09464697324ab9991dda1976127 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 19 Oct 2023 15:01:24 +0000 Subject: [PATCH 7/7] chore(audit): qualification schedule renewal changes are logged to audit log --- src/Audit/Types.hs | 9 +++++++-- src/Handler/Qualification.hs | 14 ++++++++++---- 2 files changed, 17 insertions(+), 6 deletions(-) diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 8360410a8..50dbc8811 100644 --- a/src/Audit/Types.hs +++ b/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) diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 66a4b2f75..689a96e2b 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -620,11 +620,17 @@ postQualificationR sid qsh = do 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 - [QualificationUserQualification ==. qid, QualificationUserUser <-. Set.toList selectedUsers] - [QualificationUserScheduleRenewal =. isUnexpire] + upd <- runDB $ do + forM_ selectedUsers $ \uid -> audit TransactionQualificationUserScheduleRenewal + { 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