From 8ecdaca4d696cd7b4244b0e8ab0b58c16769ceb2 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 22 Aug 2023 08:56:43 +0000 Subject: [PATCH 01/59] Quickfix for apc sever seeing ligatures that do not exist --- src/Handler/Utils/LMS.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index f5f91e969..0376866cb 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -141,7 +141,7 @@ maxLmsUserIdentRetries = 27 randomText :: MonadIO m => String -> Int -> m Text randomText extra n = fmap pack . evalRandTIO . replicateM n $ uniform range where - num_letters = ['2'..'9'] ++ ['a'..'h'] ++ ['j','k'] ++ ['m'..'z'] -- users have trouble distinguishing 1/l and 0/O so we eliminate these; apc has trouble distinguishing i/j + num_letters = ['2'..'9'] ++ ['a'..'h'] ++ 'k' : ['m'..'z'] -- users have trouble distinguishing 1/l and 0/O so we eliminate these; apc has trouble distinguishing i/j and read "ji", "jf" as ligatures "ij", "fj" so we eliminate j as well range = extra ++ num_letters --TODO: consider using package elocrypt for user-friendly passwords here, licence requires mentioning of author, etc. though From b591e22880f49c065a8048def92c246bf818b802 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 12 Sep 2023 12:57:00 +0000 Subject: [PATCH 02/59] chore: fix minor typo --- messages/uniworx/categories/admin/de-de-formal.msg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index 5b905fbf1..28803d6c4 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -45,7 +45,7 @@ MailTestFormEmail: E-Mail-Adresse MailTestFormLanguages: Spracheinstellungen MailRerouteTo dev@Address: Alle Emails werden nicht an die eigentlichen Empfänger versendet, sondern umgeleitet zu _{dev}. Druckaufträge werden generiert, aber nicht zum tatsächlichen Druck gesendet. TestDownload: Download-Test -BearerTokenUsageWarning: Mit diesem Interface können quesi beliebige Rechte als Tokens kodiert und somit ohne wesentliche weitere Beschränkung frei übertragen werden. Benutzen Sie dieses Interface nur, wenn Sie von einem erfahrenen Entwickler/einer erfahrenen Entwicklerin über die Auswirkungen des konkreten Tokens, dass sie ausstellen möchten, beraten wurden! +BearerTokenUsageWarning: Mit diesem Interface können quasi beliebige Rechte als Tokens kodiert und somit ohne wesentliche weitere Beschränkung frei übertragen werden. Benutzen Sie dieses Interface nur, wenn Sie von einem erfahrenen Entwickler/einer erfahrenen Entwicklerin über die Auswirkungen des konkreten Tokens, dass sie ausstellen möchten, beraten wurden! BearerTokenAuthorityGroups: Token-Authorität (Gruppen) BearerTokenAuthorityGroupsTip: Die primären Benutzer:innen aller angegebenen Gruppen müssen Zugriff auf eine Route haben, damit das Token den Zugriff auf diese Route erlaubt. BearerTokenAuthorityGroupMissing: Gruppe wird benötigt From a72142352ee867bb9fdc29741622efd11e8de8af Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 20 Sep 2023 21:52:17 +0000 Subject: [PATCH 03/59] chore(release): 27.4.34 --- CHANGELOG.md | 36 ++++++++++++++++++++++++++++++++++++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 40 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index c258f366f..ea7b67a33 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,42 @@ 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.34](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.18...v27.4.34) (2023-09-20) + + +### Bug Fixes + +* **apc:** apc cannot distinguish ij from ji, partial fix only. Needs new font ([b4ba0a3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b4ba0a30dc7c513bb9e3c567ca771d5d75de4343)) +* **block:** negate condition to test ([9cf7f39](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9cf7f3965aa95f0b8f2a1574dbad90c0257edafd)) +* **build:** add missing file ([1fd24f6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1fd24f608dc9202fa98f52f7908f4be908a18efc)) +* **build:** prevent migration on non-existing table ([5bb49cd](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5bb49cd88941e510a50759efaad88690f841ca47)) +* **build:** refix test commits somehow ([34ada53](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/34ada53de0cc5804468791854e824b730fcc84de)) +* **build:** v2 ([ac77aa1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ac77aa176a3c3977c4a802e5ed534fa2850528fe)) +* **lms:** accept success for no-status learners and print several more debug messages processing reports ([a7ed659](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a7ed659866de1d4a178bbe4e8f9cd8fbc629c724)) +* **lms:** ensure lms uniqueness across all qualifications ([b85c8bd](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b85c8bd74f8db526fb1cbb43ff12a24b93c07eb3)) +* **lms:** filter by status ([a74c3d8](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a74c3d80cada4f9d224365727dab9676cc905f54)) +* **lms:** negate learner locking condition ([a452b03](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a452b032c43dbdfd086ffa4793c83ecc32c450f8)) +* **lms:** reset e-learning more lenient ([8b0737e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8b0737e2aabc7153ae3a3df4f97f86ffc8592e7a)) +* **lms:** simultaneous block/unblock lets unblock win in all situations ([ecd1a0f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ecd1a0fc210d1340bff5c79d8bb676a47654b509)) +* **qualification:** new block/unblock mechanism working now ([5397c7b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5397c7be353fc1b1e8310f66b49a9b93ee890253)) +* **time:** midnight timezone conversion bug eliminated ([dfa07a9](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/dfa07a95eb29f1fceec258a466e1e7c779ff6e5c)) +* **users:** fix [#112](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/112) and also add some convenience ([35096ac](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/35096ace01a2bc2a2d666794bb1ff92f52b3edec)) +* **users:** fix [#112](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/112) working now ([88bf21c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/88bf21c9c5de3755ea6591c97dc1f99a928914d5)) + +## [27.4.17](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.16...v27.4.17) (2023-07-15) + +## [27.4.16](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.15...v27.4.16) (2023-07-15) + +## [27.4.15](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.14...v27.4.15) (2023-07-15) + + +### Bug Fixes + +* **build:** major qualfication block quirks fixed ([ab48e40](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ab48e40ac7e5024b7847b3995e6ae16d1c401c60)) +* **build:** minor ([f9930f2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f9930f2a00d1e0f0af9b7f2af7c387bcc09cef5a)) +* **db:** migration qualification block ([3d59527](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3d595271d979f29ed8bbc546f495e5ad1deae5ca)) +* **test:** LmsStatus is no longer a semigroup ([bf8cd4f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/bf8cd4fa899bccd4a37906a4d899aca6ca25d726)) + ## [27.4.33](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.32...t27.4.33) (2023-09-20) diff --git a/nix/docker/version.json b/nix/docker/version.json index 665027c0b..1480b6267 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.33" + "version": "27.4.34" } diff --git a/package-lock.json b/package-lock.json index ede5cb103..002df9556 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.33", + "version": "27.4.34", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 666282fb3..85fa6e713 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.33", + "version": "27.4.34", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index b67586386..03e875bea 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.33 +version: 27.4.34 dependencies: - base - yesod From 61d414e3d5559afd51b1fb9be46d0f1d219d684a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 21 Sep 2023 14:32:32 +0000 Subject: [PATCH 04/59] chore(qualifications): restrict regular renewal to half valid duration --- src/Handler/Utils/Qualification.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index da50d98b7..b2edbf325 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -198,8 +198,8 @@ renewValidQualificationUsers qid renewalTime uids = Just Qualification{qualificationValidDuration=Just renewalMonths} -> do cutoff <- maybe (liftIO getCurrentTime) return renewalTime quEntsAll <- selectValidQualifications qid uids cutoff - let cutoffday = utctDay cutoff - maxValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) cutoffday + let cutoffday = utctDay cutoff + maxValidTo = addGregorianMonthsRollOver (toInteger $ renewalMonths `div` 2) cutoffday quEnts = filter (\q -> maxValidTo >= (q ^. _entityVal . _qualificationUserValidUntil)) quEntsAll forM_ quEnts $ \(Entity quId QualificationUser{..}) -> do let newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil From 9bb2586c1e959b787b9ec44907dc07a0a51e1292 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 21 Sep 2023 14:32:57 +0000 Subject: [PATCH 05/59] chore(release): 27.4.36 --- CHANGELOG.md | 7 +++++++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 11 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 225e7ee08..2292c68d7 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ 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.36](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.34...v27.4.36) (2023-09-21) + + +### Bug Fixes + +* **lms:** treat simultaneous blocks/unblocks correctly ([11752dc](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/11752dc5ac96f36ebf9a4cad43fa4e4b55c1b21c)) + ## [27.4.35](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.34...t27.4.35) (2023-09-21) ## [27.4.34](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.33...t27.4.34) (2023-09-21) diff --git a/nix/docker/version.json b/nix/docker/version.json index 4efd4d36f..fa92fb1f7 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.35" + "version": "27.4.36" } diff --git a/package-lock.json b/package-lock.json index d2111836e..90d812445 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.35", + "version": "27.4.36", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 441aae286..0f8457c4b 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.35", + "version": "27.4.36", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 7d65cae07..2b3b86260 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.35 +version: 27.4.36 dependencies: - base - yesod From cb9e09d071d22f41a92ab8140d7aaa643c748373 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 21 Sep 2023 14:41:00 +0000 Subject: [PATCH 06/59] fix(lms): disable workaround for late lms success --- src/Jobs/Handler/LMS.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index c29f09ef2..fd05322f6 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -310,7 +310,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act >>= foldMapM procBlock >>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " status set to blocked for qualification " <> tshow qid -- debug, remove later -- D) renew qualifications for all successfull learners - let lrFltrSuccess luser lreport = (E.isNothing (luser E.^. LmsUserStatus) E.||. luser E.^. LmsUserStatus E.!=. E.justVal LmsSuccess) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsPassed -- LMS WORKAROUND 1: LmsPassed replaces any other status + let lrFltrSuccess luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsPassed procRenew (Entity luid luser, Entity _ lreport) = do let repDay = lmsReportDate lreport <|> Just now -- LMS WORKAROUND 2: [supposedly fixed now] sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning From 9bc9a0f1b9538876ee4928d521a2d71323b425a9 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 21 Sep 2023 14:41:29 +0000 Subject: [PATCH 07/59] chore(release): 27.4.37 --- CHANGELOG.md | 7 +++++++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 11 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 2292c68d7..b5c1ce37b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ 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.37](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.36...v27.4.37) (2023-09-21) + + +### Bug Fixes + +* **lms:** disable workaround for late lms success ([cb9e09d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cb9e09d071d22f41a92ab8140d7aaa643c748373)) + ## [27.4.36](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.34...v27.4.36) (2023-09-21) diff --git a/nix/docker/version.json b/nix/docker/version.json index fa92fb1f7..10ec6a2a5 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.36" + "version": "27.4.37" } diff --git a/package-lock.json b/package-lock.json index 90d812445..6100cad20 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.36", + "version": "27.4.37", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 0f8457c4b..bf7f1f8a5 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.36", + "version": "27.4.37", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 2b3b86260..c1954ebb9 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.36 +version: 27.4.37 dependencies: - base - yesod From 8896885bd9883b4cc96c82c3e880199ff12e575a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 21 Sep 2023 16:02:08 +0000 Subject: [PATCH 08/59] Revert "hotfix(lms): lms learner filename for test system changed from qsh to t. !!! REVERT BEFORE PRODUCTION!!!" This reverts commit dfa96c7f3eb061590aa9fff1bd2d4c177c00aaa1. --- src/Handler/LMS/Learners.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Handler/LMS/Learners.hs b/src/Handler/LMS/Learners.hs index 19b5d0ca7..3f8cdf2ab 100644 --- a/src/Handler/LMS/Learners.hs +++ b/src/Handler/LMS/Learners.hs @@ -202,7 +202,7 @@ getLmsLearnersDirectR sid qsh = do , csvUseCrLf = lmsDownloadCrLf } csvOpts = def { csvFormat = fmtOpts } - csvSheetName <- csvFilenameLmsUser "t" -- DEBUG UNDO ME BEFORE PRODUCTION qsh + csvSheetName <- csvFilenameLmsUser qsh let nr = length lms_users msg = "Success. LMS Users download file " <> csvSheetName <> " containing " <> tshow nr <> " rows" $logInfoS "LMS" msg @@ -210,4 +210,4 @@ getLmsLearnersDirectR sid qsh = do csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered -- direct Download see: --- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod +-- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod \ No newline at end of file From 50e4f297b81065034ef962df0f1ed8f7adc51067 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 21 Sep 2023 16:08:02 +0000 Subject: [PATCH 09/59] chore(release): 27.4.38 --- CHANGELOG.md | 2 ++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 6 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index b5c1ce37b..470e3b5e6 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,8 @@ 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.38](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.37...v27.4.38) (2023-09-21) + ## [27.4.37](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.36...v27.4.37) (2023-09-21) diff --git a/nix/docker/version.json b/nix/docker/version.json index 10ec6a2a5..a43038020 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.37" + "version": "27.4.38" } diff --git a/package-lock.json b/package-lock.json index 6100cad20..f5559d6fd 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.37", + "version": "27.4.38", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index bf7f1f8a5..002f15edd 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.37", + "version": "27.4.38", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index c1954ebb9..5753f4541 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.37 +version: 27.4.38 dependencies: - base - yesod From 81b821c88ad309376f0d3493ab7b188f75634edb Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 25 Sep 2023 15:25:38 +0000 Subject: [PATCH 10/59] chore(lms): better links in lms status widget --- src/Handler/Utils/LMS.hs | 20 +++++++++++--------- src/Handler/Utils/Table/Cells.hs | 4 ++-- templates/lms-user.hamlet | 2 +- 3 files changed, 14 insertions(+), 12 deletions(-) diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index e47c58cc1..888e0bac2 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -255,23 +255,20 @@ lmsStatusIcon LmsSuccess{} = IconOK lmsStatusIcon LmsExpired{} = IconExpired lmsStatusIcon _other = IconNotOK -lmsUserStatusWidget :: Bool -> LmsUser -> Widget -lmsUserStatusWidget adminInfo luser = case luser of +lmsUserStatusWidget :: Bool -> Maybe (SomeRoute UniWorX) -> LmsUser -> Widget +lmsUserStatusWidget adminInfo mbLink luser = case luser of LmsUser{lmsUserStatus=Just lStat, lmsUserStatusDay=mbDay} -> [whamlet|$newline never - $maybe aday <- mbDay - ^{formatTimeW SelFormatDateTime aday} - $nothing - --.--.---- + ^{dateWgt mbDay} \ ^{iconFixed (lmsStatusIcon lStat)} $if adminInfo \ ^{lockIcon} \ ^{resetIcon} |] - LmsUser{lmsUserNotified=Just d} -> + LmsUser{lmsUserNotified=mbDay@(Just _)} -> [whamlet|$newline never - ^{formatTimeW SelFormatDateTime d} + ^{dateWgt mbDay} \ ^{iconFixed IconNotificationSent} $if adminInfo \ ^{lockIcon} @@ -280,7 +277,7 @@ lmsUserStatusWidget adminInfo luser = case luser of LmsUser{lmsUserStarted=dstart} | adminInfo -> -- E-Learning started, but not yet notified; only intended for Admins; [whamlet|$newline never - ^{formatTimeW SelFormatDateTime dstart} + ^{dateWgt (Just dstart)} \ ^{iconFixed IconPlanned} $if adminInfo \ ^{resetIcon} @@ -297,3 +294,8 @@ lmsUserStatusWidget adminInfo luser = case luser of resetIcon | lmsUserResetTries luser = iconFixed IconResetTries | otherwise = mempty + + dateWgt :: Maybe UTCTime -> Widget + dateWgt = maybe id (flip modal . Left ) mbLink . + maybe (text2widget "--.--.----") (formatTimeW SelFormatDateTime) + diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 8c77f1dfa..e945ff8d2 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -426,10 +426,10 @@ cryptoidCell :: (IsDBTable m a, PathPiece cid) => cid -> DBCell m a cryptoidCell = addCellClass ("cryptoid" :: Text) . textCell . toPathPiece lmsStatusCell :: IsDBTable m a => Bool -> Maybe (CryptoUUIDUser -> Route UniWorX) -> LmsUser -> DBCell m a -lmsStatusCell extendedInfo Nothing lu = wgtCell $ lmsUserStatusWidget extendedInfo lu +lmsStatusCell extendedInfo Nothing lu = wgtCell $ lmsUserStatusWidget extendedInfo Nothing lu lmsStatusCell extendedInfo (Just toLink) lu = cell $ do uuid <- liftHandler $ encrypt $ lu ^. _lmsUserUser - modal (lmsUserStatusWidget extendedInfo lu) (Left $ SomeRoute $ toLink uuid) + lmsUserStatusWidget extendedInfo (Just $ SomeRoute $ toLink uuid) lu lmsStateCell :: IsDBTable m a => LmsState -> DBCell m a lmsStateCell LmsFailed = iconBoolCell False diff --git a/templates/lms-user.hamlet b/templates/lms-user.hamlet index a084f582a..db87888e7 100644 --- a/templates/lms-user.hamlet +++ b/templates/lms-user.hamlet @@ -43,7 +43,7 @@ $else
^{formatTimeW SelFormatDateTime (lmsUserStarted lmsUsr)} $maybe _ <- lmsUserStatus lmsUsr
_{MsgTableLmsStatus} -
^{lmsUserStatusWidget True lmsUsr} +
^{lmsUserStatusWidget True Nothing lmsUsr}
_{MsgTableLmsIdent}
From f7b2f354212c02582423b335168561b66bd00d62 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 25 Sep 2023 15:39:09 +0000 Subject: [PATCH 11/59] refactor(lms): clean code for nicer links in lms status widget --- src/Handler/Utils/LMS.hs | 12 ++++++++---- src/Handler/Utils/Table/Cells.hs | 5 +---- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index 888e0bac2..e67fc4e05 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -255,7 +255,7 @@ lmsStatusIcon LmsSuccess{} = IconOK lmsStatusIcon LmsExpired{} = IconExpired lmsStatusIcon _other = IconNotOK -lmsUserStatusWidget :: Bool -> Maybe (SomeRoute UniWorX) -> LmsUser -> Widget +lmsUserStatusWidget :: Bool -> Maybe (CryptoUUIDUser -> Route UniWorX) -> LmsUser -> Widget lmsUserStatusWidget adminInfo mbLink luser = case luser of LmsUser{lmsUserStatus=Just lStat, lmsUserStatusDay=mbDay} -> [whamlet|$newline never @@ -296,6 +296,10 @@ lmsUserStatusWidget adminInfo mbLink luser = case luser of | otherwise = mempty dateWgt :: Maybe UTCTime -> Widget - dateWgt = maybe id (flip modal . Left ) mbLink . - maybe (text2widget "--.--.----") (formatTimeW SelFormatDateTime) - + dateWgt = + let mkDayWgt = maybe (text2widget "--.--.----") (formatTimeW SelFormatDateTime) + in case mbLink of + Nothing -> mkDayWgt + (Just mkLink) -> \mbDay -> do + uuid <- liftHandler $ encrypt $ luser ^. _lmsUserUser + modal (mkDayWgt mbDay) $ Left $ SomeRoute $ mkLink uuid diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index e945ff8d2..42970a046 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -426,10 +426,7 @@ cryptoidCell :: (IsDBTable m a, PathPiece cid) => cid -> DBCell m a cryptoidCell = addCellClass ("cryptoid" :: Text) . textCell . toPathPiece lmsStatusCell :: IsDBTable m a => Bool -> Maybe (CryptoUUIDUser -> Route UniWorX) -> LmsUser -> DBCell m a -lmsStatusCell extendedInfo Nothing lu = wgtCell $ lmsUserStatusWidget extendedInfo Nothing lu -lmsStatusCell extendedInfo (Just toLink) lu = cell $ do - uuid <- liftHandler $ encrypt $ lu ^. _lmsUserUser - lmsUserStatusWidget extendedInfo (Just $ SomeRoute $ toLink uuid) lu +lmsStatusCell extendedInfo mkLink = wgtCell . lmsUserStatusWidget extendedInfo mkLink lmsStateCell :: IsDBTable m a => LmsState -> DBCell m a lmsStateCell LmsFailed = iconBoolCell False From bb708ca540557b41d33996cfea9a390a457ed855 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 25 Sep 2023 15:46:48 +0000 Subject: [PATCH 12/59] fix(qualifications): latest block could ignore itself --- src/Handler/Utils/Qualification.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index b2edbf325..f94aa67b2 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -71,17 +71,19 @@ quserToNotify quser cutoff = ) ) --- condition to ensure that the lastes QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended +-- condition to ensure that the lastest QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended isLatestBlockBefore :: E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool) isLatestBlockBefore qualBlock cutoff = (cutoff E.>~. qualBlock E.?. QualificationUserBlockFrom) E.&&. E.notExists (do newerBlock <- E.from $ E.table @QualificationUserBlock E.where_ $ newerBlock E.^. QualificationUserBlockQualificationUser E.=?. qualBlock E.?. QualificationUserBlockQualificationUser E.&&. newerBlock E.^. QualificationUserBlockFrom E.<=. cutoff + E.&&. E.just(newerBlock E.^. QualificationUserBlockId) E.!=. qualBlock E.?. QualificationUserBlockId E.&&. ((E.just(newerBlock E.^. QualificationUserBlockFrom) E.>. qualBlock E.?. QualificationUserBlockFrom) E.||. ( newerBlock E.^. QualificationUserBlockUnblock -- in case of equal timestamps, any unblock wins E.&&. (newerBlock E.^. QualificationUserBlockFrom E.=?. qualBlock E.?. QualificationUserBlockFrom) - )) + )) ) + -- cutoff can be `E.val now` or even `Database.Esqueleto.PostgreSQL.now_` quserBlockAux :: Bool -> E.SqlExpr (E.Value UTCTime) -> (E.SqlExpr (E.Value QualificationUserId) -> E.SqlExpr (E.Value Bool)) -> Maybe (E.SqlExpr (Entity QualificationUserBlock) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool) quserBlockAux negCond cutoff checkQualUserId mbBlockCondition = bool E.notExists E.exists negCond $ do From a84812640f02981875275c96e37338de4ab49996 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 26 Sep 2023 09:55:16 +0000 Subject: [PATCH 13/59] fix(lms): do not mark lms users with open status as ended --- src/Jobs/Handler/LMS.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index fd05322f6..42105c664 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -329,6 +329,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act E.set luser [ LmsUserEnded E.=. E.justVal now ] E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification E.&&. E.isNothing (luser E.^. LmsUserEnded ) + E.&&. E.isJust (luser E.^. LmsUserStatus ) -- status is decided E.&&. E.isJust (luser E.^. LmsUserReceived) -- seen before, for otherwise it might not have been started yet E.&&. E.notExists (do lreport <- E.from $ E.table @LmsReport From 330e89bb6bd9942139d8eb427755f033f90ae637 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 26 Sep 2023 09:55:46 +0000 Subject: [PATCH 14/59] chore(release): 27.4.39 --- 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 470e3b5e6..df333baa7 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.39](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.38...v27.4.39) (2023-09-26) + + +### Bug Fixes + +* **lms:** do not mark lms users with open status as ended ([a848126](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a84812640f02981875275c96e37338de4ab49996)) +* **qualifications:** latest block could ignore itself ([bb708ca](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/bb708ca540557b41d33996cfea9a390a457ed855)) + ## [27.4.38](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.37...v27.4.38) (2023-09-21) ## [27.4.37](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.36...v27.4.37) (2023-09-21) diff --git a/nix/docker/version.json b/nix/docker/version.json index a43038020..8475f663a 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.38" + "version": "27.4.39" } diff --git a/package-lock.json b/package-lock.json index f5559d6fd..806db5c5f 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.38", + "version": "27.4.39", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 002f15edd..107816c80 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.38", + "version": "27.4.39", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 5753f4541..9c4afab1f 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.38 +version: 27.4.39 dependencies: - base - yesod From 095fde54b78f69831be4251970719dbec958af18 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 26 Sep 2023 09:56:50 +0000 Subject: [PATCH 15/59] chore(release): 27.4.40 --- CHANGELOG.md | 2 ++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 6 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index df333baa7..8d908dced 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,8 @@ 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.40](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.39...v27.4.40) (2023-09-26) + ## [27.4.39](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.38...v27.4.39) (2023-09-26) diff --git a/nix/docker/version.json b/nix/docker/version.json index 8475f663a..d2bbd19ec 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.39" + "version": "27.4.40" } diff --git a/package-lock.json b/package-lock.json index 806db5c5f..ea1aedb59 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.39", + "version": "27.4.40", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 107816c80..1573086fc 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.39", + "version": "27.4.40", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 9c4afab1f..9f4a87b4a 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.39 +version: 27.4.40 dependencies: - base - yesod From f48862efbcb95e92203a200267e1bcc613af4af1 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 26 Sep 2023 16:15:58 +0000 Subject: [PATCH 16/59] fix(lms): sorting and filtering lms status --- src/Database/Esqueleto/Utils.hs | 13 ++++++++++++- src/Handler/LMS.hs | 6 +++++- src/Handler/Qualification.hs | 9 ++++++--- src/Jobs/Handler/LMS.hs | 2 +- 4 files changed, 24 insertions(+), 6 deletions(-) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index bac61ff27..a3e4d8368 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -20,7 +20,7 @@ module Database.Esqueleto.Utils , subSelectAnd, subSelectOr , mkExactFilter, mkExactFilterWith , mkExactFilterLast, mkExactFilterLastWith - , mkExactFilterMaybeLast + , mkExactFilterMaybeLast, mkExactFilterMaybeLast' , mkContainsFilter, mkContainsFilterWith , mkContainsFilterWithSet, mkContainsFilterWithComma, mkContainsFilterWithCommaPlus , mkDayFilter, mkDayFilterFrom, mkDayFilterTo @@ -313,6 +313,17 @@ mkExactFilterMaybeLast lenslike row criterias | Last (Just crit) <- criterias = lenslike row E.==. E.val crit | otherwise = true +-- | like `mkExactFilterMaybeLast` but for doubly wrapped Maybes +mkExactFilterMaybeLast' :: PersistField a + => (t -> E.SqlExpr (E.Value (Maybe (Maybe a)))) -- ^ getter from query to searched element + -> t -- ^ query row + -> Last (Maybe a) -- ^ needle + -> E.SqlExpr (E.Value Bool) +mkExactFilterMaybeLast' lenslike row criterias + | Last (Just Nothing) <- criterias = lenslike row E.==. E.val (Just Nothing) + | Last (Just crit) <- criterias = lenslike row E.==. E.val (Just crit) + | otherwise = true + -- | generic filter creation for dbTable -- Given a lens-like function, make filter searching for needles in String-like elements -- (Keep Set here to ensure that there are no duplicates) diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index eff51bb81..4986ac5d1 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -465,7 +465,11 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) , single ("ident" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserIdent)) , single ("pin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserPin)) - , single ("status" , SortColumnNullsInv $ views (to queryLmsUser) (E.^. LmsUserStatus)) + -- , single ("status" , SortColumnNullsInv $ views (to queryLmsUser) (E.^. LmsUserStatusDay)) + , single ("status" , SortColumnNeverNull $ \row -> E.coalesceDefault [ queryLmsUser row E.^. LmsUserStatusDay + , queryLmsUser row E.^. LmsUserNotified + ](queryLmsUser row E.?. LmsUserStarted)) + , single ("started" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserStarted)) , single ("datepin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserDatePin)) , single ("received" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserReceived)) diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 7abf93a93..a1d3763d1 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -391,9 +391,10 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do , single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified)) , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) , single ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom)) - , single ("lms-status-plus",SortColumnNeverNull $ \row -> E.coalesce [E.explicitUnsafeCoerceSqlExprValue "timestamp" $ (queryLmsUser row E.?. LmsUserStatus) E.#>>. "{day}" - , queryLmsUser row E.?. LmsUserStarted]) - , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) + , single ("lms-status-plus",SortColumnNeverNull $ \row -> E.coalesce [ E.joinV (queryLmsUser row E.?. LmsUserStatusDay) + , E.joinV (queryLmsUser row E.?. LmsUserNotified) + , queryLmsUser row E.?. LmsUserStarted]) + , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) , single ("user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId @@ -440,6 +441,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do if | Just True <- getLast criterion -> quser `quserToNotify` now | otherwise -> E.true ) + , single ("status" , FilterColumn . E.mkExactFilterMaybeLast' $ views (to queryLmsUser) (E.?. LmsUserStatus)) ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgLmsUser mPrev @@ -451,6 +453,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do , if isNothing mbRenewal then mempty else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) , prismAForm (singletonFilter "tobe-notified" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsNotificationDue) + , prismAForm (singletonFilter "status" . maybePrism _PathPiece) mPrev $ aopt (hoistField liftHandler (selectField optionsFinite) :: (Field _ (Maybe LmsStatus))) (fslI MsgTableLmsStatus) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtCsvEncode = Just DBTCsvEncode diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 42105c664..7899cbf3e 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -208,7 +208,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act when (quali ^. _qualificationExpiryNotification) $ do notifyInvalidDrivers <- E.select $ do quser <- E.from $ E.table @QualificationUser - E.where_ $ E.not_ (quser `qualificationValid` now) -- currently invalid + E.where_ $ E.not_ (validQualification now quser) -- currently invalid E.&&. quser E.^. QualificationUserQualification E.==. E.val qid -- correct qualification E.&&. quser `quserToNotify` now -- recently became invalid or blocked pure (quser E.^. QualificationUserUser) From ae4470333e2b1b5c271b38092210c094822f4a19 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 27 Sep 2023 09:31:50 +0000 Subject: [PATCH 17/59] fix(lms): sorting and filtering lms status works throughout now --- src/Database/Esqueleto/Utils.hs | 13 +++++++------ src/Handler/LMS.hs | 2 +- src/Handler/Qualification.hs | 2 +- 3 files changed, 9 insertions(+), 8 deletions(-) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index a3e4d8368..53a480fa8 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -314,13 +314,14 @@ mkExactFilterMaybeLast lenslike row criterias | otherwise = true -- | like `mkExactFilterMaybeLast` but for doubly wrapped Maybes -mkExactFilterMaybeLast' :: PersistField a - => (t -> E.SqlExpr (E.Value (Maybe (Maybe a)))) -- ^ getter from query to searched element - -> t -- ^ query row - -> Last (Maybe a) -- ^ needle +mkExactFilterMaybeLast' :: (PersistField a, PersistField b) + => (t -> E.SqlExpr (E.Value (Maybe b))) -- ^ getter from query ensure entity exists at all + -> (t -> E.SqlExpr (E.Value (Maybe (Maybe a)))) -- ^ getter from query to searched element + -> t -- ^ query row + -> Last (Maybe a) -- ^ needle -> E.SqlExpr (E.Value Bool) -mkExactFilterMaybeLast' lenslike row criterias - | Last (Just Nothing) <- criterias = lenslike row E.==. E.val (Just Nothing) +mkExactFilterMaybeLast' lensexists lenslike row criterias + | Last (Just Nothing) <- criterias = isJust (lensexists row) E.&&. E.isNothing (E.joinV $ lenslike row) | Last (Just crit) <- criterias = lenslike row E.==. E.val (Just crit) | otherwise = true diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 4986ac5d1..c15a5ebaf 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -468,7 +468,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do -- , single ("status" , SortColumnNullsInv $ views (to queryLmsUser) (E.^. LmsUserStatusDay)) , single ("status" , SortColumnNeverNull $ \row -> E.coalesceDefault [ queryLmsUser row E.^. LmsUserStatusDay , queryLmsUser row E.^. LmsUserNotified - ](queryLmsUser row E.?. LmsUserStarted)) + ](queryLmsUser row E.^. LmsUserStarted)) , single ("started" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserStarted)) , single ("datepin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserDatePin)) diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index a1d3763d1..b275c3e31 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -441,7 +441,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do if | Just True <- getLast criterion -> quser `quserToNotify` now | otherwise -> E.true ) - , single ("status" , FilterColumn . E.mkExactFilterMaybeLast' $ views (to queryLmsUser) (E.?. LmsUserStatus)) + , single ("status" , FilterColumn . E.mkExactFilterMaybeLast' (views (to queryLmsUser) (E.?. LmsUserId)) $ views (to queryLmsUser) (E.?. LmsUserStatus)) ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgLmsUser mPrev From cdb23115effe3d1015094530b64aa959de008062 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 27 Sep 2023 15:36:05 +0000 Subject: [PATCH 18/59] refactor(lms): clean lms handling code --- src/Handler/LMS.hs | 4 +- src/Handler/LMS/Learners.hs | 2 +- src/Handler/Utils/Qualification.hs | 2 +- src/Jobs/Handler/LMS.hs | 222 +++++++++++++++-------------- 4 files changed, 116 insertions(+), 114 deletions(-) diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index c15a5ebaf..ed1b829b3 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -741,7 +741,7 @@ postLmsR sid qsh = do forM_ shortUsers $ upsertQualificationUser qid nowaday cutoff Nothing fromIntegral <$> (if isReset - then updateWhereCount ([LmsUserQualification ==. qid, LmsUserUser <-. usersList, LmsUserResetTries ==. False] -- , 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 + 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 ++ ([LmsUserStatus ==. Just LmsBlocked] ||. [LmsUserStatus ==. Just LmsExpired])) [LmsUserResetTries =. True] else deleteWhereCount [LmsUserQualification ==. qid, LmsUserUser <-. usersList] ) @@ -768,7 +768,7 @@ postLmsR sid qsh = do numExaminees <- runDB $ do okUsers <- selectList [ LmsUserQualification ==. qid -- matching qualification , LmsUserEnded ==. Nothing -- not yet deleted - , LmsUserStatus ==. Nothing -- not yet decided + -- , LmsUserStatus ==. Nothing -- not yet decided , LmsUserUser <-. Set.toList selectedUsers -- selected ] [] forM_ okUsers $ \(Entity lid LmsUser {lmsUserUser = uid, lmsUserQualification = qid'}) -> do diff --git a/src/Handler/LMS/Learners.hs b/src/Handler/LMS/Learners.hs index 3f8cdf2ab..31f9ce8bd 100644 --- a/src/Handler/LMS/Learners.hs +++ b/src/Handler/LMS/Learners.hs @@ -204,7 +204,7 @@ getLmsLearnersDirectR sid qsh = do csvOpts = def { csvFormat = fmtOpts } csvSheetName <- csvFilenameLmsUser qsh let nr = length lms_users - msg = "Success. LMS Users download file " <> csvSheetName <> " containing " <> tshow nr <> " rows" + msg = "Success. LMS user learners download file " <> csvSheetName <> " containing " <> tshow nr <> " rows" $logInfoS "LMS" msg addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\"" csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index f94aa67b2..9c877906a 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -263,7 +263,7 @@ qualificationUserBlocking qid uids unblock mbBlockTime (qualificationBlockReason , qualificationUserBlockBlocker = authUsr })) toChange E.insertMany_ (snd <$> newBlocks) - unless notify $ updateWhere [QualificationUserId <-. (qualificationUserBlockQualificationUser . snd <$> newBlocks)] [QualificationUserLastNotified =. now] + unless notify $ updateWhere [QualificationUserId <-. (qualificationUserBlockQualificationUser . snd <$> newBlocks)] [QualificationUserLastNotified =. addUTCTime 1 blockTime] forM_ newBlocks $ \(uid, qub) -> audit TransactionQualificationUserBlocking { transactionQualification = qid , transactionUser = uid diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 7899cbf3e..5550e0706 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -196,7 +196,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid E.&&. luser E.^. LmsUserQualification E.==. E.val qid E.&&. E.isNothing (luser E.^. LmsUserStatus) - E.&&. E.isNothing (luser E.^. LmsUserEnded) + -- E.&&. E.isNothing (luser E.^. LmsUserEnded) E.&&. E.not_ (validQualification now quser) pure (luser E.^. LmsUserId) nrExpired <- E.updateCount $ \luser -> do @@ -205,7 +205,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act E.&&. luser E.^. LmsUserQualification E.==. E.val qid $logInfoS "LMS" $ "Expired lms users " <> tshow nrExpired <> " for qualification " <> qshort - when (quali ^. _qualificationExpiryNotification) $ do + when (quali ^. _qualificationExpiryNotification) $ do -- notifies expired and previously lms-failed drivers notifyInvalidDrivers <- E.select $ do quser <- E.from $ E.table @QualificationUser E.where_ $ E.not_ (validQualification now quser) -- currently invalid @@ -254,119 +254,121 @@ dispatchJobLmsReports qid = JobHandlerAtomic act act = whenM (exists [LmsReportQualification ==. qid]) $ do -- executing twice must be prohibited due to assertion that ALL learners are always sent (D fails otherwise) now <- liftIO getCurrentTime -- DEBUG 2rows; remove later - totalrows <- count [LmsReportQualification ==. qid] + totalrows <- count [LmsReportQualification ==. qid] $logInfoS "LMS" $ "Report processing " <> tshow totalrows <> " rows for qualification " <> tshow qid - let -- locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now -- no longer necessary, since LMS reports dates only - -- DB query for LmsUserUser, provided a matching LmsReport exists - luserQry luFltr repFltr = E.select $ do - luser <- E.from $ E.table @LmsUser - E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification - E.&&. E.isNothing (luser E.^. LmsUserEnded) -- ignore all closed learners - E.&&. luFltr luser - E.&&. E.exists (do + when (totalrows > 0) $ do + let -- locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now -- no longer necessary, since LMS reports dates only + -- DB query for LmsUserUser, provided a matching LmsReport exists + luserQry luFltr repFltr = E.select $ do + luser <- E.from $ E.table @LmsUser + E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification + E.&&. E.isNothing (luser E.^. LmsUserEnded) -- ignore all closed learners + E.&&. luFltr luser + E.&&. E.exists (do + lreport <- E.from $ E.table @LmsReport + E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent + E.&&. lreport E.^. LmsReportQualification E.==. E.val qid + E.&&. repFltr luser lreport + ) + return $ luser E.^. LmsUserUser + -- DB query for LmsUser innerJoin LmsReport + lrepQry lrFltr = E.select $ do + (luser :& lreport) <- E.from $ E.table @LmsUser`E.innerJoin` E.table @LmsReport + `E.on` (\(luser :& lreport) -> luser E.^. LmsUserIdent E.==. lreport E.^. LmsReportIdent + E.&&. luser E.^. LmsUserQualification E.==. lreport E.^. LmsReportQualification) + E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid + E.&&. lreport E.^. LmsReportQualification E.==. E.val qid + E.&&. E.isNothing (luser E.^. LmsUserEnded) -- ignore all closed learners + E.&&. lrFltr luser lreport + return (luser, lreport) + -- A) reset status for learners that had their tries just resetted as indicated by LmsOpen + E.update $ \luser -> do + E.set luser [ LmsUserStatus E.=. E.nothing + , LmsUserStatusDay E.=. E.nothing + , LmsUserResetTries E.=. E.false ] + E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification + E.&&. E.isNothing (luser E.^. LmsUserEnded ) -- must still exist at server + E.&&. E.isJust (luser E.^. LmsUserReceived) -- seen before, for otherwise it might not have been started yet + E.&&. luser E.^. LmsUserResetTries + E.&&. E.exists (do lreport <- E.from $ E.table @LmsReport E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent E.&&. lreport E.^. LmsReportQualification E.==. E.val qid - E.&&. repFltr luser lreport - ) - return $ luser E.^. LmsUserUser - -- DB query for LmsUser innerJoin LmsReport - lrepQry lrFltr = E.select $ do - (luser :& lreport) <- E.from $ E.table @LmsUser`E.innerJoin` E.table @LmsReport - `E.on` (\(luser :& lreport) -> luser E.^. LmsUserIdent E.==. lreport E.^. LmsReportIdent - E.&&. luser E.^. LmsUserQualification E.==. lreport E.^. LmsReportQualification) - E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid - E.&&. lreport E.^. LmsReportQualification E.==. E.val qid - E.&&. E.isNothing (luser E.^. LmsUserEnded) -- ignore all closed learners - E.&&. lrFltr luser lreport - return (luser, lreport) - -- A) reset status for learners that had their tries just resetted as indicated by LmsOpen - E.update $ \luser -> do - E.set luser [ LmsUserStatus E.=. E.nothing - , LmsUserResetTries E.=. E.false ] - E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification - E.&&. E.isNothing (luser E.^. LmsUserEnded ) -- must still exist at server - E.&&. E.isJust (luser E.^. LmsUserReceived) -- seen before, for otherwise it might not have been started yet - E.&&. luser E.^. LmsUserResetTries - E.&&. E.exists (do - lreport <- E.from $ E.table @LmsReport - E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent - E.&&. lreport E.^. LmsReportQualification E.==. E.val qid - E.&&. lreport E.^. LmsReportResult E.==. E.val LmsOpen - E.&&. lreport E.^. LmsReportLock E.==. E.true - ) - -- B) notify all newly reported users that lms is available - let luserFltrNew luser = E.isNothing $ luser E.^. LmsUserReceived -- not seen before, just starting - notifyNewLearner (E.Value uid) = queueDBJob JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False } } - in luserQry luserFltrNew (const $ const E.true) >>= mapM_ notifyNewLearner - -- C) block qualifications for failed learners by calling qualificationUserBlocking [uids] (includes audit) - let lrFltrBlock luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsFailed - procBlock (Entity luid luser, Entity _ lreport) = do - let repDay = lmsReportDate lreport <|> Just now - ok_block <- qualificationUserBlocking qid [lmsUserUser luser] False (lmsReportDate lreport) (Right QualificationBlockFailedELearning) True -- only valid qualifications are blocked; transcribes to audit log - update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. repDay] - return $ Sum ok_block - in lrepQry lrFltrBlock - >>= foldMapM procBlock - >>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " status set to blocked for qualification " <> tshow qid -- debug, remove later - -- D) renew qualifications for all successfull learners - let lrFltrSuccess luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsPassed - procRenew (Entity luid luser, Entity _ lreport) = do - let repDay = lmsReportDate lreport <|> Just now - -- LMS WORKAROUND 2: [supposedly fixed now] sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning - -- let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning - -- ok_unblock <- qualificationUserUnblockByReason qid [lmsUserUser luser] repTime (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log - -- when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid} having success reported after initially failed e-learning|]) - -- END LMS WORKAROUND 2 - ok_renew <- renewValidQualificationUsers qid repDay [lmsUserUser luser]-- only valid qualifications are truly renewed; transcribes to audit log - update luid [LmsUserStatus =. Just LmsSuccess, LmsUserStatusDay =. repDay] - return $ Sum ok_renew - in lrepQry lrFltrSuccess - >>= foldMapM procRenew - >>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " renewed and status set to success for qualification " <> tshow qid -- debug, remove later - -- E) mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected) - E.update $ \luser -> do - E.set luser [ LmsUserEnded E.=. E.justVal now ] - E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification - E.&&. E.isNothing (luser E.^. LmsUserEnded ) - E.&&. E.isJust (luser E.^. LmsUserStatus ) -- status is decided - E.&&. E.isJust (luser E.^. LmsUserReceived) -- seen before, for otherwise it might not have been started yet - E.&&. E.notExists (do - lreport <- E.from $ E.table @LmsReport - E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent - E.&&. lreport E.^. LmsReportQualification E.==. E.val qid - ) - - -- F) lock expired learners: happens during JobLmsDequeue only - -- G) update lock and received - let updateReceivedLocked lockstatus = E.updateCount $ \luser -> do -- due to the absence of UPDATE..FROM in esqueleto, we call update twice - E.set luser [ LmsUserReceived E.=. E.justVal now - , LmsUserLocked E.=. E.val lockstatus ] - E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification - E.&&. E.isNothing (luser E.^. LmsUserEnded) - E.&&. E.exists (do - lreport <- E.from $ E.table @LmsReport - E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent - E.&&. lreport E.^. LmsReportQualification E.==. E.val qid - E.&&. lreport E.^. LmsReportLock E.==. E.val lockstatus -- Maybe more efficient, but less readable: bool E.not_ id lockstatus (lreport E.^. LmsReport Lock) + E.&&. lreport E.^. LmsReportResult E.==. E.val LmsOpen + E.&&. lreport E.^. LmsReportLock E.==. E.true ) - -- NOTE: this code leads to a runtime errror; apparently from-clauses are not allowed in updates yet - -- let updateReceivedLocked lockstatus = E.update $ \luser -> do -- attempt to use 'from'-clause in update as per PostgreSQL - -- E.set luser [ LmsUserReceived E.=. E.justVal now - -- , LmsUserLocked E.=. E.val lockstatus ] - -- lreport <- E.from $ E.table @LmsReport - -- E.where_ $ E.isNothing (luser E.^. LmsUserEnded) - -- E.&&. luser E.^. LmsUserQualification E.==. E.val qid - -- E.&&. lreport E.^. LmsReportQualification E.==. E.val qid - -- E.&&. lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent - -- E.&&. lreport E.^. LmsReportLock E.==. E.val lockstatus -- Maybe more efficient, but less readable: bool E.not_ id lockstatus (lreport E.^. LmsReport Lock) - updateReceivedLocked False - >>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as unlocked and received for qualification " <> tshow qid -- debug, remove later - updateReceivedLocked True - >>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as locked and received for qualification " <> tshow qid -- debug, remove later - -- G) Truncate LmsReport for qid and log - repProc <- deleteWhereCount [LmsReportQualification ==. qid] - $logInfoS "LMS" [st|Processed #{tshow repProc} e-learning status reports for qualification #{tshow qid}.|] + -- B) notify all newly reported users that lms is available + let luserFltrNew luser = E.isNothing $ luser E.^. LmsUserReceived -- not seen before, just starting + notifyNewLearner (E.Value uid) = queueDBJob JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False } } + in luserQry luserFltrNew (const $ const E.true) >>= mapM_ notifyNewLearner + -- C) block qualifications for failed learners by calling qualificationUserBlocking [uids] (includes audit), notified during expiry + let lrFltrBlock luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsFailed + procBlock (Entity luid luser, Entity _ lreport) = do + let repDay = lmsReportDate lreport <|> Just now + ok_block <- qualificationUserBlocking qid [lmsUserUser luser] False (lmsReportDate lreport) (Right QualificationBlockFailedELearning) True -- only valid qualifications are blocked; transcribes to audit log + update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. repDay] + return $ Sum ok_block + in lrepQry lrFltrBlock + >>= foldMapM procBlock + >>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " status set to blocked for qualification " <> tshow qid -- debug, remove later + -- D) renew qualifications for all successfull learners + let lrFltrSuccess luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsPassed + procRenew (Entity luid luser, Entity _ lreport) = do + let repDay = lmsReportDate lreport <|> Just now + -- LMS WORKAROUND 2: [supposedly fixed now] sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning + -- let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning + -- ok_unblock <- qualificationUserUnblockByReason qid [lmsUserUser luser] repTime (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log + -- when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid} having success reported after initially failed e-learning|]) + -- END LMS WORKAROUND 2 + ok_renew <- renewValidQualificationUsers qid repDay [lmsUserUser luser]-- only valid qualifications are truly renewed; transcribes to audit log + update luid [LmsUserStatus =. Just LmsSuccess, LmsUserStatusDay =. repDay] + return $ Sum ok_renew + in lrepQry lrFltrSuccess + >>= foldMapM procRenew + >>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " renewed and status set to success for qualification " <> tshow qid -- debug, remove later + -- E) mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected) + E.update $ \luser -> do + E.set luser [ LmsUserEnded E.=. E.justVal now ] + E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification + E.&&. E.isNothing (luser E.^. LmsUserEnded ) + E.&&. E.isJust (luser E.^. LmsUserStatus ) -- status is decided + E.&&. E.isJust (luser E.^. LmsUserReceived) -- seen before, for otherwise it might not have been started yet + E.&&. E.notExists (do + lreport <- E.from $ E.table @LmsReport + E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent + E.&&. lreport E.^. LmsReportQualification E.==. E.val qid + ) + + -- F) lock expired learners: happens during JobLmsDequeue only + -- G) update lock and received + let updateReceivedLocked lockstatus = E.updateCount $ \luser -> do -- due to the absence of UPDATE..FROM in esqueleto, we call update twice + E.set luser [ LmsUserReceived E.=. E.justVal now + , LmsUserLocked E.=. E.val lockstatus ] + E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification + -- E.&&. E.isNothing (luser E.^. LmsUserEnded) -- should always be true, but maybe there is a bug? + E.&&. E.exists (do + lreport <- E.from $ E.table @LmsReport + E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent + E.&&. lreport E.^. LmsReportQualification E.==. E.val qid + E.&&. lreport E.^. LmsReportLock E.==. E.val lockstatus -- Maybe more efficient, but less readable: bool E.not_ id lockstatus (lreport E.^. LmsReport Lock) + ) + -- NOTE: this code leads to a runtime errror; apparently from-clauses are not allowed in updates yet + -- let updateReceivedLocked lockstatus = E.update $ \luser -> do -- attempt to use 'from'-clause in update as per PostgreSQL + -- E.set luser [ LmsUserReceived E.=. E.justVal now + -- , LmsUserLocked E.=. E.val lockstatus ] + -- lreport <- E.from $ E.table @LmsReport + -- E.where_ $ E.isNothing (luser E.^. LmsUserEnded) + -- E.&&. luser E.^. LmsUserQualification E.==. E.val qid + -- E.&&. lreport E.^. LmsReportQualification E.==. E.val qid + -- E.&&. lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent + -- E.&&. lreport E.^. LmsReportLock E.==. E.val lockstatus -- Maybe more efficient, but less readable: bool E.not_ id lockstatus (lreport E.^. LmsReport Lock) + updateReceivedLocked False + >>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as unlocked and received for qualification " <> tshow qid -- debug, remove later + updateReceivedLocked True + >>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as locked and received for qualification " <> tshow qid -- debug, remove later + -- G) Truncate LmsReport for qid and log + repProc <- deleteWhereCount [LmsReportQualification ==. qid] + $logInfoS "LMS" [st|Processed #{tshow repProc} e-learning status reports for qualification #{tshow qid}.|] -- DEPRECATED processes received results and lengthen qualifications, if applicable From 382fa7fc079e8cb086a0f50b959ccb4cd441382d Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 27 Sep 2023 15:43:56 +0000 Subject: [PATCH 19/59] chore(lms): disable inefficient non-working filter for qusertonotify --- src/Handler/Qualification.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index b275c3e31..ddc7154b0 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -437,10 +437,10 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday | otherwise -> E.true ) - , single ("tobe-notified", FilterColumn $ \(queryQualUser -> quser) criterion -> - if | Just True <- getLast criterion -> quser `quserToNotify` now - | otherwise -> E.true - ) + -- , single ("tobe-notified", FilterColumn $ \(queryQualUser -> quser) criterion -> + -- if | Just True <- getLast criterion -> quser `quserToNotify` now + -- | otherwise -> E.true + -- ) , single ("status" , FilterColumn . E.mkExactFilterMaybeLast' (views (to queryLmsUser) (E.?. LmsUserId)) $ views (to queryLmsUser) (E.?. LmsUserStatus)) ] dbtFilterUI mPrev = mconcat @@ -452,7 +452,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) , if isNothing mbRenewal then mempty else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) - , prismAForm (singletonFilter "tobe-notified" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsNotificationDue) + -- , prismAForm (singletonFilter "tobe-notified" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsNotificationDue) , prismAForm (singletonFilter "status" . maybePrism _PathPiece) mPrev $ aopt (hoistField liftHandler (selectField optionsFinite) :: (Field _ (Maybe LmsStatus))) (fslI MsgTableLmsStatus) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } From 8b0218ba89cc947c5e5d3b431513fd096622c122 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 28 Sep 2023 11:29:02 +0000 Subject: [PATCH 20/59] refactor(qualification): more efficient correct code to discern expiry notifications --- src/Database/Esqueleto/Utils.hs | 7 +++++ src/Handler/Qualification.hs | 32 +++++++++++------------ src/Handler/Utils/Qualification.hs | 41 +++++++++--------------------- src/Jobs/Handler/LMS.hs | 13 +++++++--- 4 files changed, 44 insertions(+), 49 deletions(-) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 53a480fa8..dc9f5159e 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -33,6 +33,7 @@ module Database.Esqueleto.Utils , selectExists, selectNotExists , SqlHashable , sha256 + , isTrue, isFalse , maybe, maybe2, maybeEq, guardMaybe, unsafeCoalesce , bool , max, min @@ -488,6 +489,12 @@ sha256 :: SqlHashable a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value (Digest S sha256 = E.unsafeSqlFunction "digest" . (, E.val "sha256" :: E.SqlExpr (E.Value Text)) +isTrue :: E.SqlExpr (E.Value (Maybe Bool)) -> E.SqlExpr (E.Value Bool) +isTrue expr = E.unsafeSqlBinOp "IS TRUE" expr $ E.unsafeSqlValue "" + +isFalse :: E.SqlExpr (E.Value (Maybe Bool)) -> E.SqlExpr (E.Value Bool) +isFalse expr = E.unsafeSqlBinOp "IS FALSE" expr $ E.unsafeSqlValue "" + maybe :: (PersistField a, PersistField b) => E.SqlExpr (E.Value b) -> (E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value b)) diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index ddc7154b0..6553bb300 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -30,7 +30,7 @@ import Database.Persist.Sql (updateWhereCount) import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Legacy as E -import qualified Database.Esqueleto.PostgreSQL as E +-- import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH @@ -328,17 +328,17 @@ blockActRemoveSupervisors _ = False -- E.where_ $ fltr qualUser E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) -- return (qualUser, user, lmsUser) -qualificationTableQuery :: QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr +qualificationTableQuery :: UTCTime -> QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) , E.SqlExpr (Entity User) , E.SqlExpr (Maybe (Entity LmsUser)) , E.SqlExpr (Maybe (Entity QualificationUserBlock)) ) -qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do +qualificationTableQuery now qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do -- E.distinctOnOrderBy will not work: sorting with dbTable should work, except that columns contained in distinctOnOrderBy cannot be sorted inversely by user; but PostgreSQL leftJoin with distinct filters too many results, see SQL Example lead/lag under jost/misc DevOps -- E.on $ qualBlock E.?. QualificationUserBlockQualificationUser E.?=. qualUser E.^. QualificationUserId - E.&&. qualBlock `isLatestBlockBefore` E.now_ + E.&&. qualBlock `isLatestBlockBefore` E.val now E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser @@ -371,7 +371,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do dbtIdent :: Text dbtIdent = "qualification" fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs - dbtSQLQuery = qualificationTableQuery qid fltrSvs + dbtSQLQuery = qualificationTableQuery now qid fltrSvs dbtRowKey = queryUser >>> (E.^. UserId) dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock) -> do -- cmps <- E.select . E.from $ \(usrComp `E.InnerJoin` comp) -> do @@ -437,23 +437,23 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday | otherwise -> E.true ) - -- , single ("tobe-notified", FilterColumn $ \(queryQualUser -> quser) criterion -> - -- if | Just True <- getLast criterion -> quser `quserToNotify` now - -- | otherwise -> E.true - -- ) + , single ("tobe-notified", FilterColumn $ \row criterion -> + if | Just True <- getLast criterion -> quserToNotify now (queryQualUser row) (queryQualBlock row) + | otherwise -> E.true + ) , single ("status" , FilterColumn . E.mkExactFilterMaybeLast' (views (to queryLmsUser) (E.?. LmsUserId)) $ views (to queryLmsUser) (E.?. LmsUserStatus)) ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgLmsUser mPrev - , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) - , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber) - , prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo) - , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) - , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) + , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) + , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber) + , prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo) + , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) + , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) , if isNothing mbRenewal then mempty else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) - -- , prismAForm (singletonFilter "tobe-notified" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsNotificationDue) - , prismAForm (singletonFilter "status" . maybePrism _PathPiece) mPrev $ aopt (hoistField liftHandler (selectField optionsFinite) :: (Field _ (Maybe LmsStatus))) (fslI MsgTableLmsStatus) + , prismAForm (singletonFilter "tobe-notified" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsNotificationDue) + , prismAForm (singletonFilter "status" . maybePrism _PathPiece) mPrev $ aopt (hoistField liftHandler (selectField optionsFinite) :: (Field _ (Maybe LmsStatus))) (fslI MsgTableLmsStatus) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtCsvEncode = Just DBTCsvEncode diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index 9c877906a..370ff80b6 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -41,35 +41,18 @@ isValidQualification d qu qb= d `inBetween` (qu ^. hasQualificationUser . _quali -- SQL Snippets -- ------------------ --- | Recently became invalid or blocked and not yet notified -quserToNotify :: E.SqlExpr (Entity QualificationUser) -> UTCTime -> E.SqlExpr (E.Value Bool) -quserToNotify quser cutoff = -- recently invalid or... - ( E.day (quser E.^. QualificationUserLastNotified) E.<. quser E.^. QualificationUserValidUntil - E.&&. E.notExists (do - qualUserBlock <- E.from $ E.table @QualificationUserBlock - E.where_ $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock) - E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.>. quser E.^. QualificationUserLastNotified - E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.<=. E.val cutoff - E.&&. E.notExists (do -- block is the most recent block - qualUserLaterBlock <- E.from $ E.table @QualificationUserBlock - E.where_ $ -- ((E.>.) `on` (E.^. QualificationUserBlockFrom) qualUserLaterBlock qualUserBlock) - qualUserLaterBlock E.^. QualificationUserBlockFrom E.>. qualUserBlock E.^. QualificationUserBlockFrom - E.&&. qualUserLaterBlock E.^. QualificationUserBlockFrom E.<=. E.val cutoff - ) - ) - ) E.||. E.exists (do -- ...recently blocked - qualUserBlock <- E.from $ E.table @QualificationUserBlock - E.where_ $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock) -- block is not an unblock - E.&&. E.day (qualUserBlock E.^. QualificationUserBlockFrom) E.<. quser E.^. QualificationUserValidUntil -- block was essential during validity - E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.>. quser E.^. QualificationUserLastNotified -- block has not yet been communicated - E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.<=. E.val cutoff -- block is already active - E.&&. E.notExists (do -- block is the most recent block - qualUserLaterBlock <- E.from $ E.table @QualificationUserBlock - E.where_ $ -- ((E.>.) `on` (E.^. QualificationUserBlockFrom) qualUserLaterBlock qualUserBlock)) - qualUserLaterBlock E.^. QualificationUserBlockFrom E.>. qualUserBlock E.^. QualificationUserBlockFrom - E.&&. qualUserLaterBlock E.^. QualificationUserBlockFrom E.<=. E.val cutoff - ) - ) +-- | Recently became invalid or blocked and not yet notified; assumes that second argument is latest active block (if exists), also checks validity with respect to given timestamp +quserToNotify :: UTCTime -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value Bool) +quserToNotify cutoff quser qblock = -- either recently become invalid with no prior block or recently blocked + -- has expired without being blocked + quser E.^. QualificationUserScheduleRenewal + E.&&. (( quser E.^. QualificationUserValidUntil E.<. E.val (utctDay cutoff) + E.&&. quser E.^. QualificationUserValidUntil E.>. E.day (quser E.^. QualificationUserLastNotified) + E.&&. E.not_ (E.isFalse (qblock E.?. QualificationUserBlockUnblock)) -- not currently blocked + ) E.||. ( -- was recently blocked + E.isFalse (qblock E.?. QualificationUserBlockUnblock) + E.&&. qblock E.?. QualificationUserBlockFrom E.>. E.just (quser E.^. QualificationUserLastNotified) + )) -- condition to ensure that the lastest QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended isLatestBlockBefore :: E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 5550e0706..388bfc2af 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -207,10 +207,15 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act when (quali ^. _qualificationExpiryNotification) $ do -- notifies expired and previously lms-failed drivers notifyInvalidDrivers <- E.select $ do - quser <- E.from $ E.table @QualificationUser - E.where_ $ E.not_ (validQualification now quser) -- currently invalid - E.&&. quser E.^. QualificationUserQualification E.==. E.val qid -- correct qualification - E.&&. quser `quserToNotify` now -- recently became invalid or blocked + (quser :& qblock) <- E.from $ + E.table @QualificationUser + `E.leftJoin` E.table @QualificationUserBlock + `E.on` (\(quser :& qblock) -> qblock E.?. QualificationUserBlockQualificationUser E.?=. quser E.^. QualificationUserId + E.&&. qblock `isLatestBlockBefore` E.val now + ) + E.where_ $ -- E.not_ (validQualification now quser) -- currently invalid + quser E.^. QualificationUserQualification E.==. E.val qid -- correct qualification + E.&&. quserToNotify now quser qblock -- recently became invalid or blocked pure (quser E.^. QualificationUserUser) forM_ notifyInvalidDrivers $ \(E.Value uid) -> From 9ac275c9eb2a55883a7bcef85db36c92308e0cae Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 28 Sep 2023 11:36:24 +0000 Subject: [PATCH 21/59] chore(lms): minor clarifications about lms resetting --- messages/uniworx/categories/qualification/de-de-formal.msg | 2 +- messages/uniworx/categories/qualification/en-eu.msg | 2 +- src/Handler/LMS.hs | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 6ec90ad28..6c903c496 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -121,7 +121,7 @@ LmsActNotify: Benachrichtigung E‑Learning erneut per Post oder E-Mail versende LmsActRenewPin: Neues zufällige E‑Learning Passwort zuweisen LmsActRenewNotify: Neue zufällige E‑Learning Passwort zuweisen und Benachrichtigung per Post oder E-Mail versenden LmsActReset: E‑Learning Fehlversuche zurücksetzen und entsperren -LmsActResetInfo: E‑Learning Login und Passwort bleiben unverändert, eine neue Benachrichtigung ist nicht notwendig. Nur möglich für bereits gesperrte Lerner. Es kann bis zu 2 Stunden dauern, bis das LMS die Anfrage umgesetzt hat. +LmsActResetInfo: E‑Learning Login, Passwort und Fortschritt bleiben unverändert, eine neue Benachrichtigung ist nicht notwendig. Nur möglich für bereits gesperrte Lerner. Es kann bis zu 2 Stunden dauern, bis das LMS die Anfrage umgesetzt hat. LmsActResetFeedback n@Int m@Int: Für #{n}/#{m} E‑Learning Nutzer wurden alle Fehlversuche zurückgesetzt. LmsActRestart: E‑Learning komplett neu starten LmsActRestartWarning: Das vorhandene E‑Learning wird komplett gelöscht! Für Inhaber einer gültigen Fahrlizenz werden später Benutzer und Passwort neu vergeben und es sollte eine neue Benachrichtigung versendet werden. Hinweis: Es kann mehrere Stunden dauern, bis das LMS diese Anfrage umgesetzt hat. diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index e4db425e1..7851b5c84 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -121,7 +121,7 @@ LmsActNotify: Resend e‑learning notification by post or email LmsActRenewPin: Randomly replace e‑learning password LmsActRenewNotify: Randomly replace e‑learning password and re-send notification by post or email LmsActReset: Reset and unlock e‑learning -LmsActResetInfo: E‑learning login and password remain unchanged; a notification is thus not necessary. This is only possible for already failed learners. Note that the reset procedure may take up to 2 hours. +LmsActResetInfo: E‑learning login, password and progress remain unchanged; a notification is thus not necessary. This is only possible for already failed learners. Note that the reset procedure may take up to 2 hours. LmsActResetFeedback n@Int m@Int: For #{n}/#{m} learners all failures were erased, preserving login credentials. LmsActRestart: Restart e‑learning LmsActRestartWarning: The existing e‑learning will be erased immediately! For drivers with a valid licence, user and password will later be generated anew and a notification will be queued as usual, which may take several hours. diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index ed1b829b3..c06cd68f6 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -768,7 +768,7 @@ postLmsR sid qsh = do numExaminees <- runDB $ do okUsers <- selectList [ LmsUserQualification ==. qid -- matching qualification , LmsUserEnded ==. Nothing -- not yet deleted - -- , LmsUserStatus ==. Nothing -- not yet decided + , LmsUserStatus ==. Nothing -- not yet decided , LmsUserUser <-. Set.toList selectedUsers -- selected ] [] forM_ okUsers $ \(Entity lid LmsUser {lmsUserUser = uid, lmsUserQualification = qid'}) -> do From 60644528fc2c513db1d9087590d48f213868c405 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 28 Sep 2023 15:05:04 +0000 Subject: [PATCH 22/59] refactor(lms): show deletion days parameter and ensure audit log period is accounted for --- .../categories/qualification/de-de-formal.msg | 2 +- .../categories/qualification/en-eu.msg | 2 +- src/Handler/LMS.hs | 12 ++++--- src/Handler/LMS/Learners.hs | 31 +++++++++++-------- src/Handler/LMS/Users.hs | 4 +-- src/Handler/Utils/DateTime.hs | 2 +- src/Handler/Utils/LMS.hs | 13 +++++--- templates/lms.hamlet | 6 ++-- 8 files changed, 42 insertions(+), 30 deletions(-) diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 6c903c496..ce59e03ed 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -8,7 +8,7 @@ QualificationDescription: Beschreibung QualificationValidIndicator: Gültigkeit QualificationValidDuration: Gültigkeitsdauer QualificationAuditDuration: Aufbewahrung Audit Log -QualificationAuditDurationTooltip: Optionaler Zeitraum zur Löschung von E‑Learning Daten. Hiweis: Der E‑Learning Server kann seine anonymisierten Daten schon früher löschen. +QualificationAuditDurationTooltip n@Int: Optionaler Zeitraum zur Löschung von E‑Learning Daten. Hinweis: Der E‑Learning Server kann seine anonymisierten Daten schon früher löschen, aber spätestens #{n} Tage nach Abschluss. QualificationRefreshWithin: Erneurerungszeitraum QualificationRefreshWithinTooltip: Optionaler Zeitraum vor Ablauf für automatischen Start des E‑Learnings und Versand einer Benachrichtigung per Brief oder Email. QualificationRefreshReminder: 2. Erinnerung diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 7851b5c84..6e949fc4f 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -8,7 +8,7 @@ QualificationDescription: Description QualificationValidIndicator: Validity QualificationValidDuration: Validity period QualificationAuditDuration: Audit log keept -QualificationAuditDurationTooltip: Optional period for deletion of e‑learning data. Note that the e‑learning server may delete its anonymised data earlier. +QualificationAuditDurationTooltip n@Int: Optional period for deletion of e‑learning data. Note that the e‑learning server may delete its anonymised data earlier, at most #{n} days after closing. QualificationRefreshWithin: Refresh within QualificationRefreshWithinTooltip: Optional period before expiry to start e‑learning and send a notification by post or email. QualificationRefreshReminder: 2. Reminder diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index c06cd68f6..66ccf51a6 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -104,9 +104,10 @@ postLmsAllR = do , formEncoding = btnEnctype , formSubmit = FormNoSubmit } - + + LmsConf{lmsDeletionDays} <- getsYesod $ view _appLmsConf lmsTable <- runDB $ do - view _2 <$> mkLmsAllTable isAdmin + view _2 <$> mkLmsAllTable isAdmin lmsDeletionDays siteLayoutMsg MsgMenuLms $ do setTitleI MsgMenuLms $(widgetFile "lms-all") @@ -122,8 +123,8 @@ resultAllQualificationTotal :: Lens' AllQualificationTableData Word64 resultAllQualificationTotal = _dbrOutput . _3 . _unValue -mkLmsAllTable :: Bool -> DB (Any, Widget) -mkLmsAllTable isAdmin = do +mkLmsAllTable :: Bool -> Int -> DB (Any, Widget) +mkLmsAllTable isAdmin lmsDeletionDays = do svs <- getSupervisees let resultDBTable = DBTable{..} @@ -160,7 +161,7 @@ mkLmsAllTable isAdmin = do -- , sortable Nothing (i18nCell MsgQualificationRefreshWithin) $ foldMap textCell . view (resultAllQualification . _qualificationRefreshWithin . to formatCalendarDiffDays) -- does not work, since there is a maybe in between , sortable Nothing (i18nCell MsgQualificationRefreshReminder & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $ foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder) - , sortable Nothing (i18nCell MsgQualificationAuditDuration & cellTooltips [SomeMessage MsgQualificationAuditDurationTooltip, SomeMessage MsgTableDiffDaysTooltip]) $ + , sortable Nothing (i18nCell MsgQualificationAuditDuration & cellTooltips [SomeMessage (MsgQualificationAuditDurationTooltip lmsDeletionDays), SomeMessage MsgTableDiffDaysTooltip]) $ foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationAuditDuration) , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) $ tickmarkCell . view (resultAllQualification . _qualificationElearningStart) @@ -790,6 +791,7 @@ postLmsR sid qsh = do let heading = citext2widget $ "LMS " <> qualificationName quali siteLayout heading $ do setTitle $ toHtml $ "LMS " <> unSchoolKey sid <> "-" <> qsh + LmsConf{lmsDeletionDays} <- getsYesod $ view _appLmsConf $(widgetFile "lms") -- redirect to a specific lms user diff --git a/src/Handler/LMS/Learners.hs b/src/Handler/LMS/Learners.hs index 31f9ce8bd..ff329166e 100644 --- a/src/Handler/LMS/Learners.hs +++ b/src/Handler/LMS/Learners.hs @@ -90,9 +90,8 @@ instance CsvColumnsExplained LmsUserTableCsv where -mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) -mkUserTable _sid qsh qid = do - cutoff <- liftHandler lmsDeletionDate +mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> UTCTime -> DB (Any, Widget) +mkUserTable _sid qsh qid cutoff = do dbtCsvName <- csvFilenameLmsUser qsh let dbtCsvSheetName = dbtCsvName let @@ -158,25 +157,31 @@ mkUserTable _sid qsh qid = do & defaultSorting [SortAscBy csvLmsIdent] dbTable userDBTableValidator userDBTable +getQidCutoff :: SchoolId -> QualificationShorthand -> DB (QualificationId, UTCTime) +getQidCutoff sid qsh = do + Entity{entityKey = qid, entityVal = Qualification{qualificationAuditDuration=auditDur}} <- getBy404 $ SchoolQualificationShort sid qsh + cutoff <- liftHandler $ lmsDeletionDate auditDur + return (qid, cutoff) + getLmsLearnersR :: SchoolId -> QualificationShorthand -> Handler Html getLmsLearnersR sid qsh = do lmsTable <- runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - view _2 <$> mkUserTable sid qsh qid + (qid, cutoff) <- getQidCutoff sid qsh + view _2 <$> mkUserTable sid qsh qid cutoff siteLayoutMsg MsgMenuLmsLearners $ do setTitleI MsgMenuLmsLearners lmsTable getLmsLearnersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent getLmsLearnersDirectR sid qsh = do - $logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid - cutoff <- lmsDeletionDate - lms_users <- runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - selectList [ LmsUserQualification ==. qid - , LmsUserEnded ==. Nothing - -- , LmsUserReceived ==. Nothing ||. LmsUserResetPin ==. True ||. LmsUserStatus !=. Nothing -- send delta only NOTE: know-how no longer expects delta - ] [Asc LmsUserStarted, Asc LmsUserIdent] + $logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid + (lms_users,cutoff) <- runDB $ do + (qid, cutoff) <- getQidCutoff sid qsh + lms_users <- selectList [ LmsUserQualification ==. qid + , LmsUserEnded ==. Nothing + -- , LmsUserReceived ==. Nothing ||. LmsUserResetPin ==. True ||. LmsUserStatus !=. Nothing -- send delta only NOTE: know-how no longer expects delta + ] [Asc LmsUserStarted, Asc LmsUserIdent] + return (lms_users, cutoff) {- To avoid exporting unneeded columns, we would need an SqlSelect instance for LmsUserTableCsv; probably not worth it Ex.select $ do diff --git a/src/Handler/LMS/Users.hs b/src/Handler/LMS/Users.hs index 389ad16f6..b5f534b5a 100644 --- a/src/Handler/LMS/Users.hs +++ b/src/Handler/LMS/Users.hs @@ -83,7 +83,7 @@ instance CsvColumnsExplained LmsUserTableCsv where mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) mkUserTable _sid qsh qid = do - cutoff <- liftHandler lmsDeletionDate + cutoff <- liftHandler $ lmsDeletionDate Nothing dbtCsvName <- csvFilenameLmsUser qsh let dbtCsvSheetName = dbtCsvName let @@ -154,7 +154,7 @@ getLmsUsersR sid qsh = do getLmsUsersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent getLmsUsersDirectR sid qsh = do $logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid - cutoff <- lmsDeletionDate + cutoff <- lmsDeletionDate Nothing lms_users <- runDB $ do qid <- getKeyBy404 $ SchoolQualificationShort sid qsh selectList [ LmsUserQualification ==. qid diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 754110bdb..49cc6a7ba 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index e67fc4e05..29667b1ec 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -130,11 +130,16 @@ makeLmsFilename ftag (citext2lower -> qsh) = do getYMTH :: MonadHandler m => m Text getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime --- -lmsDeletionDate :: Handler UTCTime -lmsDeletionDate = do +-- | Given the QualificationAuditDuration, determines the time to signal the deletion of an LMS User to the e-learning server. Note that the e-learning server ought to delete LMS users on its own +lmsDeletionDate :: Maybe Int -> Handler UTCTime +lmsDeletionDate mbMaxAuditMonths = do + now <- liftIO getCurrentTime LmsConf{lmsDeletionDays} <- getsYesod $ view _appLmsConf - addLocalDays (fromIntegral $ negate lmsDeletionDays) <$> liftIO getCurrentTime + let ldd = addDiffDaysRollOver (fromDays $ negate lmsDeletionDays) now + return $ case mbMaxAuditMonths of + Nothing -> ldd + (Just maxAuditMonths) -> + max ldd (addDiffDaysRollOver (fromMonths $ negate maxAuditMonths) now) -- | Decide whether LMS platform should delete an identifier lmsUserToDeleteExpr :: UTCTime -> E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool) diff --git a/templates/lms.hamlet b/templates/lms.hamlet index acfccaccf..fb38e8e07 100644 --- a/templates/lms.hamlet +++ b/templates/lms.hamlet @@ -1,6 +1,6 @@ $newline never -$# SPDX-FileCopyrightText: 2022 Sarah Vaupel ,Steffen Jost +$# SPDX-FileCopyrightText: 2022-23 Sarah Vaupel ,Steffen Jost $# $# SPDX-License-Identifier: AGPL-3.0-or-later @@ -15,11 +15,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
_{MsgMonths (fromIntegral dvalid)} $maybe daudit <- qualificationAuditDuration quali -
_{MsgQualificationAuditDuration} ^{iconTooltip (msg2widget MsgQualificationAuditDurationTooltip) Nothing True} +
_{MsgQualificationAuditDuration} ^{iconTooltip (msg2widget (MsgQualificationAuditDurationTooltip lmsDeletionDays)) Nothing True}
_{MsgMonths (fromIntegral daudit)} $maybe drefresh <- qualificationRefreshWithin quali -
_{MsgQualificationRefreshWithin} ^{iconTooltip (msg2widget MsgQualificationRefreshWithinTooltip) Nothing True} +
_{MsgQualificationRefreshWithin} ^{iconTooltip (msg2widget MsgQualificationRefreshWithinTooltip) Nothing True}
$with drm <- cdMonths drefresh $with drd <- cdDays drefresh From b7d4f6913d8b1a70c1b7ef73782cf29861dc11a7 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 4 Oct 2023 08:18:46 +0000 Subject: [PATCH 23/59] fix(print): apc ident aliases did not stop at first success --- src/Jobs/Handler/Print.hs | 2 +- src/Utils.hs | 4 +--- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/src/Jobs/Handler/Print.hs b/src/Jobs/Handler/Print.hs index cb16a2907..630a946eb 100644 --- a/src/Jobs/Handler/Print.hs +++ b/src/Jobs/Handler/Print.hs @@ -47,7 +47,7 @@ dispatchJobPrintAck = JobHandlerException act return True _ -> return False procOneId oks Entity{entityKey=paid, entityVal=PrintAcknowledge{printAcknowledgeApcIdent=Text.strip -> apci, printAcknowledgeTimestamp=ackt}} = - andM [ackOneId ackt $ ftrans apci | ftrans <- ftransAliases] >>= \case + orM [ackOneId ackt $ ftrans apci | ftrans <- ftransAliases] >>= \case True -> delete paid >> return (succ oks) False -> update paid [PrintAcknowledgeProcessed =. True] >> return oks apcis <- selectList [PrintAcknowledgeProcessed ==. False] [Asc PrintAcknowledgeTimestamp, LimitTo jobPrintAckChunkSize] diff --git a/src/Utils.hs b/src/Utils.hs index 2cf4b1495..a40d0ad49 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1161,9 +1161,7 @@ guardMOnM b x = guardM b *> x -- Some Utility Functions from Agda.Utils.Monad -- | Monadic if-then-else. ifM :: Monad m => m Bool -> m a -> m a -> m a -ifM c m m' = - do b <- c - if b then m else m' +ifM c x y = c >>= bool y x -- | @ifNotM mc = ifM (not <$> mc)@ from Agda.Utils.Monad ifNotM :: Monad m => m Bool -> m a -> m a -> m a From dd67429139b5b5fc9dd6da2deaa12ef575e3f537 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 4 Oct 2023 14:46:54 +0000 Subject: [PATCH 24/59] shell-nix: remove node2nix (non-existant) and profiteur (ghc-prof currently markes as broken) --- shell.nix | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/shell.nix b/shell.nix index 9d891d877..0988cc475 100644 --- a/shell.nix +++ b/shell.nix @@ -275,7 +275,7 @@ in pkgs.mkShell { ++ (with pkgs; [ stack nodejs-14_x postgresql_12 openldap exiftool memcached minio minio-client gup reuse pre-commit - node2nix + # node2nix # busybox # for print services, but interferes with build commands in develop-shell htop pdftk # pdftk just for testing pdf-passwords @@ -290,5 +290,5 @@ in pkgs.mkShell { ; }) ] - ) ++ (with pkgs.haskellPackages; [ yesod-bin hlint cabal-install weeder profiteur ]); + ) ++ (with pkgs.haskellPackages; [ yesod-bin hlint cabal-install weeder ]); } From 95857b46247cf46241ad6b9a8b88c3f8f9bd85e3 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 4 Oct 2023 14:46:21 +0000 Subject: [PATCH 25/59] stack.nix: conform to new flake.nix stack-wrapped --- stack.nix | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/stack.nix b/stack.nix index d528dabc5..22b4b452f 100644 --- a/stack.nix +++ b/stack.nix @@ -2,12 +2,12 @@ # # SPDX-License-Identifier: AGPL-3.0-or-later -{ ghc, nixpkgs ? import ./nixpkgs.nix }: +{ ghc, nixpkgs ? import {} }: let # haskellPackages = import ./stackage.nix { inherit nixpkgs; }; haskellPackages = pkgs.haskellPackages; - inherit (nixpkgs {}) pkgs; + inherit (nixpkgs) pkgs; in pkgs.haskell.lib.buildStackProject { inherit ghc; inherit (haskellPackages) stack; From 6355f81f02d0baa2628a7d670868b12bf30e7806 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 4 Oct 2023 14:45:53 +0000 Subject: [PATCH 26/59] flake.nix: wrap stack using pkgs-recent --- flake.nix | 22 ++++++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) diff --git a/flake.nix b/flake.nix index 663a99ec2..2ecc482e0 100644 --- a/flake.nix +++ b/flake.nix @@ -112,8 +112,26 @@ overlays = [ (final: prev: let - pkgs-recent = import nixpkgs-recent { inherit system; }; - in { inherit (pkgs-recent) dockerTools node2nix stack glibcLocalesUtf8 tzdata chromium minio minio-client skopeo; inherit (pkgs-recent.stdenv) fetchurlBoot; }) + pkgs-recent = import nixpkgs-recent { inherit system; }; + in { + inherit (pkgs-recent) dockerTools node2nix glibcLocalesUtf8 tzdata chromium minio minio-client skopeo; inherit (pkgs-recent.stdenv) fetchurlBoot; + stack = pkgs.symlinkJoin { + inherit (pkgs-recent.stack) name; + paths = [pkgs-recent.stack]; + nativeBuildInputs = [pkgs-recent.makeWrapper]; + + postBuild = '' + wrapProgram $out/bin/stack \ + --prefix PATH : "${prev.lib.makeBinPath [pkgs-recent.nix]}" \ + --add-flags "\ + --nix \ + --no-nix-pure \ + --nix-shell-file=${./stack.nix} \ + --nix-path=nixpkgs=${nixpkgs} \ + " + ''; + }; + }) (import ./nix/maildev) haskell-nix.overlay From 55ea2c26f4cf52f0ac5255fbba0ec469d812ca6a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 4 Oct 2023 15:58:23 +0000 Subject: [PATCH 27/59] chore(bump): non-essential commit --- src/Utils.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Utils.hs b/src/Utils.hs index a40d0ad49..dc9e8199a 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Winnie Ros +-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Winnie Ros ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later From c75d914dc3f222c625f0d53ec8f5bac9d999bd89 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 4 Oct 2023 15:58:57 +0000 Subject: [PATCH 28/59] chore(release): 27.4.41 --- CHANGELOG.md | 9 +++++++++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 13 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 8d908dced..c855e7e52 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,15 @@ 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.41](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.40...v27.4.41) (2023-10-04) + + +### Bug Fixes + +* **lms:** sorting and filtering lms status ([f48862e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f48862efbcb95e92203a200267e1bcc613af4af1)) +* **lms:** sorting and filtering lms status works throughout now ([ae44703](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ae4470333e2b1b5c271b38092210c094822f4a19)) +* **print:** apc ident aliases did not stop at first success ([b7d4f69](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b7d4f6913d8b1a70c1b7ef73782cf29861dc11a7)) + ## [27.4.40](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.39...v27.4.40) (2023-09-26) ## [27.4.39](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.38...v27.4.39) (2023-09-26) diff --git a/nix/docker/version.json b/nix/docker/version.json index d2bbd19ec..ab442fe54 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.40" + "version": "27.4.41" } diff --git a/package-lock.json b/package-lock.json index ea1aedb59..5ac06c7a7 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.40", + "version": "27.4.41", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 1573086fc..ca56d2043 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.40", + "version": "27.4.41", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 9f4a87b4a..0e94d2098 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.40 +version: 27.4.41 dependencies: - base - yesod From f776aaaef51855596618d8f9e50d8b1f4d0de1cc Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 6 Oct 2023 09:14:19 +0000 Subject: [PATCH 29/59] chore(lms): prefix lms-ident with qualification shorthand --- src/Handler/Utils/LMS.hs | 12 +++++++----- src/Jobs/Handler/LMS.hs | 9 ++++++--- 2 files changed, 13 insertions(+), 8 deletions(-) diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index 29667b1ec..eb619276b 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -39,6 +39,7 @@ import Import import Handler.Utils.DateTime import Handler.Utils.Csv import Data.Csv (HasHeader(..), FromRecord) +import qualified Data.Text as Text import qualified Data.Set as Set (notMember) import qualified Database.Esqueleto.Legacy as E @@ -211,14 +212,15 @@ randomText extra n = fmap pack . evalRandTIO . replicateM n $ uniform range -- where -- eopt = Elo.genOptions -- { genCapitals = False, genSpecials = False, genDigitis = True } -randomLMSIdent :: MonadIO m => m LmsIdent -randomLMSIdent = LmsIdent <$> randomText [] lengthIdent -- idents must not contain '_' nor '-' +randomLMSIdent :: MonadIO m => Maybe Char -> m LmsIdent +randomLMSIdent Nothing = LmsIdent . Text.cons 'j' <$> randomText [] (pred lengthIdent) -- idents must not contain '_' nor '-' +randomLMSIdent (Just c) = LmsIdent . Text.cons c <$> randomText [] (pred lengthIdent) -randomLMSIdentBut :: MonadIO m => Set LmsIdent -> m (Maybe LmsIdent) -randomLMSIdentBut banList = untilJustMaxM maxLmsUserIdentRetries getIdentOk +randomLMSIdentBut :: MonadIO m => Maybe Char -> Set LmsIdent -> m (Maybe LmsIdent) +randomLMSIdentBut prefix banList = untilJustMaxM maxLmsUserIdentRetries getIdentOk where getIdentOk = do - l <- randomLMSIdent + l <- randomLMSIdent prefix return $ toMaybe (Set.notMember l banList) l randomLMSpw :: MonadIO m => m Text -- may contain all kinds of symbols, but our users had trouble with some, like ',' '.' ':' '_' diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 388bfc2af..162cffce9 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -34,7 +34,7 @@ import Handler.Utils.LMS (randomLMSIdentBut, randomLMSpw, maxLmsUserIdentRetries import Handler.Utils.Qualification import qualified Data.CaseInsensitive as CI - +import qualified Data.Text as Text dispatchJobLmsQualificationsEnqueue :: JobHandler UniWorX dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsEnqueue @@ -125,6 +125,9 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act where act :: YesodJobDB UniWorX () act = do + quali <- getJust qid -- may throw an error, aborting the job + let qshort = CI.original $ qualificationShorthand quali + qprefix = fst <$> Text.uncons (Text.toLower qshort) identsInUseVs <- E.select $ do lui <- E.from $ @@ -158,9 +161,9 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act -- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser)) startLmsUser = do lpw <- randomLMSpw - maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser lpw) (randomLMSIdentBut identsInUse) + maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser lpw) (randomLMSIdentBut qprefix identsInUse) -- runMaybeT $ do - -- lid <- MaybeT $ randomLMSIdentBut identsInUse + -- lid <- MaybeT $ randomLMSIdentBu qprefix identsInUse -- MaybeT $ E.insertUniqueEntity $ mkLmsUser lpw lid inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser case inserted of From e3b6a7e4c6b567c67c9eb0e14f2ac8bac989217b Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 6 Oct 2023 11:16:49 +0000 Subject: [PATCH 30/59] chore(qualification): block expired qualification users explicitly --- src/Handler/Utils/Qualification.hs | 2 +- src/Jobs/Handler/LMS.hs | 22 +++++++++++++--------- src/Model/Types/Lms.hs | 2 ++ test/Database/Fill.hs | 18 ++++++++++-------- 4 files changed, 26 insertions(+), 18 deletions(-) diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index 370ff80b6..ea9812c68 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -201,7 +201,7 @@ renewValidQualificationUsers qid renewalTime uids = return $ length quEnts _ -> return (-1) -- qualificationId not found, isNothing qualificationValidDuration, etc. --- | Block or unblock some users for a given reason +-- | Block or unblock some users for a given reason, but only if they are not already blocked (essential assumption that is actually used) qualificationUserBlocking :: ( AuthId (HandlerSite m) ~ Key User , IsPersistBackend (YesodPersistBackend (HandlerSite m)) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 162cffce9..1b6cf4359 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -189,24 +189,28 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act $logInfoS "LMS" $ "Processing e-learning results for qualification " <> qshort now <- liftIO getCurrentTime -- end users that expired by doing nothing - expiredLearners <- E.select $ do + expiredUsers <- E.select $ do (quser :& luser) <- E.from $ E.table @QualificationUser - `E.innerJoin` E.table @LmsUser + `E.leftJoin` E.table @LmsUser `E.on` (\(quser :& luser) -> - luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser - E.&&. luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification) + luser E.?. LmsUserUser E.?=. quser E.^. QualificationUserUser + E.&&. luser E.?. LmsUserQualification E.?=. quser E.^. QualificationUserQualification) E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid - E.&&. luser E.^. LmsUserQualification E.==. E.val qid - E.&&. E.isNothing (luser E.^. LmsUserStatus) + -- E.&&. luser E.?. LmsUserQualification E.?=. E.val qid + -- E.&&. E.isNothing (luser E.^. LmsUserStatus) -- E.&&. E.isNothing (luser E.^. LmsUserEnded) E.&&. E.not_ (validQualification now quser) - pure (luser E.^. LmsUserId) + pure (luser E.?. LmsUserId, quser E.^. QualificationUserUser) + nrBlocked <- qualificationUserBlocking qid (E.unValue . snd <$> expiredUsers) False (Just now) (Right QualificationBlockExpired) True -- essential that blocks occur only once + let expiredLearners = [ luid | (E.Value (Just luid), _) <- expiredUsers ] + -- let expiredLearners = catMaybes (E.unValue . fst <$> expiredUsers) nrExpired <- E.updateCount $ \luser -> do E.set luser [LmsUserStatus E.=. E.justVal LmsExpired, LmsUserStatusDay E.=. E.justVal now] - E.where_ $ (luser E.^. LmsUserId) `E.in_` E.valList (E.unValue <$> expiredLearners) + E.where_ $ E.isNothing (luser E.^. LmsUserStatus) E.&&. luser E.^. LmsUserQualification E.==. E.val qid - $logInfoS "LMS" $ "Expired lms users " <> tshow nrExpired <> " for qualification " <> qshort + E.&&. (luser E.^. LmsUserId) `E.in_` E.valList expiredLearners + $logInfoS "LMS" $ "Expired qualification holders " <> tshow nrBlocked <> " and expired lms users " <> tshow nrExpired <> " for qualification " <> qshort when (quali ^. _qualificationExpiryNotification) $ do -- notifies expired and previously lms-failed drivers notifyInvalidDrivers <- E.select $ do diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index 48828607c..b8eaf90e1 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -59,11 +59,13 @@ instance Csv.ToField LmsStatus where data QualificationBlockStandardReason = QualificationBlockFailedELearning | QualificationBlockReturnedByCompany + | QualificationBlockExpired deriving (Eq, Ord, Enum, Bounded, Universe, Finite) instance Show QualificationBlockStandardReason where show QualificationBlockFailedELearning = "E-Learning durchgefallen" show QualificationBlockReturnedByCompany = "Rückgabe Firma" + show QualificationBlockExpired = "Abgelaufen" qualificationBlockedReasonText :: QualificationBlockStandardReason -> Text qualificationBlockedReasonText = diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 55beaff95..a4d2ab2c4 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -726,16 +726,18 @@ fillDb = do qidfUsers <- Set.fromAscList . fmap (qualificationUserUser . entityVal) <$> selectList [QualificationUserQualification ==. qid_f] [Asc QualificationUserUser] - insertMany_ [QualificationUser uid qid_f (n_day (fromIntegral (length udn) - 12)) (n_day $ -42) (n_day $ -365) True (n_day' $ -11)| Entity uid User{userDisplayName=udn} <- take 200 matUsers, uid `Set.notMember` qidfUsers] - void . insert' $ LmsResult qid_f (LmsIdent "hijklmn") (n_day (-1)) now + insertMany_ [QualificationUser uid qid_f (n_day (fromIntegral (length udn) - 12)) (n_day $ -42) (n_day $ -365) True (n_day' $ -11) | Entity uid User{userDisplayName=udn} <- take 200 $ drop 2 matUsers, uid `Set.notMember` qidfUsers] + insertMany_ [LmsUser qid_f uid (LmsIdent udn) "123456" False now astatus astatusDay now (Just now) (Just now) Nothing False False | Entity uid User{userDisplayName=udn} <- take 200 $ drop 22 matUsers, uid `Set.notMember` qidfUsers + , let selsome = odd $ length udn, let astatus = bool Nothing (Just LmsBlocked) selsome, let astatusDay = bool Nothing (Just now) selsome] + void . insert' $ LmsResult qid_f (LmsIdent "hijklm" ) (n_day (-1)) now void . insert' $ LmsResult qid_f (LmsIdent "opqgrs" ) (n_day (-2)) now void . insert' $ LmsResult qid_f (LmsIdent "pqgrst" ) (n_day (-3)) now - void . insert' $ LmsUserlist qid_f (LmsIdent "hijklmn") False now - void . insert' $ LmsUserlist qid_f (LmsIdent "abcdefg") True now - void . insert' $ LmsUserlist qid_f (LmsIdent "ijk" ) False now - void . insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False now Nothing Nothing now Nothing (Just $ n_day' (-7)) (Just $ n_day' (-5)) False False - void . insert' $ LmsUser qid_f svaupel (LmsIdent "abcdefg") "abc" False now (Just LmsSuccess) (Just $ n_day' 1) (n_day' (-1)) (Just now) (Just $ n_day' 0) Nothing True False - void . insert' $ LmsUser qid_f gkleen (LmsIdent "hijklmn") "@#!" True now (Just LmsBlocked) (Just $ now) (n_day' (-2)) (Just now) (Just $ n_day' (-4)) Nothing False True + void . insert' $ LmsUserlist qid_f (LmsIdent "hijklm") False now + void . insert' $ LmsUserlist qid_f (LmsIdent "abcdef") True now + void . insert' $ LmsUserlist qid_f (LmsIdent "ijk" ) False now + void . insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False now Nothing Nothing now Nothing (Just $ n_day' (-7)) (Just $ n_day' (-5)) False False + void . insert' $ LmsUser qid_f svaupel (LmsIdent "bcdefg") "abc" False now (Just LmsSuccess) (Just $ n_day' 1) (n_day' (-1)) (Just now) (Just $ n_day' 0) Nothing True False + void . insert' $ LmsUser qid_f gkleen (LmsIdent "hiklmn") "@#!" True now (Just LmsBlocked) (Just $ now) (n_day' (-2)) (Just now) (Just $ n_day' (-4)) Nothing False True void . insert' $ LmsUser qid_f tinaTester (LmsIdent "qwvu") "45678" True now (Just LmsSuccess) (Just $ n_day' (-22)) (n_day' (-3)) (Just $ n_day' (-1)) (Just $ n_day' (-1)) Nothing True True void . insert' $ LmsUser qid_f maxMuster (LmsIdent "xyz") "a1b2c3" False now (Just LmsBlocked) (Just $ n_day' (-11)) (n_day' (-4)) (Just $ n_day' (-2)) (Just $ n_day' (-2)) Nothing True True void . insert' $ LmsUser qid_f fhamann (LmsIdent "123") "456" False now Nothing Nothing now Nothing Nothing Nothing False False From be527ada321b6f3c4fe08e44a4ca11a1bb39eea3 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 6 Oct 2023 15:07:34 +0000 Subject: [PATCH 31/59] refactor: minor code cleaning --- src/Jobs/Handler/LMS.hs | 9 ++++----- src/Jobs/Handler/SendNotification/Qualification.hs | 10 +++++----- 2 files changed, 9 insertions(+), 10 deletions(-) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 1b6cf4359..827f44496 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -197,14 +197,13 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act luser E.?. LmsUserUser E.?=. quser E.^. QualificationUserUser E.&&. luser E.?. LmsUserQualification E.?=. quser E.^. QualificationUserQualification) E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid - -- E.&&. luser E.?. LmsUserQualification E.?=. E.val qid + -- E.&&. luser E.?. LmsUserQualification E.?=. E.val qid -- E.&&. E.isNothing (luser E.^. LmsUserStatus) -- E.&&. E.isNothing (luser E.^. LmsUserEnded) E.&&. E.not_ (validQualification now quser) - pure (luser E.?. LmsUserId, quser E.^. QualificationUserUser) - nrBlocked <- qualificationUserBlocking qid (E.unValue . snd <$> expiredUsers) False (Just now) (Right QualificationBlockExpired) True -- essential that blocks occur only once - let expiredLearners = [ luid | (E.Value (Just luid), _) <- expiredUsers ] - -- let expiredLearners = catMaybes (E.unValue . fst <$> expiredUsers) + pure (quser E.^. QualificationUserUser, luser E.?. LmsUserId) + nrBlocked <- qualificationUserBlocking qid (E.unValue . fst <$> expiredUsers) False (Just now) (Right QualificationBlockExpired) True -- essential that blocks occur only once + let expiredLearners = [luid | (_, E.Value (Just luid)) <- expiredUsers] nrExpired <- E.updateCount $ \luser -> do E.set luser [LmsUserStatus E.=. E.justVal LmsExpired, LmsUserStatusDay E.=. E.justVal now] E.where_ $ E.isNothing (luser E.^. LmsUserStatus) diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index d5338acf6..d5d8d595e 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -60,7 +60,7 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do let expDay = maybe qualificationUserValidUntil (min qualificationUserValidUntil . utctDay . qualificationUserBlockFrom) block qname = CI.original qualificationName qshort = CI.original qualificationShorthand - letter = LetterExpireQualification + letter = LetterExpireQualification { leqHolderCFN = encRecShort , leqHolderID = jRecipient , leqHolderDN = userDisplayName @@ -72,14 +72,14 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do , leqSchool = qualificationSchool , leqUrl = pure . urender $ ForProfileDataR encRecipient } - if expDay > utctDay qualificationUserLastNotified + if expDay > utctDay qualificationUserLastNotified then do notifyOk <- sendEmailOrLetter jRecipient letter if notifyOk - then do + then do runDB $ update quId [QualificationUserLastNotified =. now] $logInfoS "LMS" $ "Notified " <> tshow encRecipient <> " about expired qualification " <> qname - else + else $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> qname else $logErrorS "LMS" $ "Suppressed repeated notification " <> tshow encRecipient <> " about expired qualification " <> qname _ -> $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> tshow nQualification @@ -89,7 +89,7 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do dispatchNotificationQualificationRenewal :: QualificationId -> Bool -> UserId -> Handler () dispatchNotificationQualificationRenewal nQualification nReminder jRecipient = do encRecipient :: CryptoUUIDUser <- encrypt jRecipient - query <- runDB $ (,,,) + query <- runDB $ (,,,) <$> get jRecipient <*> get nQualification <*> getBy (UniqueQualificationUser nQualification jRecipient) From 9caf2af540c9c18e38bbbeb5c0b397e8b0a04f48 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 9 Oct 2023 07:24:01 +0000 Subject: [PATCH 32/59] chore(firm): initial stub --- .../utils/navigation/menu/de-de-formal.msg | 2 + .../uniworx/utils/navigation/menu/en-eu.msg | 2 + routes | 2 + src/Application.hs | 1 + src/Foundation/Navigation.hs | 3 + src/Handler/Firm.hs | 663 ++++++++++++++++++ 6 files changed, 673 insertions(+) create mode 100644 src/Handler/Firm.hs diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 5ea9b7e59..9e1c55f5a 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -133,6 +133,8 @@ MenuLmsFake: Testnutzer generieren MenuLmsLearners: Export Benutzer E‑Learning MenuLmsReport: Ergebnisse E‑Learning +MenuFirms: Firmen + MenuSap: SAP Schnittstelle MenuAvs: AVS Schnittstelle diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index b4a66104d..6145f0d81 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -134,6 +134,8 @@ MenuLmsFake: Generate Test Users MenuLmsLearners: E‑learning Users MenuLmsReport: E‑learning Results +MenuFirms: Companies + MenuSap: SAP Interface MenuAvs: AVS Interface diff --git a/routes b/routes index 7a68b54e3..e7f9fc7b9 100644 --- a/routes +++ b/routes @@ -113,6 +113,8 @@ /for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self /for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self +/firm FirmAllR GET +/firm/#CompanyShorthand FirmR GET POST /exam-office ExamOfficeR !exam-office: / EOExamsR GET POST !system-exam-office diff --git a/src/Application.hs b/src/Application.hs index 90d344bfd..45f24768e 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -159,6 +159,7 @@ import Handler.SAP import Handler.PrintCenter import Handler.ApiDocs import Handler.Swagger +import Handler.Firm import ServantApi () -- YesodSubDispatch instances import Servant.API diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 1dbc9384a..9fce295f5 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -123,6 +123,9 @@ breadcrumb ProblemFbutNoR = i18nCrumb MsgProblemsRWithoutFHeading $ Just breadcrumb ProblemAvsSynchR = i18nCrumb MsgProblemsAvsSynchHeading $ Just AdminProblemsR breadcrumb ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just ProblemAvsSynchR +breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing +breadcrumb FirmR = i18nCrumb MsgMenuFirms $ Just FirmAllR + breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR breadcrumb PrintDownloadR{} = i18nCrumb MsgMenuPrintDownload $ Just PrintCenterR diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs new file mode 100644 index 000000000..5d640d603 --- /dev/null +++ b/src/Handler/Firm.hs @@ -0,0 +1,663 @@ +-- SPDX-FileCopyrightText: 2023 Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances +{-# LANGUAGE TypeApplications #-} + +module Handler.Firm + ( getFirmAllR + , getFirmR, postFirmR + ) + where + +import Import + +-- import Jobs +import Handler.Utils + +-- import qualified Data.Set as Set +-- import qualified Data.Map as Map +-- import qualified Data.Csv as Csv +-- import qualified Data.Text as T +-- import qualified Data.CaseInsensitive as CI +-- import qualified Data.Conduit.List as C +-- import Database.Persist.Sql (updateWhereCount) +-- import Database.Esqueleto.Experimental ((:&)(..)) +-- import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma +-- import qualified Database.Esqueleto.Legacy as E +-- import qualified Database.Esqueleto.PostgreSQL as E +-- import qualified Database.Esqueleto.Utils as E +-- import Database.Esqueleto.Utils.TH + + +-- avoids repetition of local definitions +single :: (k,a) -> Map k a +single = uncurry Map.singleton + + +getFirmAllR :: Handler Html +getFirmAllR = do + siteLayoutMsg MsgMenuFirms $ do + setTitleI MsgMenuFirms + [whamlet|STUB TO DO|] + + +getFirmR, postFirmR :: CompanyShorthand -> Handler Html +getFirmR = postFirmR +postFirmR _ = do + siteLayoutMsg MsgMenuFirms $ do + setTitleI MsgMenuFirms + [whamlet|STUB TO DO|] + + +-- isAdmin <- hasReadAccessTo AdminR +-- firmTable <- runDB $ do +-- view _2 <$> mkFirmAllTable isAdmin +-- siteLayoutMsg MsgMenuFirms $ do +-- setTitleI MsgMenuFirms +-- $(widgetFile "firm-all") + +-- type AllQualificationTableData = DBRow (Entity Qualification, Ex.Value Word64, Ex.Value Word64) +-- resultAllQualification :: Lens' AllQualificationTableData Qualification +-- resultAllQualification = _dbrOutput . _1 . _entityVal + +-- resultAllQualificationActive :: Lens' AllQualificationTableData Word64 +-- resultAllQualificationActive = _dbrOutput . _2 . _unValue + +-- resultAllQualificationTotal :: Lens' AllQualificationTableData Word64 +-- resultAllQualificationTotal = _dbrOutput . _3 . _unValue + + +-- mkQualificationAllTable :: Bool -> DB (Any, Widget) +-- mkQualificationAllTable isAdmin = do +-- svs <- getSupervisees +-- now <- liftIO getCurrentTime +-- let +-- resultDBTable = DBTable{..} +-- where +-- dbtSQLQuery quali = do +-- let filterSvs quser = quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId +-- Ex.&&. (E.val isAdmin E.||. quser Ex.^. QualificationUserUser `Ex.in_` E.vals svs) +-- cusers = Ex.subSelectCount $ do +-- quser <- Ex.from $ Ex.table @QualificationUser +-- Ex.where_ $ filterSvs quser +-- cactive = Ex.subSelectCount $ do +-- quser <- Ex.from $ Ex.table @QualificationUser +-- Ex.where_ $ filterSvs quser Ex.&&. validQualification now quser +-- return (quali, cactive, cusers) +-- dbtRowKey = (Ex.^. QualificationId) +-- dbtProj = dbtProjId +-- dbtColonnade = dbColonnade $ mconcat +-- [ colSchool $ resultAllQualification . _qualificationSchool +-- , sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) -> +-- let qsh = qualificationShorthand quali in +-- anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qsh +-- , sortable (Just "qname") (i18nCell MsgQualificationName) $ \(view resultAllQualification -> quali) -> +-- let qsh = qualificationShorthand quali +-- qnm = qualificationName quali +-- in anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qnm +-- , sortable Nothing (i18nCell MsgQualificationDescription) $ \(view resultAllQualification -> quali) -> +-- maybeCell (qualificationDescription quali) markupCellLargeModal +-- , sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $ +-- foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration) +-- , sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip , SomeMessage MsgTableDiffDaysTooltip]) $ +-- foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshWithin) +-- , sortable Nothing (i18nCell MsgQualificationRefreshReminder & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $ +-- foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder) +-- , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) +-- $ tickmarkCell . view (resultAllQualification . _qualificationElearningStart) +-- , sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip) +-- $ tickmarkCell . view (resultAllQualification . _qualificationExpiryNotification) +-- , sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip) +-- $ \(view (resultAllQualification . _qualificationAvsLicence) -> licence) -> maybeCell licence $ textCell . T.singleton . licence2char +-- , sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip) +-- $ \(view (resultAllQualification . _qualificationSapId) -> mbSapId) -> tickmarkCell $ isJust mbSapId +-- , sortable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip) +-- $ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n +-- , sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal +-- ] +-- dbtSorting = mconcat +-- [ +-- sortSchool $ to (E.^. QualificationSchool) +-- , singletonMap "qshort" $ SortColumn (E.^. QualificationShorthand) +-- , singletonMap "qname" $ SortColumn (E.^. QualificationName) +-- , singletonMap "qelearning" $ SortColumn (E.^. QualificationElearningStart) +-- , singletonMap "noteexpiry" $ SortColumn (E.^. QualificationExpiryNotification) +-- ] +-- dbtFilter = mconcat +-- [ +-- fltrSchool $ to (E.^. QualificationSchool) +-- , singletonMap "qelearning" . FilterColumn $ E.mkExactFilterLast (E.^. QualificationElearningStart) +-- ] +-- dbtFilterUI = mconcat +-- [ +-- fltrSchoolUI +-- , \mPrev -> prismAForm (singletonFilter "qelearning" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableLmsElearning) +-- ] +-- dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } +-- dbtParams = def +-- dbtIdent :: Text +-- dbtIdent = "qualification-overview" +-- dbtCsvEncode = noCsvEncode +-- dbtCsvDecode = Nothing +-- dbtExtraReps = [] + +-- resultDBTableValidator = def +-- & defaultSorting [SortAscBy "school", SortAscBy "qshort"] +-- dbTable resultDBTableValidator resultDBTable + + + +-- -- getQualificationEditR, postQualificationEditR :: SchoolId -> QualificationShorthand -> Handler Html +-- -- getQualificationEditR = postQualificationEditR +-- -- postQualificationEditR = error "TODO" + +-- data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc.. +-- { qtcDisplayName :: UserDisplayName +-- , qtcEmail :: UserEmail +-- , qtcCompany :: Maybe Text +-- , qtcCompanyNumbers :: CsvSemicolonList Int +-- , qtcValidUntil :: Day +-- , qtcLastRefresh :: Day +-- , qtcBlockStatus :: Maybe Bool +-- , qtcBlockFrom :: Maybe UTCTime +-- , qtcScheduleRenewal:: Bool +-- , qtcLmsStatusTxt :: Maybe Text +-- , qtcLmsStatusDay :: Maybe UTCTime +-- } +-- deriving Generic +-- makeLenses_ ''QualificationTableCsv + +-- qtcExample :: QualificationTableCsv +-- qtcExample = QualificationTableCsv +-- { qtcDisplayName = "Max Mustermann" +-- , qtcEmail = "m.mustermann@example.com" +-- , qtcCompany = Just "Example Brothers LLC, SecondaryJobs Inc" +-- , qtcCompanyNumbers = CsvSemicolonList [27,69] +-- , qtcValidUntil = compDay +-- , qtcLastRefresh = compDay +-- , qtcBlockStatus = Nothing +-- , qtcBlockFrom = Nothing +-- , qtcScheduleRenewal= True +-- , qtcLmsStatusTxt = Just "Success" +-- , qtcLmsStatusDay = Just compTime +-- } +-- where +-- compTime :: UTCTime +-- compTime = $compileTime +-- compDay :: Day +-- compDay = utctDay compTime + +-- qtcOptions :: Csv.Options +-- qtcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc } +-- where +-- renameLtc "qtcDisplayName" = "licensee" +-- renameLtc other = replaceLtc $ camelToPathPiece' 1 other +-- replaceLtc ('l':'m':'s':'-':t) = prefixLms t +-- replaceLtc other = other +-- prefixLms = ("elearn-" <>) + +-- instance Csv.ToNamedRecord QualificationTableCsv where +-- toNamedRecord = Csv.genericToNamedRecord qtcOptions + +-- instance Csv.DefaultOrdered QualificationTableCsv where +-- headerOrder = Csv.genericHeaderOrder qtcOptions + +-- instance CsvColumnsExplained QualificationTableCsv where +-- csvColumnsExplanations = genericCsvColumnsExplanations qtcOptions $ Map.fromList +-- [ ('qtcDisplayName , SomeMessage MsgLmsUser) +-- , ('qtcEmail , SomeMessage MsgTableLmsEmail) +-- , ('qtcCompany , SomeMessage MsgTableCompanies) +-- , ('qtcCompanyNumbers , SomeMessage MsgTableCompanyNos) +-- , ('qtcValidUntil , SomeMessage MsgLmsQualificationValidUntil) +-- , ('qtcLastRefresh , SomeMessage MsgTableQualificationLastRefresh) +-- , ('qtcBlockStatus , SomeMessage MsgInfoQualificationBlockStatus) +-- , ('qtcBlockFrom , SomeMessage MsgInfoQualificationBlockFrom) +-- , ('qtcScheduleRenewal, SomeMessage MsgQualificationScheduleRenewalTooltip) +-- , ('qtcLmsStatusTxt , SomeMessage MsgTableLmsStatus) +-- , ('qtcLmsStatusDay , SomeMessage MsgTableLmsStatusDay) +-- ] + + +-- type QualificationTableExpr = ( E.SqlExpr (Entity QualificationUser) +-- `E.InnerJoin` E.SqlExpr (Entity User) +-- ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) +-- `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock)) + +-- queryQualUser :: QualificationTableExpr -> E.SqlExpr (Entity QualificationUser) +-- queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) + +-- queryUser :: QualificationTableExpr -> E.SqlExpr (Entity User) +-- queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) + +-- queryLmsUser :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity LmsUser)) +-- queryLmsUser = $(sqlLOJproj 3 2) + +-- queryQualBlock :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock)) +-- queryQualBlock = $(sqlLOJproj 3 3) + +-- type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), Maybe (Entity QualificationUserBlock), [Entity UserCompany]) + +-- resultQualUser :: Lens' QualificationTableData (Entity QualificationUser) +-- resultQualUser = _dbrOutput . _1 + +-- resultUser :: Lens' QualificationTableData (Entity User) +-- resultUser = _dbrOutput . _2 + +-- resultLmsUser :: Traversal' QualificationTableData (Entity LmsUser) +-- resultLmsUser = _dbrOutput . _3 . _Just + +-- resultQualBlock :: Traversal' QualificationTableData (Entity QualificationUserBlock) +-- resultQualBlock = _dbrOutput . _4 . _Just + +-- resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany] +-- resultCompanyUser = _dbrOutput . _5 + + +-- instance HasEntity QualificationTableData User where +-- hasEntity = resultUser + +-- instance HasUser QualificationTableData where +-- hasUser = resultUser . _entityVal + +-- instance HasEntity QualificationTableData QualificationUser where +-- hasEntity = resultQualUser + +-- instance HasQualificationUser QualificationTableData where +-- hasQualificationUser = resultQualUser . _entityVal + +-- -- instance HasEntity QualificationUserBlock where +-- -- hasQualificationUserBlock = resultQualBlock + + +-- data QualificationTableAction +-- = QualificationActExpire +-- | QualificationActUnexpire +-- | QualificationActBlockSupervisor +-- | QualificationActBlock +-- | QualificationActUnblock +-- | QualificationActRenew +-- | QualificationActGrant +-- deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + +-- instance Universe QualificationTableAction +-- instance Finite QualificationTableAction +-- nullaryPathPiece ''QualificationTableAction $ camelToPathPiece' 2 +-- embedRenderMessage ''UniWorX ''QualificationTableAction id + +-- {- +-- isAdminAct :: QualificationTableAction -> Bool +-- isAdminAct QualificationActExpire = False +-- isAdminAct QualificationActUnexpire = False +-- isAdminAct QualificationActBlockSupervisor = False +-- isAdminAct _ = True +-- -} + +-- data QualificationTableActionData +-- = QualificationActExpireData +-- | QualificationActUnexpireData +-- | QualificationActBlockSupervisorData +-- | QualificationActBlockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool } +-- | QualificationActUnblockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool} +-- | QualificationActRenewData +-- | QualificationActGrantData { qualTableActGrantUntil :: Day } +-- deriving (Eq, Ord, Show, Generic) + +-- isExpiryAct :: QualificationTableActionData -> Bool +-- isExpiryAct QualificationActExpireData = True +-- isExpiryAct QualificationActUnexpireData = True +-- isExpiryAct _ = False + +-- isBlockAct :: QualificationTableActionData -> Bool +-- isBlockAct QualificationActBlockSupervisorData = True +-- isBlockAct QualificationActBlockData{} = True +-- isBlockAct QualificationActUnblockData{} = True +-- isBlockAct _ = False + +-- blockActRemoveSupervisors :: QualificationTableActionData -> Bool +-- blockActRemoveSupervisors QualificationActBlockSupervisorData = True +-- blockActRemoveSupervisors QualificationActBlockData{qualTableActRemoveSupervisors=res} = res +-- blockActRemoveSupervisors _ = False + +-- -- qualificationTableQuery :: QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr +-- -- -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) +-- -- , E.SqlExpr (Entity User) +-- -- , E.SqlExpr (Maybe (Entity LmsUser)) +-- -- ) +-- -- qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUse) = do +-- -- E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser +-- -- E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work +-- -- E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser +-- -- E.where_ $ fltr qualUser E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) +-- -- return (qualUser, user, lmsUser) + +-- qualificationTableQuery :: UTCTime -> QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr +-- -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) +-- , E.SqlExpr (Entity User) +-- , E.SqlExpr (Maybe (Entity LmsUser)) +-- , E.SqlExpr (Maybe (Entity QualificationUserBlock)) +-- ) +-- qualificationTableQuery now qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do +-- -- E.distinctOnOrderBy will not work: sorting with dbTable should work, except that columns contained in distinctOnOrderBy cannot be sorted inversely by user; but PostgreSQL leftJoin with distinct filters too many results, see SQL Example lead/lag under jost/misc DevOps +-- -- +-- E.on $ qualBlock E.?. QualificationUserBlockQualificationUser E.?=. qualUser E.^. QualificationUserId +-- E.&&. qualBlock `isLatestBlockBefore` E.val now +-- E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser +-- E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work +-- E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser +-- E.where_ $ fltr qualUser +-- E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) +-- return (qualUser, user, lmsUser, qualBlock) + + +-- mkQualificationTable :: +-- ( Functor h, ToSortable h +-- , AsCornice h p QualificationTableData (DBCell (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))) cols +-- ) +-- => Bool +-- -> Entity Qualification +-- -> Map QualificationTableAction (AForm Handler QualificationTableActionData) +-- -> (Map CompanyId Company -> cols) +-- -> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData)) +-- -> DB (FormResult (QualificationTableActionData, Set UserId), Widget) +-- mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do +-- svs <- getSupervisees +-- now <- liftIO getCurrentTime +-- -- lookup all companies +-- cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do +-- cmps <- selectList [] [] -- [Asc CompanyShorthand] +-- return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps +-- let +-- nowaday = utctDay now +-- mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday +-- csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) +-- dbtIdent :: Text +-- dbtIdent = "qualification" +-- fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs +-- dbtSQLQuery = qualificationTableQuery now qid fltrSvs +-- dbtRowKey = queryUser >>> (E.^. UserId) +-- dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock) -> do +-- -- cmps <- E.select . E.from $ \(usrComp `E.InnerJoin` comp) -> do +-- -- E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId +-- -- E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val (entityKey usr) +-- -- E.orderBy [E.asc (comp E.^. CompanyName)] +-- -- return (comp E.^. CompanyName, comp E.^. CompanyAvsId, usrComp E.^. UserCompanySupervisor) +-- cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany] +-- return (qualUsr, usr, lmsUsr, qUsrBlock, cmpUsr) +-- dbtColonnade = cols cmpMap +-- dbtSorting = mconcat +-- [ single $ sortUserNameLink queryUser +-- , single $ sortUserEmail queryUser +-- , single $ sortUserMatriclenr queryUser +-- , single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) +-- , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) +-- , single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified)) +-- , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) +-- , single ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom)) +-- , single ("lms-status-plus",SortColumnNeverNull $ \row -> E.coalesce [ E.joinV (queryLmsUser row E.?. LmsUserStatusDay) +-- , E.joinV (queryLmsUser row E.?. LmsUserNotified) +-- , queryLmsUser row E.?. LmsUserStarted]) +-- , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) +-- , single ("user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do +-- E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId +-- E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId +-- E.orderBy [E.asc (comp E.^. CompanyName)] +-- return (comp E.^. CompanyName) +-- ) +-- -- , single ("validity", SortColumn $ queryQualUser >>> validQualification now) +-- ] +-- dbtFilter = mconcat +-- [ single $ fltrUserNameEmail queryUser +-- , single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion -> +-- E.from $ \usrAvs -> -- do +-- E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId +-- E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==. +-- (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) )) +-- , single ("avs-card" , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of +-- Nothing -> E.false +-- Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do +-- E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId +-- E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId +-- E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo) +-- ) +-- , single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if +-- | Set.null criteria -> E.true +-- | otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria +-- ) +-- , single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion -> +-- E.from $ \(usrComp `E.InnerJoin` comp) -> do +-- let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf` +-- (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text))) +-- testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId +-- testcrit = maybe testname testnumber $ readMay $ CI.original criterion +-- E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId +-- E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit +-- ) +-- , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now)) +-- , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> +-- if | Just renewal <- mbRenewal +-- , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal +-- E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday +-- | otherwise -> E.true +-- ) +-- , single ("tobe-notified", FilterColumn $ \row criterion -> +-- if | Just True <- getLast criterion -> quserToNotify now (queryQualUser row) (queryQualBlock row) +-- | otherwise -> E.true +-- ) +-- , single ("status" , FilterColumn . E.mkExactFilterMaybeLast' (views (to queryLmsUser) (E.?. LmsUserId)) $ views (to queryLmsUser) (E.?. LmsUserStatus)) +-- ] +-- dbtFilterUI mPrev = mconcat +-- [ fltrUserNameEmailHdrUI MsgLmsUser mPrev +-- , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) +-- , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber) +-- , prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo) +-- , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) +-- , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) +-- , if isNothing mbRenewal then mempty +-- else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) +-- , prismAForm (singletonFilter "tobe-notified" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsNotificationDue) +-- , prismAForm (singletonFilter "status" . maybePrism _PathPiece) mPrev $ aopt (hoistField liftHandler (selectField optionsFinite) :: (Field _ (Maybe LmsStatus))) (fslI MsgTableLmsStatus) +-- ] +-- dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } +-- dbtCsvEncode = Just DBTCsvEncode +-- { dbtCsvExportForm = pure () +-- , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) +-- , dbtCsvName = csvName +-- , dbtCsvSheetName = csvName +-- , dbtCsvNoExportData = Just id +-- , dbtCsvHeader = const $ return $ Csv.headerOrder qtcExample +-- , dbtCsvExampleData = Just [qtcExample] +-- } +-- where +-- doEncode' :: QualificationTableData -> QualificationTableCsv +-- doEncode' = QualificationTableCsv +-- <$> view (resultUser . _entityVal . _userDisplayName) +-- <*> view (resultUser . _entityVal . _userDisplayEmail) +-- <*> (view resultCompanyUser >>= getCompanies) +-- <*> (view resultCompanyUser >>= getCompanyNos) +-- <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) +-- <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) +-- <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockUnblock . _not) +-- <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom) +-- <*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal) +-- <*> getStatusPlusTxt +-- <*> getStatusPlusDay +-- getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of +-- [] -> pure Nothing +-- somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps +-- getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) + +-- getStatusPlusTxt = +-- (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case +-- Just LmsBlocked{} -> return $ Just "Failed" +-- Just LmsExpired{} -> return $ Just "Expired" +-- Just LmsSuccess{} -> return $ Just "Success" +-- Nothing -> maybeM (return Nothing) (const $ return $ Just "Open") $ +-- preview (resultLmsUser . _entityVal . _lmsUserStarted) +-- getStatusPlusDay = +-- (join . preview (resultLmsUser . _entityVal . _lmsUserStatusDay)) >>= \case +-- lsd@(Just _) -> return lsd +-- Nothing -> preview (resultLmsUser . _entityVal . _lmsUserStarted) + +-- dbtCsvDecode = Nothing +-- dbtExtraReps = [] +-- dbtParams = DBParamsForm +-- { dbParamsFormMethod = POST +-- , dbParamsFormAction = Nothing +-- , dbParamsFormAttrs = [] +-- , dbParamsFormSubmit = FormSubmit +-- , dbParamsFormAdditional +-- = renderAForm FormStandard +-- $ (, mempty) . First . Just +-- <$> multiActionA acts (fslI MsgTableAction) Nothing +-- , dbParamsFormEvaluate = liftHandler . runFormPost +-- , dbParamsFormResult = id +-- , dbParamsFormIdent = def +-- } + +-- postprocess :: FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData) +-- -> FormResult ( QualificationTableActionData, Set UserId) +-- postprocess inp = do +-- (First (Just act), usrMap) <- inp +-- let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap +-- return (act, usrSet) + +-- -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableActionData)) +-- -- resultDBTableValidator = def +-- -- & defaultSorting [SortAscBy csvLmsIdent] +-- over _1 postprocess <$> dbTable psValidator DBTable{..} + +-- getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html +-- getQualificationR = postQualificationR +-- postQualificationR sid qsh = do +-- isAdmin <- hasReadAccessTo AdminR +-- msgGrantWarning <- messageIconI Warning IconWarning MsgQualificationActGrantWarning +-- msgUnexpire <- messageIconI Info IconWarning MsgQualificationActUnexpireWarning +-- now <- liftIO getCurrentTime +-- let nowaday = utctDay now +-- ((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do +-- qent@Entity{ +-- entityKey=qid +-- , entityVal=Qualification{ +-- qualificationAuditDuration=auditMonths +-- , qualificationValidDuration=validMonths +-- }} <- getBy404 $ SchoolQualificationShort sid qsh + +-- -- Block copied to Handler/Qualifications TODO: refactor +-- let getBlockReasons unblk = Ex.select $ do +-- (quser :& qblock) <- Ex.from $ Ex.table @QualificationUser +-- `Ex.innerJoin` Ex.table @QualificationUserBlock +-- `Ex.on` (\(quser :& qblock) -> quser Ex.^. QualificationUserId Ex.==. qblock Ex.^. QualificationUserBlockQualificationUser) +-- Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. Ex.val qid +-- Ex.&&. unblk (qblock Ex.^. QualificationUserBlockUnblock) +-- Ex.groupBy (qblock Ex.^. QualificationUserBlockReason) +-- let countRows' :: Ex.SqlExpr (Ex.Value Int64) = Ex.countRows +-- Ex.orderBy [Ex.desc countRows'] +-- Ex.limit 7 +-- pure (qblock Ex.^. QualificationUserBlockReason) +-- mkOption :: Ex.Value Text -> Option Text +-- mkOption (Ex.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t } +-- suggestionsBlock :: HandlerFor UniWorX (OptionList Text) +-- suggestionsBlock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons Ex.not_) +-- suggestionsUnblock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons id) +-- dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> validMonths +-- acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData) +-- acts = mconcat $ +-- [ singletonMap QualificationActExpire $ pure QualificationActExpireData +-- , singletonMap QualificationActUnexpire $ QualificationActUnexpireData +-- <$ aformMessage msgUnexpire +-- ] ++ bool +-- -- nonAdmin actions, ie. Supervisor +-- [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] +-- -- Admin-only actions +-- [ singletonMap QualificationActUnblock $ QualificationActUnblockData +-- <$> apreq (textField & cfStrip & addDatalist suggestionsUnblock) (fslI MsgQualificationGrantReason) Nothing +-- <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) +-- , singletonMap QualificationActBlock $ QualificationActBlockData +-- <$> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationBlockReason) Nothing +-- <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) +-- <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockRemoveSupervisor) (Just False) +-- , singletonMap QualificationActRenew $ pure QualificationActRenewData +-- , singletonMap QualificationActGrant $ QualificationActGrantData +-- <$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry +-- <* aformMessage msgGrantWarning +-- ] isAdmin +-- linkLmsUser = toMaybe isAdmin (LmsUserR sid qsh) +-- linkUserName = bool ForProfileR ForProfileDataR isAdmin +-- colChoices cmpMap = mconcat +-- [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) +-- , colUserNameModalHdr MsgLmsUser linkUserName +-- , colUserEmail +-- , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) -> +-- let icnSuper = text2markup " " <> icon IconSupervisor +-- cs = [ (cmpName, cmpSpr) +-- | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps +-- , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap +-- ] +-- companies = intercalate (text2markup ", ") $ +-- (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs +-- in wgtCell companies +-- , guardMonoid isAdmin colUserMatriclenr +-- -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) +-- , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d +-- , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d +-- , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) (dayCell . view ( resultQualUser . _entityVal . _qualificationUserValidUntil)) +-- , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row -> +-- qualificationValidReasonCell' (Just $ LmsUserR sid qsh) isAdmin nowaday (row ^? resultQualBlock) row +-- , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip +-- ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification +-- , sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths)) +-- $ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap (lmsStatusCell isAdmin linkLmsUser) lu +-- , sortable (Just "last-notified") (i18nCell MsgTableQualificationLastNotified) $ \( view $ resultQualUser . _entityVal . _qualificationUserLastNotified -> d) -> dateTimeCell d +-- ] +-- psValidator = def & defaultSorting [SortDescBy "last-refresh"] +-- tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator +-- return (tbl, qent) + +-- formResult lmsRes $ \case +-- (QualificationActRenewData, selectedUsers) | isAdmin -> do +-- noks <- runDB $ renewValidQualificationUsers qid Nothing $ Set.toList selectedUsers +-- 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 +-- addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers +-- reloadKeepGetParams $ QualificationR sid qsh +-- (action, selectedUsers) | isExpiryAct action -> do +-- let isUnexpire = action == QualificationActUnexpireData +-- upd <- runDB $ 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 +-- reloadKeepGetParams $ QualificationR sid qsh +-- (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do +-- let selUserIds = Set.toList selectedUsers +-- (unblock, reason) = case action of +-- QualificationActBlockSupervisorData -> (False, Right QualificationBlockReturnedByCompany) +-- QualificationActBlockData{..} -> (False, Left qualTableActBlockReason) +-- QualificationActUnblockData{..} -> (True , Left qualTableActBlockReason) +-- _ -> error "Handle.Qualification.isBlockAct returned non-block action" -- cannot occur due to earlier checks +-- notify = case action of +-- QualificationActBlockData{qualTableActNotify} -> qualTableActNotify +-- _ -> False + +-- oks <- runDB $ do +-- when (blockActRemoveSupervisors action) $ deleteWhere [UserSupervisorUser <-. selUserIds] +-- qualificationUserBlocking qid selUserIds unblock Nothing reason notify +-- let nrq = length selectedUsers +-- warnLevel = if +-- | oks < 0 -> Error +-- | oks == nrq -> Success +-- | otherwise -> Warning +-- fbmsg = if unblock then MsgQualificationStatusUnblock else MsgQualificationStatusBlock +-- addMessageI warnLevel $ fbmsg qsh oks nrq +-- reloadKeepGetParams $ QualificationR sid qsh +-- _ -> addMessageI Error MsgInvalidFormAction + +-- let heading = citext2widget $ qualificationName quali +-- siteLayout heading $ do +-- setTitle $ toHtml $ unSchoolKey sid <> "-" <> qsh +-- $(widgetFile "qualification") From bc0b449689458ee4868070f770b80dde518f58cf Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 9 Oct 2023 16:30:07 +0000 Subject: [PATCH 33/59] fix build --- src/Foundation/Navigation.hs | 2 +- src/Handler/Firm.hs | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 9fce295f5..a38b62b93 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -124,7 +124,7 @@ breadcrumb ProblemAvsSynchR = i18nCrumb MsgProblemsAvsSynchHeading $ Just breadcrumb ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just ProblemAvsSynchR breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing -breadcrumb FirmR = i18nCrumb MsgMenuFirms $ Just FirmAllR +breadcrumb FirmR{} = i18nCrumb MsgMenuFirms $ Just FirmAllR breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 5d640d603..10dcf320b 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -14,7 +14,7 @@ module Handler.Firm import Import -- import Jobs -import Handler.Utils +-- import Handler.Utils -- import qualified Data.Set as Set -- import qualified Data.Map as Map @@ -32,8 +32,8 @@ import Handler.Utils -- avoids repetition of local definitions -single :: (k,a) -> Map k a -single = uncurry Map.singleton +-- single :: (k,a) -> Map k a +-- single = uncurry Map.singleton getFirmAllR :: Handler Html From 8fcfc9586e3aca5f1eb0b3f1019127c7690328e8 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 10 Oct 2023 15:11:56 +0000 Subject: [PATCH 34/59] chore(firm): wip all firm table query --- routes | 2 +- src/Handler/Firm.hs | 213 ++++++++++++++++++++++++-------------------- 2 files changed, 116 insertions(+), 99 deletions(-) diff --git a/routes b/routes index e7f9fc7b9..031e7b5c2 100644 --- a/routes +++ b/routes @@ -113,7 +113,7 @@ /for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self /for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self -/firm FirmAllR GET +/firm FirmAllR GET !free /firm/#CompanyShorthand FirmR GET POST /exam-office ExamOfficeR !exam-office: diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 10dcf320b..8072ef78b 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -36,13 +36,6 @@ import Import -- single = uncurry Map.singleton -getFirmAllR :: Handler Html -getFirmAllR = do - siteLayoutMsg MsgMenuFirms $ do - setTitleI MsgMenuFirms - [whamlet|STUB TO DO|] - - getFirmR, postFirmR :: CompanyShorthand -> Handler Html getFirmR = postFirmR postFirmR _ = do @@ -51,101 +44,125 @@ postFirmR _ = do [whamlet|STUB TO DO|] --- isAdmin <- hasReadAccessTo AdminR --- firmTable <- runDB $ do --- view _2 <$> mkFirmAllTable isAdmin --- siteLayoutMsg MsgMenuFirms $ do --- setTitleI MsgMenuFirms --- $(widgetFile "firm-all") +getFirmAllR :: Handler Html +getFirmAllR = do + uid <- requireAuthId + isAdmin <- hasReadAccessTo AdminR + firmTable <- runDB $ do + view _2 <$> mkFirmAllTable (toMaybe (not isAdmin) uid) -- filter to associated companies for non-admins + siteLayoutMsg MsgMenuFirms $ do + setTitleI MsgMenuFirms + -- $(widgetFile "firm-all") + [whamlet|!!!STUB!!!TO DO!!! --- type AllQualificationTableData = DBRow (Entity Qualification, Ex.Value Word64, Ex.Value Word64) --- resultAllQualification :: Lens' AllQualificationTableData Qualification --- resultAllQualification = _dbrOutput . _1 . _entityVal - --- resultAllQualificationActive :: Lens' AllQualificationTableData Word64 --- resultAllQualificationActive = _dbrOutput . _2 . _unValue - --- resultAllQualificationTotal :: Lens' AllQualificationTableData Word64 --- resultAllQualificationTotal = _dbrOutput . _3 . _unValue + ^{firmTable} + |] --- mkQualificationAllTable :: Bool -> DB (Any, Widget) --- mkQualificationAllTable isAdmin = do --- svs <- getSupervisees --- now <- liftIO getCurrentTime --- let --- resultDBTable = DBTable{..} --- where --- dbtSQLQuery quali = do --- let filterSvs quser = quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId --- Ex.&&. (E.val isAdmin E.||. quser Ex.^. QualificationUserUser `Ex.in_` E.vals svs) --- cusers = Ex.subSelectCount $ do --- quser <- Ex.from $ Ex.table @QualificationUser --- Ex.where_ $ filterSvs quser --- cactive = Ex.subSelectCount $ do --- quser <- Ex.from $ Ex.table @QualificationUser --- Ex.where_ $ filterSvs quser Ex.&&. validQualification now quser --- return (quali, cactive, cusers) --- dbtRowKey = (Ex.^. QualificationId) --- dbtProj = dbtProjId --- dbtColonnade = dbColonnade $ mconcat --- [ colSchool $ resultAllQualification . _qualificationSchool --- , sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) -> --- let qsh = qualificationShorthand quali in --- anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qsh --- , sortable (Just "qname") (i18nCell MsgQualificationName) $ \(view resultAllQualification -> quali) -> --- let qsh = qualificationShorthand quali --- qnm = qualificationName quali --- in anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qnm --- , sortable Nothing (i18nCell MsgQualificationDescription) $ \(view resultAllQualification -> quali) -> --- maybeCell (qualificationDescription quali) markupCellLargeModal --- , sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $ --- foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration) --- , sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip , SomeMessage MsgTableDiffDaysTooltip]) $ --- foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshWithin) --- , sortable Nothing (i18nCell MsgQualificationRefreshReminder & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $ --- foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder) --- , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) --- $ tickmarkCell . view (resultAllQualification . _qualificationElearningStart) --- , sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip) --- $ tickmarkCell . view (resultAllQualification . _qualificationExpiryNotification) --- , sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip) --- $ \(view (resultAllQualification . _qualificationAvsLicence) -> licence) -> maybeCell licence $ textCell . T.singleton . licence2char --- , sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip) --- $ \(view (resultAllQualification . _qualificationSapId) -> mbSapId) -> tickmarkCell $ isJust mbSapId --- , sortable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip) --- $ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n --- , sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal --- ] --- dbtSorting = mconcat --- [ --- sortSchool $ to (E.^. QualificationSchool) --- , singletonMap "qshort" $ SortColumn (E.^. QualificationShorthand) --- , singletonMap "qname" $ SortColumn (E.^. QualificationName) --- , singletonMap "qelearning" $ SortColumn (E.^. QualificationElearningStart) --- , singletonMap "noteexpiry" $ SortColumn (E.^. QualificationExpiryNotification) --- ] --- dbtFilter = mconcat --- [ --- fltrSchool $ to (E.^. QualificationSchool) --- , singletonMap "qelearning" . FilterColumn $ E.mkExactFilterLast (E.^. QualificationElearningStart) --- ] --- dbtFilterUI = mconcat --- [ --- fltrSchoolUI --- , \mPrev -> prismAForm (singletonFilter "qelearning" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableLmsElearning) --- ] --- dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } --- dbtParams = def --- dbtIdent :: Text --- dbtIdent = "qualification-overview" --- dbtCsvEncode = noCsvEncode --- dbtCsvDecode = Nothing --- dbtExtraReps = [] +type AllCompanyTableData = DBRow (Entity Company, Ex.Value Word64, Ex.Value Word64, Ex.Value Word64) +resultAllCompany :: Lens' AllCompanyTableData Company +resultAllCompany = _dbrOutput . _1 . _entityVal --- resultDBTableValidator = def --- & defaultSorting [SortAscBy "school", SortAscBy "qshort"] --- dbTable resultDBTableValidator resultDBTable +resultAllCompanySupervisors :: Lens' AllCompanyTableData Word64 +resultAllCompanySupervisors = _dbrOutput . _2 . _unValue + +resultAllCompanyUsers :: Lens' AllCompanyTableData Word64 +resultAllCompanyUsers = _dbrOutput . _3 . _unValue + +resultAllCompanyForeignSupers :: Lens' AllCompanyTableData Word64 +resultAllCompanyForeignSupers = _dbrOutput . _4 . _unValue + + +mkQualificationAllTable :: Maybe UserId -> DB (Any, Widget) +mkQualificationAllTable mbUid = do + + now <- liftIO getCurrentTime + let + resultDBTable = DBTable{..} + where + dbtSQLQuery cmpy = do + let filterCmpy usrCmpy = usrCmpy E.^. UserCompanyCompany Ex.==. cmpy E.^. CompanyId + cforeign = Ex.subSelectCount $ Ex.distinct $ do + usrSuper <- Ex.from $ Ex.table @UserSupervisor + Ex.where_ (Ex.exists $ do + usrCmpy <- Ex.from $ Ex.table @UserCompany + Ex.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser + ) E.&&. Ex.notExists (do + usrCmpy <- Ex.from $ Ex.table @UserCompany + Ex.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor + ) + return $ usrSuper E.^. UserSupervisorSupervisor + cusers = Ex.subSelectCount $ do + usrCmpy <- Ex.from $ Ex.table @UserCompany + Ex.where_ $ filterCmpy usrCmpy + csupers = Ex.subSelectCount $ do + usrCmpy <- Ex.from $ Ex.table @UserCompany + Ex.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanySupervisor + whenIsJust mbUid $ \uid -> + Ex.where_ $ Ex.exists $ do -- only show associated companies + usrCmpy <- Ex.from $ Ex.table @UserCompany + Ex.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser Ex.==. E.val uid + return (cmpy, csupers, cusers, cforeign) + dbtRowKey = (Ex.^. CompanyShorthand) + dbtProj = dbtProjId + dbtColonnade = dbColonnade $ mconcat + [ colSchool $ resultAllQualification . _qualificationSchool + , sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) -> + let qsh = qualificationShorthand quali in + anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qsh + , sortable (Just "qname") (i18nCell MsgQualificationName) $ \(view resultAllQualification -> quali) -> + let qsh = qualificationShorthand quali + qnm = qualificationName quali + in anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qnm + , sortable Nothing (i18nCell MsgQualificationDescription) $ \(view resultAllQualification -> quali) -> + maybeCell (qualificationDescription quali) markupCellLargeModal + , sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $ + foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration) + , sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip , SomeMessage MsgTableDiffDaysTooltip]) $ + foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshWithin) + , sortable Nothing (i18nCell MsgQualificationRefreshReminder & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $ + foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder) + , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) + $ tickmarkCell . view (resultAllQualification . _qualificationElearningStart) + , sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip) + $ tickmarkCell . view (resultAllQualification . _qualificationExpiryNotification) + , sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip) + $ \(view (resultAllQualification . _qualificationAvsLicence) -> licence) -> maybeCell licence $ textCell . T.singleton . licence2char + , sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip) + $ \(view (resultAllQualification . _qualificationSapId) -> mbSapId) -> tickmarkCell $ isJust mbSapId + , sortable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip) + $ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n + , sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal + ] + dbtSorting = mconcat + [ + sortSchool $ to (E.^. QualificationSchool) + , singletonMap "qshort" $ SortColumn (E.^. QualificationShorthand) + , singletonMap "qname" $ SortColumn (E.^. QualificationName) + , singletonMap "qelearning" $ SortColumn (E.^. QualificationElearningStart) + , singletonMap "noteexpiry" $ SortColumn (E.^. QualificationExpiryNotification) + ] + dbtFilter = mconcat + [ + fltrSchool $ to (E.^. QualificationSchool) + , singletonMap "qelearning" . FilterColumn $ E.mkExactFilterLast (E.^. QualificationElearningStart) + ] + dbtFilterUI = mconcat + [ + fltrSchoolUI + , \mPrev -> prismAForm (singletonFilter "qelearning" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableLmsElearning) + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + dbtParams = def + dbtIdent :: Text + dbtIdent = "qualification-overview" + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + + resultDBTableValidator = def + & defaultSorting [SortAscBy "school", SortAscBy "qshort"] + dbTable resultDBTableValidator resultDBTable From 16d0fdd1c83b8ae3321df9e5a8cdd3ff33476be5 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 11 Oct 2023 08:46:25 +0000 Subject: [PATCH 35/59] chore(course): change default name for tutorial to %y_%m_%d --- src/Handler/Course/ParticipantInvite.hs | 2 +- src/Utils.hs | 3 +++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index d31cd0d41..4bdf04021 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -49,7 +49,7 @@ tutorialTemplateNames Nothing = ["Vorlage", "Template"] tutorialTemplateNames (Just name) = [prefixes <> suffixes | prefixes <- tutorialTemplateNames Nothing, suffixes <- [mempty, tutorialTypeSeparator <> name]] tutorialDefaultName :: Maybe TutorialType -> Day -> TutorialName -tutorialDefaultName Nothing = CI.mk . tshow -- Don't use user date display setting, so that tutorial default names conform to all users +tutorialDefaultName Nothing = string2citext . formatTime defaultTimeLocale "%y_%m_%d" -- Don't use user date display setting, so that tutorial default names conform to all users tutorialDefaultName (Just ttyp) = let prefix = CI.mk $ snd $ Text.breakOnEnd (CI.original tutorialTypeSeparator) $ CI.original ttyp in (<> (tutorialTypeSeparator <> prefix)) . tutorialDefaultName Nothing diff --git a/src/Utils.hs b/src/Utils.hs index dc9e8199a..80af449b7 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -312,6 +312,9 @@ citext2lower = Text.toLower . CI.original citext2string :: CI Text -> String citext2string = Text.unpack . CI.original +string2citext :: CI Text -> String +string2citext = CI.mk . Text.pack + -- | Convert or remove all non-ascii characters, e.g. for filenames text2asciiAlphaNum :: Text -> Text text2asciiAlphaNum = Text.filter (\c -> Char.isAlphaNum c && Char.isAscii c) From 87f0b2edab2bcf696b7b776e47272ef2204c0b75 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 11 Oct 2023 09:18:22 +0000 Subject: [PATCH 36/59] fix(build): Update Utils.hs --- src/Utils.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Utils.hs b/src/Utils.hs index 80af449b7..4f8b5ff03 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -312,7 +312,7 @@ citext2lower = Text.toLower . CI.original citext2string :: CI Text -> String citext2string = Text.unpack . CI.original -string2citext :: CI Text -> String +string2citext :: String -> CI Text string2citext = CI.mk . Text.pack -- | Convert or remove all non-ascii characters, e.g. for filenames From fa4f9b24475261afc1e534541c8878a85e6a1b10 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 11 Oct 2023 10:52:44 +0000 Subject: [PATCH 37/59] fix(build): Update ParticipantInvite.hs --- src/Handler/Course/ParticipantInvite.hs | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 4bdf04021..14cd08930 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -49,11 +49,19 @@ tutorialTemplateNames Nothing = ["Vorlage", "Template"] tutorialTemplateNames (Just name) = [prefixes <> suffixes | prefixes <- tutorialTemplateNames Nothing, suffixes <- [mempty, tutorialTypeSeparator <> name]] tutorialDefaultName :: Maybe TutorialType -> Day -> TutorialName -tutorialDefaultName Nothing = string2citext . formatTime defaultTimeLocale "%y_%m_%d" -- Don't use user date display setting, so that tutorial default names conform to all users +tutorialDefaultName Nothing = formatDayForTutName tutorialDefaultName (Just ttyp) = let prefix = CI.mk $ snd $ Text.breakOnEnd (CI.original tutorialTypeSeparator) $ CI.original ttyp in (<> (tutorialTypeSeparator <> prefix)) . tutorialDefaultName Nothing +formatDayForTutName :: Day -> CI Text -- "%yy_%mm_%dd" -- Do not use user date display setting, since tutorial default names must be universal regardless of user +-- formatDayForTutName = CI.mk . formatTime' "%y_%m_%d" -- we don't want to go monadic for this +formatDayForTutName d = CI.mk . Text.map d2u . Text.drop 2 . tshow + where + d2u '-' = '_' + d2u c = c + + data ButtonCourseRegisterMode = BtnCourseRegisterConfirm | BtnCourseRegisterAbort deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) instance Universe ButtonCourseRegisterMode From f888da3ab0df45bb3c515ebb7cbb43569fdaa1fa Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 11 Oct 2023 13:56:47 +0000 Subject: [PATCH 38/59] fix(build): Update ParticipantInvite.hs --- src/Handler/Course/ParticipantInvite.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 14cd08930..82ebe492f 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -56,7 +56,7 @@ tutorialDefaultName (Just ttyp) = formatDayForTutName :: Day -> CI Text -- "%yy_%mm_%dd" -- Do not use user date display setting, since tutorial default names must be universal regardless of user -- formatDayForTutName = CI.mk . formatTime' "%y_%m_%d" -- we don't want to go monadic for this -formatDayForTutName d = CI.mk . Text.map d2u . Text.drop 2 . tshow +formatDayForTutName = CI.mk . Text.map d2u . Text.drop 2 . tshow where d2u '-' = '_' d2u c = c From e831a76c2718d92d2d87642fb53cc49827b840b2 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 12 Oct 2023 14:50:42 +0000 Subject: [PATCH 39/59] chore(firm): fix imports --- src/Handler/Firm.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 8072ef78b..e7fc5fe85 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -14,7 +14,7 @@ module Handler.Firm import Import -- import Jobs --- import Handler.Utils +import Handler.Utils -- import qualified Data.Set as Set -- import qualified Data.Map as Map @@ -24,7 +24,7 @@ import Import -- import qualified Data.Conduit.List as C -- import Database.Persist.Sql (updateWhereCount) -- import Database.Esqueleto.Experimental ((:&)(..)) --- import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma +import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma -- import qualified Database.Esqueleto.Legacy as E -- import qualified Database.Esqueleto.PostgreSQL as E -- import qualified Database.Esqueleto.Utils as E From 855aee7f786dbe1360518da3cef62f4b630ef50d Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 12 Oct 2023 16:11:47 +0000 Subject: [PATCH 40/59] chore(SAP): send latest blocking --- src/Handler/SAP.hs | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index 79e69d222..dc251a6b7 100644 --- a/src/Handler/SAP.hs +++ b/src/Handler/SAP.hs @@ -56,8 +56,8 @@ instance ToNamedRecord SapUserTableCsv where -- | Removes all personalNummer which are not numbers between 10000 and 99999 (also excludes E-Accounts), which should not be returned by the query anyway (only qualfications with sap id and users with internal personnel number must be transmitted) -- TODO: once temporary suspensions are implemented, a user must be transmitted to SAP in two rows: firstheld->suspensionFrom & suspensionTo->validTo -sapRes2csv :: [(Ex.Value (Maybe Text), Ex.Value Day, Ex.Value Day, Ex.Value (Maybe Text))] -> [SapUserTableCsv] -sapRes2csv l = [ res | (Ex.Value pn@(Just persNo), Ex.Value firstHeld, Ex.Value validUntil, Ex.Value (Just sapId)) <- l +sapRes2csv :: [(Ex.Value (Maybe Text), Ex.Value Day, Ex.Value Day, Ex.Value (Maybe Text), Maybe (Entity QualificationUserBlock))] -> [SapUserTableCsv] +sapRes2csv l = [ res | (Ex.Value pn@(Just persNo), Ex.Value firstHeld, Ex.Value validUntil, Ex.Value (Just sapId), mbQualUserBlock) <- l -- , let persNoAsInt = readMay =<< persNo -- also see Handler.Utils.Profile.validFraportPersonalNumber -- , persNoAsInt >= Just (10000::Int) -- filter E-accounts for SAP export -- , persNoAsInt <= Just (99999::Int) -- filter E-accounts for SAP export @@ -65,12 +65,16 @@ sapRes2csv l = [ res | (Ex.Value pn@(Just persNo), Ex.Value firstHeld, Ex.Value { csvSUTpersonalNummer = persNo , csvSUTqualifikation = sapId , csvSUTgültigVon = firstHeld - , csvSUTgültigBis = validUntil + , csvSUTgültigBis = getMaxValidDay mbQualUserBlock validUntil -- , csvSUTsupendiertBis = blocked , csvSUTausprägung = "J" } , validFraportPersonalNumber pn ] + where + getMaxValidDay :: Maybe (Entity QualificationUserBlock) -> Day -> Day + getMaxValidDay (Just Entity{entityVal=QualificationUserBlock{qualificationUserBlockUnblock=False, qualificationUserBlockFrom=bd}}) = min $ utctDay bd + getMaxValidDay _ = id -- | Deliver all employess with a successful LDAP synch within the last 3 months getQualificationSAPDirectR :: Handler TypedContent @@ -79,12 +83,17 @@ getQualificationSAPDirectR = do fdate <- formatTime' "%Y%m%d_%H-%M" now let ldap_cutoff = addDiffDaysRollOver (fromMonths $ -3) now qualUsers <- runDB $ Ex.select $ do - (qual :& qualUser :& user) <- + (qual :& qualUser :& user :& qualBlock) <- Ex.from $ Ex.table @Qualification `Ex.innerJoin` Ex.table @QualificationUser `Ex.on` (\(qual :& qualUser) -> qual Ex.^. QualificationId Ex.==. qualUser Ex.^. QualificationUserQualification) `Ex.innerJoin` Ex.table @User `Ex.on` (\(_ :& qualUser :& user) -> qualUser Ex.^. QualificationUserUser Ex.==. user Ex.^. UserId) + `Ex.leftJoin` Ex.table @QualificationUserBlock + `Ex.on` (\(_ :& qualUser :& _ :& qualBlock) -> + qualBlock Ex.?. QualificationUserBlockQualificationUser E.?=. qualUser Ex.^. QualificationUserId + Ex.&&. qualBlock `isLatestBlockBefore` Ex.val now + ) Ex.where_ $ E.isJust (qual Ex.^. QualificationSapId) Ex.&&. E.isJust (user Ex.^. UserCompanyPersonalNumber) Ex.&&. E.isJust (user Ex.^. UserLastLdapSynchronisation) @@ -95,6 +104,7 @@ getQualificationSAPDirectR = do , qualUser Ex.^. QualificationUserValidUntil -- , qualUser Ex.^. QualificationUserBlockedDue , qual Ex.^. QualificationSapId + , qualBlock ) let csvRendered = toCsvRendered sapUserTableCsvHeader $ sapRes2csv qualUsers fmtOpts = (review csvPreset CsvPresetRFC) From cfec7874e6980d528f914328f503901c0c114bff Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 12 Oct 2023 20:29:57 +0000 Subject: [PATCH 41/59] chore(release): 27.4.42 --- CHANGELOG.md | 9 +++++++++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 13 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index c855e7e52..97201cf9d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,15 @@ 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.42](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.41...v27.4.42) (2023-10-12) + + +### Bug Fixes + +* **build:** Update ParticipantInvite.hs ([f888da3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f888da3ab0df45bb3c515ebb7cbb43569fdaa1fa)) +* **build:** Update ParticipantInvite.hs ([fa4f9b2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fa4f9b24475261afc1e534541c8878a85e6a1b10)) +* **build:** Update Utils.hs ([87f0b2e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/87f0b2edab2bcf696b7b776e47272ef2204c0b75)) + ## [27.4.41](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.40...v27.4.41) (2023-10-04) diff --git a/nix/docker/version.json b/nix/docker/version.json index ab442fe54..e7372094f 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.41" + "version": "27.4.42" } diff --git a/package-lock.json b/package-lock.json index 5ac06c7a7..ae695ba49 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.41", + "version": "27.4.42", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index ca56d2043..87897c865 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.41", + "version": "27.4.42", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 0e94d2098..1e1825d4c 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.41 +version: 27.4.42 dependencies: - base - yesod From 11861c4d010615accbd9ee37538aa035ba3cdd9c Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 13 Oct 2023 15:32:19 +0000 Subject: [PATCH 42/59] chore(sap): transmit multiple block/unblocks --- src/Database/Esqueleto/Utils.hs | 5 +- src/Handler/LMS.hs | 2 +- src/Handler/SAP.hs | 107 ++++++++++++++++++++------------ src/Utils.hs | 5 ++ 4 files changed, 76 insertions(+), 43 deletions(-) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index dc9f5159e..70cdaaecc 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -45,7 +45,7 @@ module Database.Esqueleto.Utils , unKey , selectCountRows, selectCountDistinct , selectMaybe - , day, day', interval, diffDays, diffTimes + , day, day', dayMaybe, interval, diffDays, diffTimes , exprLift , explicitUnsafeCoerceSqlExprValue , module Database.Esqueleto.Utils.TH @@ -656,6 +656,9 @@ day = E.unsafeSqlCastAs "date" day' :: E.SqlExpr (E.Value Text) -> E.SqlExpr (E.Value Day) day' = E.unsafeSqlCastAs "date" +dayMaybe :: E.SqlExpr (E.Value (Maybe UTCTime)) -> E.SqlExpr (E.Value (Maybe Day)) +dayMaybe = E.unsafeSqlCastAs "date" + interval :: CalendarDiffDays -> E.SqlExpr (E.Value Day) -- E.+=. requires both types to be the same, so we use Day -- interval _ = E.unsafeSqlCastAs "interval" $ E.unsafeSqlValue "'P2Y'" -- tested working example interval = E.unsafeSqlCastAs "interval". E.unsafeSqlValue . wrapSqlString . Text.Builder.fromString . iso8601Show diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 66ccf51a6..cdd720509 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -424,7 +424,7 @@ lmsTableQuery now qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.Left E.where_ $ E.isJust (pj E.^. PrintJobLmsUser) E.&&. ((lmsUser E.^. LmsUserIdent) E.=?. (pj E.^. PrintJobLmsUser)) let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on! - pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted typr of subSelect does not seem to support this! + pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted type of subSelect does not seem to support this! E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder return (qualUser, user, lmsUser, qualBlock, printAcknowledged, validQualification now qualUser) diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index dc251a6b7..01d856095 100644 --- a/src/Handler/SAP.hs +++ b/src/Handler/SAP.hs @@ -18,8 +18,9 @@ import Handler.Utils.Profile -- import qualified Data.CaseInsensitive as CI import qualified Data.Csv as Csv import Database.Esqueleto.Experimental ((:&)(..)) -import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma +import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma -- import qualified Database.Esqueleto.Legacy as E +import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E @@ -55,26 +56,43 @@ instance ToNamedRecord SapUserTableCsv where ] -- | Removes all personalNummer which are not numbers between 10000 and 99999 (also excludes E-Accounts), which should not be returned by the query anyway (only qualfications with sap id and users with internal personnel number must be transmitted) --- TODO: once temporary suspensions are implemented, a user must be transmitted to SAP in two rows: firstheld->suspensionFrom & suspensionTo->validTo -sapRes2csv :: [(Ex.Value (Maybe Text), Ex.Value Day, Ex.Value Day, Ex.Value (Maybe Text), Maybe (Entity QualificationUserBlock))] -> [SapUserTableCsv] -sapRes2csv l = [ res | (Ex.Value pn@(Just persNo), Ex.Value firstHeld, Ex.Value validUntil, Ex.Value (Just sapId), mbQualUserBlock) <- l - -- , let persNoAsInt = readMay =<< persNo -- also see Handler.Utils.Profile.validFraportPersonalNumber - -- , persNoAsInt >= Just (10000::Int) -- filter E-accounts for SAP export - -- , persNoAsInt <= Just (99999::Int) -- filter E-accounts for SAP export - , let res = SapUserTableCsv - { csvSUTpersonalNummer = persNo - , csvSUTqualifikation = sapId - , csvSUTgültigVon = firstHeld - , csvSUTgültigBis = getMaxValidDay mbQualUserBlock validUntil - -- , csvSUTsupendiertBis = blocked - , csvSUTausprägung = "J" - } - , validFraportPersonalNumber pn - ] - where - getMaxValidDay :: Maybe (Entity QualificationUserBlock) -> Day -> Day - getMaxValidDay (Just Entity{entityVal=QualificationUserBlock{qualificationUserBlockUnblock=False, qualificationUserBlockFrom=bd}}) = min $ utctDay bd - getMaxValidDay _ = id +-- temporary suspensions are transmitted to SAP in multiple rows: firstheld->suspension1, reinstate1->suspension2, reinstate2->validTo +sapRes2csv :: [(E.Value (Maybe Text), E.Value (Maybe Text), E.Value Day, E.Value Day, E.Value (Maybe [Maybe Day]), E.Value (Maybe [Maybe Bool]))] -> [SapUserTableCsv] +sapRes2csv = concatMap procRes + where + procRes (E.Value pn@(Just persNo), E.Value (Just sapId), E.Value firstHeld, E.Value validUntil, E.Value (fromMaybe [] -> qubFroms), E.Value (fromMaybe [] -> qubUnblocks)) + | validFraportPersonalNumber pn -- between 10000 and 99999 also see Handler.Utils.Profile.validFraportPersonalNumber + = let mkSap (dfrom,duntil) = SapUserTableCsv + { csvSUTpersonalNummer = persNo + , csvSUTqualifikation = sapId + , csvSUTgültigVon = dfrom + , csvSUTgültigBis = duntil + , csvSUTausprägung = "J" + } + in fmap mkSap $ compileBlocks firstHeld validUntil $ zipMaybes qubFroms qubUnblocks + procRes _ = [] + +-- | compute a series of valid periods, assume that lists is already sorted by Day +-- the lists encodes qualification_user_blocks with block=False/unblock=True +compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)] +compileBlocks dfrom duntil [] = [(dfrom, duntil )] +compileBlocks dfrom duntil [(d,False)] = [(dfrom, min duntil d)] -- redundant, but common case +compileBlocks dfrom duntil (p1@(d1,u1):(d2,u2):bs) + | u1 == u2 = compileBlocks dfrom duntil (p1:bs) -- superfluous block/unblock + | u2, dfrom < d1, d1 < d2, d2 < duntil = (dfrom, d1) : compileBlocks d2 duntil bs -- block and reinstated later +compileBlocks dfrom duntil ((_,True ):bs) = compileBlocks dfrom duntil bs -- superfluous unblock +compileBlocks dfrom duntil ((d,False):bs) = compileBlocks dfrom (min duntil d) bs -- should only occur if blocks/unblock happened on same day + +-- Alternative Version constructed first, probably more efficient, but GHC does not recognize pattern matching as complete +-- compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)] +-- compileBlocks dfrom duntil (p1@(d1,u1):p2@(d2,u2):bs) +-- | u1 == u2 = compileBlocks dfrom duntil (p1:bs) +-- | u2, d1 < duntil +-- , d2 < duntil = (dfrom,d1) : compileBlocks d2 duntil bs +-- compileBlocks dfrom duntil ((d1,True):bs) = compileBlocks dfrom duntil bs +-- compileBlocks dfrom duntil [(d1,False)] = [(dfrom, min duntil d1)] +-- compileBlocks dfrom duntil _ = [(dfrom,duntil)] + -- | Deliver all employess with a successful LDAP synch within the last 3 months getQualificationSAPDirectR :: Handler TypedContent @@ -82,29 +100,36 @@ getQualificationSAPDirectR = do now <- liftIO getCurrentTime fdate <- formatTime' "%Y%m%d_%H-%M" now let ldap_cutoff = addDiffDaysRollOver (fromMonths $ -3) now - qualUsers <- runDB $ Ex.select $ do + qualUsers <- runDB $ E.select $ do (qual :& qualUser :& user :& qualBlock) <- - Ex.from $ Ex.table @Qualification - `Ex.innerJoin` Ex.table @QualificationUser - `Ex.on` (\(qual :& qualUser) -> qual Ex.^. QualificationId Ex.==. qualUser Ex.^. QualificationUserQualification) - `Ex.innerJoin` Ex.table @User - `Ex.on` (\(_ :& qualUser :& user) -> qualUser Ex.^. QualificationUserUser Ex.==. user Ex.^. UserId) - `Ex.leftJoin` Ex.table @QualificationUserBlock - `Ex.on` (\(_ :& qualUser :& _ :& qualBlock) -> - qualBlock Ex.?. QualificationUserBlockQualificationUser E.?=. qualUser Ex.^. QualificationUserId - Ex.&&. qualBlock `isLatestBlockBefore` Ex.val now + E.from $ E.table @Qualification + `E.innerJoin` E.table @QualificationUser + `E.on` (\(qual :& qualUser) -> qual E.^. QualificationId E.==. qualUser E.^. QualificationUserQualification) + `E.innerJoin` E.table @User + `E.on` (\(_ :& qualUser :& user) -> qualUser E.^. QualificationUserUser E.==. user E.^. UserId) + `E.leftJoin` E.table @QualificationUserBlock + `E.on` (\(_ :& qualUser :& _ :& qualBlock) -> + qualUser E.^. QualificationUserId E.=?. qualBlock E.?. QualificationUserBlockQualificationUser + E.&&. E.val now E.>~. qualBlock E.?. QualificationUserBlockFrom ) - Ex.where_ $ E.isJust (qual Ex.^. QualificationSapId) - Ex.&&. E.isJust (user Ex.^. UserCompanyPersonalNumber) - Ex.&&. E.isJust (user Ex.^. UserLastLdapSynchronisation) - Ex.&&. (E.justVal ldap_cutoff Ex.<=. user Ex.^. UserLastLdapSynchronisation) + E.where_ $ E.isJust (qual E.^. QualificationSapId) + E.&&. E.isJust (user E.^. UserCompanyPersonalNumber) + E.&&. E.isJust (user E.^. UserLastLdapSynchronisation) + E.&&. (E.justVal ldap_cutoff E.<=. user E.^. UserLastLdapSynchronisation) + E.groupBy ( user E.^. UserCompanyPersonalNumber + , qualUser E.^. QualificationUserFirstHeld + , qualUser E.^. QualificationUserValidUntil + , qual E.^. QualificationSapId + ) + let blockOrder = [E.asc $ qualBlock E.?. QualificationUserBlockFrom, E.asc $ qualBlock E.?. QualificationUserBlockId] + -- blockAgg f = E.arrayAggWith E.AggModeAll (qualBlock E.^. f) blockOrder return - ( user Ex.^. UserCompanyPersonalNumber - , qualUser Ex.^. QualificationUserFirstHeld - , qualUser Ex.^. QualificationUserValidUntil - -- , qualUser Ex.^. QualificationUserBlockedDue - , qual Ex.^. QualificationSapId - , qualBlock + ( user E.^. UserCompanyPersonalNumber + , qual E.^. QualificationSapId + , qualUser E.^. QualificationUserFirstHeld + , qualUser E.^. QualificationUserValidUntil + , E.arrayAggWith E.AggModeAll (E.dayMaybe $ qualBlock E.?. QualificationUserBlockFrom ) blockOrder + , E.arrayAggWith E.AggModeAll ( qualBlock E.?. QualificationUserBlockUnblock) blockOrder ) let csvRendered = toCsvRendered sapUserTableCsvHeader $ sapRes2csv qualUsers fmtOpts = (review csvPreset CsvPresetRFC) diff --git a/src/Utils.hs b/src/Utils.hs index 4f8b5ff03..7ff482a96 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -668,6 +668,11 @@ lastMaybe' l = fmap snd $ l ^? _Snoc minimumMaybe :: (MonoFoldable mono, Ord (Element mono)) => mono -> Maybe (Element mono) minimumMaybe = fmap minimum . fromNullable +zipMaybes :: [Maybe a] -> [Maybe b] -> [(a,b)] +zipMaybes (Just x:xs) (Just y:ys) = (x,y) : zipMaybes xs ys +zipMaybes (_:xs) (_:ys) = zipMaybes xs ys +zipMaybes _ _ = [] + -- | Merge/Add any attribute-value pair to an existing list of such pairs. -- If the attribute exists, the new valu will be prepended, separated by a single empty space insertAttr :: Text -> Text -> [(Text,Text)] -> [(Text,Text)] From a57cdde4503387608f68dc7ff7cf8bce888d52a1 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 13 Oct 2023 20:05:40 +0000 Subject: [PATCH 43/59] chore(release): 27.4.43 --- CHANGELOG.md | 2 ++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 6 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 97201cf9d..52590b3be 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,8 @@ 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.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 e7372094f..09792e934 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.42" + "version": "27.4.43" } diff --git a/package-lock.json b/package-lock.json index ae695ba49..0ea0303ce 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.42", + "version": "27.4.43", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 87897c865..2af7ab202 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.42", + "version": "27.4.43", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 1e1825d4c..3e70cba93 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.42 +version: 27.4.43 dependencies: - base - yesod From b4a88abcf85783c350ad2bf3a5e973d13d1eb1f6 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 16 Oct 2023 17:53:45 +0000 Subject: [PATCH 44/59] fix(sap): compileBlocks --- src/Handler/SAP.hs | 9 +++--- test/Handler/SAPSpec.hs | 61 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 66 insertions(+), 4 deletions(-) create mode 100644 test/Handler/SAPSpec.hs diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index 01d856095..0012b3902 100644 --- a/src/Handler/SAP.hs +++ b/src/Handler/SAP.hs @@ -6,6 +6,7 @@ module Handler.SAP ( getQualificationSAPDirectR + , compileBlocks -- for Test in Handler.SAPSpec only ) where @@ -78,10 +79,10 @@ compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)] compileBlocks dfrom duntil [] = [(dfrom, duntil )] compileBlocks dfrom duntil [(d,False)] = [(dfrom, min duntil d)] -- redundant, but common case compileBlocks dfrom duntil (p1@(d1,u1):(d2,u2):bs) - | u1 == u2 = compileBlocks dfrom duntil (p1:bs) -- superfluous block/unblock - | u2, dfrom < d1, d1 < d2, d2 < duntil = (dfrom, d1) : compileBlocks d2 duntil bs -- block and reinstated later -compileBlocks dfrom duntil ((_,True ):bs) = compileBlocks dfrom duntil bs -- superfluous unblock -compileBlocks dfrom duntil ((d,False):bs) = compileBlocks dfrom (min duntil d) bs -- should only occur if blocks/unblock happened on same day + | u1 == u2 = compileBlocks dfrom duntil (p1:bs) -- superfluous block/unblock + | u2, dfrom < d1, d1 < d2, d2 < duntil = (dfrom, d1) : compileBlocks d2 duntil bs -- block and reinstated later +compileBlocks dfrom duntil ((_,True ):bs) = compileBlocks dfrom duntil bs -- superfluous unblock +compileBlocks dfrom duntil ((_,False):bs) = compileBlocks dfrom duntil bs -- should only occur if blocks/unblock happened on same day -- Alternative Version constructed first, probably more efficient, but GHC does not recognize pattern matching as complete -- compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)] diff --git a/test/Handler/SAPSpec.hs b/test/Handler/SAPSpec.hs new file mode 100644 index 000000000..f0edd28b4 --- /dev/null +++ b/test/Handler/SAPSpec.hs @@ -0,0 +1,61 @@ +-- SPDX-FileCopyrightText: 2023 Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +module Handler.SAPSpec where + +import TestImport +-- import ModelSpec () +-- import CryptoID + +import Handler.SAP + + +data BlockIntervalTest = BlockIntervalTest Day Day [(Day,Bool)] + deriving (Show, Eq, Ord) + +instance Arbitrary BlockIntervalTest where + arbitrary = do + blocks <- arbitrary + case blocks of + [] -> do + dFrom <- arbitrary + dUntil <- arbitrary `suchThat` (dFrom <) + return $ BlockIntervalTest dFrom dUntil [] + ((h,_):t') -> do + let ds = ncons h (fst <$> t') + dmin = minimum ds + dmax = maximum ds + dFrom <- arbitrary `suchThat` (< dmin) + dUntil <- arbitrary `suchThat` (>= dmax) + return $ BlockIntervalTest dFrom dUntil $ sort blocks + + shrink (BlockIntervalTest dFrom dUntil []) + = [BlockIntervalTest dF dU [] | dF <- shrink dFrom, dU <- shrink dUntil, dF < dU] + shrink (BlockIntervalTest dFrom dUntil blocks) + = [BlockIntervalTest dFrom dUntil b | b <- shrink blocks, all ((dFrom <=) . fst) b] + + +cmpBlocks :: BlockIntervalTest -> [(Day,Day)] +cmpBlocks (BlockIntervalTest dFrom dUntil blocks) = makePeriods dFrom dUntil $ cleanBlocks $ sort blocks + where + cleanBlocks ((_,True):r) = cleanBlocks r + cleanBlocks (b1@(_,False):b2@(_,True):r) = b1:b2:cleanBlocks r + cleanBlocks (b1@(_,False): (_,False):r) = cleanBlocks (b1:r) + cleanBlocks r@[(_,False)] = r + cleanBlocks [] = [] + + makePeriods a b ((d1,False):(d2,True):r) + | b > d2 = (a,d1):makePeriods d2 b r + | otherwise = [(a,d1)] + makePeriods a b [(d,False)] = [(a,min b d)] + makePeriods a b _ = [(a,b)] + + + +spec :: Spec +spec = do + describe "SAP.compileBlocks" $ do + it "yields basic intervals" . property $ + \bit@(BlockIntervalTest dFrom dUntil blocks) -> + cmpBlocks bit == compileBlocks dFrom dUntil blocks From cbb44f106ad59e0a53ca04963ade5544120b7e21 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 17 Oct 2023 12:19:47 +0200 Subject: [PATCH 45/59] fix(sap): combine immediate next day licence chnages for SAP --- src/Handler/SAP.hs | 28 ++++++++++-------------- test/Handler/SAPSpec.hs | 48 +++++++++++++++++++++++++++++++++++------ 2 files changed, 52 insertions(+), 24 deletions(-) diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index 0012b3902..c22cc58bb 100644 --- a/src/Handler/SAP.hs +++ b/src/Handler/SAP.hs @@ -76,24 +76,18 @@ sapRes2csv = concatMap procRes -- | compute a series of valid periods, assume that lists is already sorted by Day -- the lists encodes qualification_user_blocks with block=False/unblock=True compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)] -compileBlocks dfrom duntil [] = [(dfrom, duntil )] -compileBlocks dfrom duntil [(d,False)] = [(dfrom, min duntil d)] -- redundant, but common case -compileBlocks dfrom duntil (p1@(d1,u1):(d2,u2):bs) - | u1 == u2 = compileBlocks dfrom duntil (p1:bs) -- superfluous block/unblock - | u2, dfrom < d1, d1 < d2, d2 < duntil = (dfrom, d1) : compileBlocks d2 duntil bs -- block and reinstated later -compileBlocks dfrom duntil ((_,True ):bs) = compileBlocks dfrom duntil bs -- superfluous unblock -compileBlocks dfrom duntil ((_,False):bs) = compileBlocks dfrom duntil bs -- should only occur if blocks/unblock happened on same day +compileBlocks dStart dEnd = go (dStart, True) + where + go :: (Day,Bool) -> [(Day,Bool)] -> [(Day, Day)] + go (d,s) ((d1,s1):r1@((d2,s2):r2)) + | d1 == d2 || succ d1 == d2 || s == s1 || d1 < d = go (d,s) r1 -- ignore unnecessary change + go (d,s) ((d1,s1):r1) + | s, d < d1, d1 < dEnd = (d,d1) : go (d1,s1) r1 -- valid interval found + | otherwise = go (d1,s1) r1 -- ignore invalid interval + go (d,s) [] + | s = [(d,dEnd)] + | otherwise = [] --- Alternative Version constructed first, probably more efficient, but GHC does not recognize pattern matching as complete --- compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)] --- compileBlocks dfrom duntil (p1@(d1,u1):p2@(d2,u2):bs) --- | u1 == u2 = compileBlocks dfrom duntil (p1:bs) --- | u2, d1 < duntil --- , d2 < duntil = (dfrom,d1) : compileBlocks d2 duntil bs --- compileBlocks dfrom duntil ((d1,True):bs) = compileBlocks dfrom duntil bs --- compileBlocks dfrom duntil [(d1,False)] = [(dfrom, min duntil d1)] --- compileBlocks dfrom duntil _ = [(dfrom,duntil)] - -- | Deliver all employess with a successful LDAP synch within the last 3 months getQualificationSAPDirectR :: Handler TypedContent diff --git a/test/Handler/SAPSpec.hs b/test/Handler/SAPSpec.hs index f0edd28b4..856bcf001 100644 --- a/test/Handler/SAPSpec.hs +++ b/test/Handler/SAPSpec.hs @@ -10,7 +10,7 @@ import TestImport import Handler.SAP - +{- data BlockIntervalTest = BlockIntervalTest Day Day [(Day,Bool)] deriving (Show, Eq, Ord) @@ -26,7 +26,7 @@ instance Arbitrary BlockIntervalTest where let ds = ncons h (fst <$> t') dmin = minimum ds dmax = maximum ds - dFrom <- arbitrary `suchThat` (< dmin) + dFrom <- arbitrary `suchThat` (<= dmin) dUntil <- arbitrary `suchThat` (>= dmax) return $ BlockIntervalTest dFrom dUntil $ sort blocks @@ -34,13 +34,30 @@ instance Arbitrary BlockIntervalTest where = [BlockIntervalTest dF dU [] | dF <- shrink dFrom, dU <- shrink dUntil, dF < dU] shrink (BlockIntervalTest dFrom dUntil blocks) = [BlockIntervalTest dFrom dUntil b | b <- shrink blocks, all ((dFrom <=) . fst) b] +-} +{- These alternative implementations do NOT meet the specifications and thus cannot be used for testing +compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)] +compileBlocks dfrom duntil [] = [(dfrom, duntil)] +compileBlocks dfrom duntil [(d,False)] + | dend <- min duntil d, dfrom < dend = [(dfrom, dend)] -- redundant, but common case + | otherwise = [] +compileBlocks dfrom duntil (p1@(d1,u1):p2@(d2,u2):bs) + | u1 == u2 = compileBlocks dfrom duntil (p1:bs) -- superfluous block/unblock + | d1 == d2 = compileBlocks dfrom duntil (p2:bs) -- eliminate same day changes + | u2, dfrom < d1, d1 < d2, d2 < duntil = (dfrom, d1) : compileBlocks d2 duntil bs -- block and reinstated later +compileBlocks dfrom duntil ((_,True ):bs) = compileBlocks dfrom duntil bs -- superfluous unblock +compileBlocks dfrom duntil ((d,False):bs) + | dfrom >= d = compileBlocks dfrom duntil bs -- should only occur if blocks/unblock happened on same day + cmpBlocks :: BlockIntervalTest -> [(Day,Day)] cmpBlocks (BlockIntervalTest dFrom dUntil blocks) = makePeriods dFrom dUntil $ cleanBlocks $ sort blocks where cleanBlocks ((_,True):r) = cleanBlocks r - cleanBlocks (b1@(_,False):b2@(_,True):r) = b1:b2:cleanBlocks r + cleanBlocks (b1@(d1,False):b2@(d2,True):r) + | d1 < d1 = b1:b2:cleanBlocks r + | otherwise = cleanBlocks r cleanBlocks (b1@(_,False): (_,False):r) = cleanBlocks (b1:r) cleanBlocks r@[(_,False)] = r cleanBlocks [] = [] @@ -50,12 +67,29 @@ cmpBlocks (BlockIntervalTest dFrom dUntil blocks) = makePeriods dFrom dUntil $ c | otherwise = [(a,d1)] makePeriods a b [(d,False)] = [(a,min b d)] makePeriods a b _ = [(a,b)] - +-} spec :: Spec spec = do describe "SAP.compileBlocks" $ do - it "yields basic intervals" . property $ - \bit@(BlockIntervalTest dFrom dUntil blocks) -> - cmpBlocks bit == compileBlocks dFrom dUntil blocks + it "works on examples" . example $ do + let wA = fromGregorian 2002 1 11 + wE = fromGregorian 2025 4 30 + w0 = fromGregorian 2001 9 22 + w1 = fromGregorian 2023 9 22 + w2 = fromGregorian 2023 10 16 + w3 = fromGregorian 2023 11 17 + compileBlocks wA wE [] `shouldBe` [(wA,wE)] + compileBlocks wA wE [(w1,False)] `shouldBe` [(wA,w1)] + compileBlocks wA wE [(w1,False),(w2,True)] `shouldBe` [(wA,w1),(w2,wE)] + compileBlocks wA wE [(wA,False),(w1,True)] `shouldBe` [(w1,wE)] + compileBlocks wA wE [(wA,True),(wA,False),(w1,True)] `shouldBe` [(w1,wE)] + compileBlocks wA wE [(wA,False),(wA,True),(w1,True)] `shouldBe` [(wA,wE)] + compileBlocks wA wE [(wA,False),(w1,True),(w2,False)] `shouldBe` [(w1,w2)] + compileBlocks wA wE [(w1,False),(w1,True),(w1,False),(w1,True),(w1,False),(w2,True)] `shouldBe` [(wA,w1),(w2,wE)] + compileBlocks wA wE [(w1,False),(succ w1,True),(succ w1,False),(w2,True)] `shouldBe` [(wA,succ 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)] + -- it "yields basic intervals" . property $ + -- \bit@(BlockIntervalTest dFrom dUntil blocks) -> + -- cmpBlocks bit == compileBlocks dFrom dUntil blocks From f4adfdf87270930d4ca6611f2a9956613fcace53 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 17 Oct 2023 13:57:19 +0200 Subject: [PATCH 46/59] fix(sap): combine immediate next day licence chnages for SAP --- src/Handler/SAP.hs | 10 ++++++---- test/Handler/SAPSpec.hs | 37 +++++++++++++++++++++++++++++++------ 2 files changed, 37 insertions(+), 10 deletions(-) diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index c22cc58bb..10b71fd9f 100644 --- a/src/Handler/SAP.hs +++ b/src/Handler/SAP.hs @@ -79,11 +79,13 @@ compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)] compileBlocks dStart dEnd = go (dStart, True) where go :: (Day,Bool) -> [(Day,Bool)] -> [(Day, Day)] - go (d,s) ((d1,s1):r1@((d2,s2):r2)) - | d1 == d2 || succ d1 == d2 || s == s1 || d1 < d = go (d,s) r1 -- ignore unnecessary change + go (d,s) ((d1,s1):r1@((d2,_s2):_r2)) + | d1 == d2 || succ d1 == d2 || s == s1 || d1 < d = go (d,s) r1 -- ignore unnecessary change go (d,s) ((d1,s1):r1) - | s, d < d1, d1 < dEnd = (d,d1) : go (d1,s1) r1 -- valid interval found - | otherwise = go (d1,s1) r1 -- ignore invalid interval + | s, not s1 + , d < d1, d1 < dEnd = (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 = [] diff --git a/test/Handler/SAPSpec.hs b/test/Handler/SAPSpec.hs index 856bcf001..3f99699cf 100644 --- a/test/Handler/SAPSpec.hs +++ b/test/Handler/SAPSpec.hs @@ -80,16 +80,41 @@ spec = do w1 = fromGregorian 2023 9 22 w2 = fromGregorian 2023 10 16 w3 = fromGregorian 2023 11 17 + w4 = fromGregorian 2024 01 21 compileBlocks wA wE [] `shouldBe` [(wA,wE)] compileBlocks wA wE [(w1,False)] `shouldBe` [(wA,w1)] + compileBlocks wA wE [(w1,True)] `shouldBe` [(wA,wE)] compileBlocks wA wE [(w1,False),(w2,True)] `shouldBe` [(wA,w1),(w2,wE)] compileBlocks wA wE [(wA,False),(w1,True)] `shouldBe` [(w1,wE)] - compileBlocks wA wE [(wA,True),(wA,False),(w1,True)] `shouldBe` [(w1,wE)] - compileBlocks wA wE [(wA,False),(wA,True),(w1,True)] `shouldBe` [(wA,wE)] + compileBlocks wA wE [(wA,True),(wA,False),(w1,True)] `shouldBe` [(w1,wE)] + compileBlocks wA wE [(wA,False),(wA,True),(w1,True)] `shouldBe` [(wA,wE)] compileBlocks wA wE [(wA,False),(w1,True),(w2,False)] `shouldBe` [(w1,w2)] - compileBlocks wA wE [(w1,False),(w1,True),(w1,False),(w1,True),(w1,False),(w2,True)] `shouldBe` [(wA,w1),(w2,wE)] + compileBlocks wA wE [(w1,False),(w2,True),(w3,True)] `shouldBe` [(wA,w1),(w2,wE)] compileBlocks wA wE [(w1,False),(succ w1,True),(succ w1,False),(w2,True)] `shouldBe` [(wA,succ w1),(w2,wE)] + 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)] - -- it "yields basic intervals" . property $ - -- \bit@(BlockIntervalTest dFrom dUntil blocks) -> - -- cmpBlocks bit == compileBlocks dFrom dUntil blocks + compileBlocks wA wE [(w0,False),(w1,False),(w2,True),(w3,False),(w4,True)] `shouldBe` [(wA,w1),(w2,w3),(w4,wE)] + + it "handles basic intervals" $ do + (d1,d2,d3) <- generate $ do + d1 <- arbitrary + d2 <- arbitrary `suchThat` (d1 <) + d3 <- arbitrary `suchThat` (d1 <) + return (d1,d2,d3) + b <- generate arbitrary + let test = compileBlocks d1 d2 [(d3,b)] + test `shouldBe` bool [(d1,min d2 d3)] [(d1,d2)] b + + it "identifies two correct intervals" $ do + (d1,d2,d3,d4) <- generate $ do + d1 <- arbitrary + d2 <- arbitrary `suchThat` (d1 <) + 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)] + test `shouldBe` result From 3924d14abd868305b42c9d04913536b4999dc45b Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 17 Oct 2023 16:56:56 +0200 Subject: [PATCH 47/59] fix(sap): combineBlocks yet another bug squashed --- src/Handler/SAP.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index 10b71fd9f..34b00b81b 100644 --- a/src/Handler/SAP.hs +++ b/src/Handler/SAP.hs @@ -79,13 +79,13 @@ compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)] compileBlocks dStart dEnd = go (dStart, True) where go :: (Day,Bool) -> [(Day,Bool)] -> [(Day, Day)] - go (d,s) ((d1,s1):r1@((d2,_s2):_r2)) - | d1 == d2 || succ d1 == d2 || s == s1 || d1 < d = go (d,s) r1 -- ignore unnecessary change - go (d,s) ((d1,s1):r1) - | s, not s1 - , d < d1, d1 < dEnd = (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 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) [] | s = [(d,dEnd)] | otherwise = [] From d81e6e15dcfeda1fa75d1c48f3f86e3cd663c2af Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 17 Oct 2023 16:09:48 +0000 Subject: [PATCH 48/59] chore(firm): WIP company overview --- .../utils/table_column/de-de-formal.msg | 5 + messages/uniworx/utils/table_column/en-eu.msg | 5 + routes | 2 +- src/Handler/Firm.hs | 143 ++++++++---------- 4 files changed, 71 insertions(+), 84 deletions(-) diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index fdf42b885..b25230af4 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -75,8 +75,13 @@ TableExamOfficeLabelStatus: Label-Farbe TableExamOfficeLabelPriority: Label-Priorität TableQualifications: Qualifikationen TableCompany: Firma +TableCompanyShort: Firmenkürzel TableCompanies: Firmen +TableCompanyNo: Firmennummer TableCompanyNos: Firmennummern +TableCompanyNrUsers: Firmenangehörige +TableCompanyNrSupers: Ansprechpartner +TableCompanyNrForeignSupers: Firmenfremde Ansprechpartner TableSupervisor: Ansprechpartner TableCreationTime: Erstellungszeit TableJob !ident-ok: Job diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index b4fe83d34..e3d095d4f 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -75,8 +75,13 @@ TableExamOfficeLabelStatus: Label colour TableExamOfficeLabelPriority: Label priority TableQualifications: Qualifications TableCompany: Company +TableCompanyShort: Company shorthand TableCompanies: Companies +TableCompanyNo: Company number TableCompanyNos: Company numbers +TableCompanyNrUsers: Associates +TableCompanyNrSupers: Supervisors +TableCompanyNrForeignSupers: External Supervisors TableSupervisor: Supervisor TableCreationTime: Creation TableJob !ident-ok: Job diff --git a/routes b/routes index 031e7b5c2..0af78745f 100644 --- a/routes +++ b/routes @@ -113,7 +113,7 @@ /for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self /for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self -/firm FirmAllR GET !free +/firm FirmAllR GET /firm/#CompanyShorthand FirmR GET POST /exam-office ExamOfficeR !exam-office: diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index e7fc5fe85..9e7a56a29 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -24,7 +24,7 @@ import Handler.Utils -- import qualified Data.Conduit.List as C -- import Database.Persist.Sql (updateWhereCount) -- import Database.Esqueleto.Experimental ((:&)(..)) -import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma +import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma -- import qualified Database.Esqueleto.Legacy as E -- import qualified Database.Esqueleto.PostgreSQL as E -- import qualified Database.Esqueleto.Utils as E @@ -49,7 +49,7 @@ getFirmAllR = do uid <- requireAuthId isAdmin <- hasReadAccessTo AdminR firmTable <- runDB $ do - view _2 <$> mkFirmAllTable (toMaybe (not isAdmin) uid) -- filter to associated companies for non-admins + view _2 <$> mkFirmAllTable isAdmin uid -- filter to associated companies for non-admins siteLayoutMsg MsgMenuFirms $ do setTitleI MsgMenuFirms -- $(widgetFile "firm-all") @@ -59,7 +59,7 @@ getFirmAllR = do |] -type AllCompanyTableData = DBRow (Entity Company, Ex.Value Word64, Ex.Value Word64, Ex.Value Word64) +type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64) resultAllCompany :: Lens' AllCompanyTableData Company resultAllCompany = _dbrOutput . _1 . _entityVal @@ -73,95 +73,72 @@ resultAllCompanyForeignSupers :: Lens' AllCompanyTableData Word64 resultAllCompanyForeignSupers = _dbrOutput . _4 . _unValue -mkQualificationAllTable :: Maybe UserId -> DB (Any, Widget) -mkQualificationAllTable mbUid = do - +mkQualificationAllTable :: Bool -> UserId -> DB (Any, Widget) +mkQualificationAllTable isAdmin uid = do now <- liftIO getCurrentTime - let + let resultDBTable = DBTable{..} where dbtSQLQuery cmpy = do - let filterCmpy usrCmpy = usrCmpy E.^. UserCompanyCompany Ex.==. cmpy E.^. CompanyId - cforeign = Ex.subSelectCount $ Ex.distinct $ do - usrSuper <- Ex.from $ Ex.table @UserSupervisor - Ex.where_ (Ex.exists $ do - usrCmpy <- Ex.from $ Ex.table @UserCompany - Ex.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser - ) E.&&. Ex.notExists (do - usrCmpy <- Ex.from $ Ex.table @UserCompany - Ex.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor + let filterCmpy usrCmpy = usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId + cforeign = E.subSelectCount $ E.distinct $ do + usrSuper <- E.from $ E.table @UserSupervisor + E.where_ (E.exists $ do + usrCmpy <- E.from $ E.table @UserCompany + E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser + ) E.&&. E.notExists (do + usrCmpy <- E.from $ E.table @UserCompany + E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor ) return $ usrSuper E.^. UserSupervisorSupervisor - cusers = Ex.subSelectCount $ do - usrCmpy <- Ex.from $ Ex.table @UserCompany - Ex.where_ $ filterCmpy usrCmpy - csupers = Ex.subSelectCount $ do - usrCmpy <- Ex.from $ Ex.table @UserCompany - Ex.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanySupervisor + cusers = E.subSelectCount $ do + usrCmpy <- E.from $ E.table @UserCompany + E.where_ $ filterCmpy usrCmpy + csupers = E.subSelectCount $ do + usrCmpy <- E.from $ E.table @UserCompany + E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanySupervisor whenIsJust mbUid $ \uid -> - Ex.where_ $ Ex.exists $ do -- only show associated companies - usrCmpy <- Ex.from $ Ex.table @UserCompany - Ex.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser Ex.==. E.val uid + E.where_ $ E.exists $ do -- only show associated companies + usrCmpy <- E.from $ E.table @UserCompany + E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. E.val uid return (cmpy, csupers, cusers, cforeign) - dbtRowKey = (Ex.^. CompanyShorthand) + dbtRowKey = (E.^. CompanyShorthand) dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat - [ colSchool $ resultAllQualification . _qualificationSchool - , sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) -> - let qsh = qualificationShorthand quali in - anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qsh - , sortable (Just "qname") (i18nCell MsgQualificationName) $ \(view resultAllQualification -> quali) -> - let qsh = qualificationShorthand quali - qnm = qualificationName quali - in anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qnm - , sortable Nothing (i18nCell MsgQualificationDescription) $ \(view resultAllQualification -> quali) -> - maybeCell (qualificationDescription quali) markupCellLargeModal - , sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $ - foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration) - , sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip , SomeMessage MsgTableDiffDaysTooltip]) $ - foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshWithin) - , sortable Nothing (i18nCell MsgQualificationRefreshReminder & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $ - foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder) - , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) - $ tickmarkCell . view (resultAllQualification . _qualificationElearningStart) - , sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip) - $ tickmarkCell . view (resultAllQualification . _qualificationExpiryNotification) - , sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip) - $ \(view (resultAllQualification . _qualificationAvsLicence) -> licence) -> maybeCell licence $ textCell . T.singleton . licence2char - , sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip) - $ \(view (resultAllQualification . _qualificationSapId) -> mbSapId) -> tickmarkCell $ isJust mbSapId - , sortable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip) - $ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n - , sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal + [ if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultAllCompany . _companyShorthand)) + , sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> + anchorCell (FirmR $ companyShorthand firm) . toWgt $ companyName firm + , sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) -> + let fsh = companyShorthand firm + anchorCell (FirmR fsh) $ toWgt fsh + , sortable (Just "nr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> + let fsh = companyShorthand firm + anchorCell (FirmR fsh) $ toWgt $ companyAvsId firm + , sortable Nothing (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr + , sortable Nothing (i18nCell MsgTableCompanyNrSupers) $ \(view resultAllCompanySupervisors -> nr) -> wgtCell $ word2widget nr + , sortable Nothing (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr ] dbtSorting = mconcat - [ - sortSchool $ to (E.^. QualificationSchool) - , singletonMap "qshort" $ SortColumn (E.^. QualificationShorthand) - , singletonMap "qname" $ SortColumn (E.^. QualificationName) - , singletonMap "qelearning" $ SortColumn (E.^. QualificationElearningStart) - , singletonMap "noteexpiry" $ SortColumn (E.^. QualificationExpiryNotification) + [ singletonMap "name" $ SortColumn (E.^. CompanyName) + , singletonMap "short" $ SortColumn (E.^. CompanyShorthand) + , singletonMap "nr" $ SortColumn (E.^. CompanyAvsId) ] dbtFilter = mconcat - [ - fltrSchool $ to (E.^. QualificationSchool) - , singletonMap "qelearning" . FilterColumn $ E.mkExactFilterLast (E.^. QualificationElearningStart) + [ ] dbtFilterUI = mconcat - [ - fltrSchoolUI - , \mPrev -> prismAForm (singletonFilter "qelearning" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableLmsElearning) + [ ] - dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + dbtStyle = def -- { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = def dbtIdent :: Text - dbtIdent = "qualification-overview" + dbtIdent = "firm" dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing dbtExtraReps = [] resultDBTableValidator = def - & defaultSorting [SortAscBy "school", SortAscBy "qshort"] + -- & defaultSorting [SortAscBy "school", SortAscBy "qshort"] dbTable resultDBTableValidator resultDBTable @@ -391,7 +368,7 @@ mkQualificationAllTable mbUid = do -- csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) -- dbtIdent :: Text -- dbtIdent = "qualification" --- fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs +-- fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `E.in_` E.vals svs -- dbtSQLQuery = qualificationTableQuery now qid fltrSvs -- dbtRowKey = queryUser >>> (E.^. UserId) -- dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock) -> do @@ -562,21 +539,21 @@ mkQualificationAllTable mbUid = do -- }} <- getBy404 $ SchoolQualificationShort sid qsh -- -- Block copied to Handler/Qualifications TODO: refactor --- let getBlockReasons unblk = Ex.select $ do --- (quser :& qblock) <- Ex.from $ Ex.table @QualificationUser --- `Ex.innerJoin` Ex.table @QualificationUserBlock --- `Ex.on` (\(quser :& qblock) -> quser Ex.^. QualificationUserId Ex.==. qblock Ex.^. QualificationUserBlockQualificationUser) --- Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. Ex.val qid --- Ex.&&. unblk (qblock Ex.^. QualificationUserBlockUnblock) --- Ex.groupBy (qblock Ex.^. QualificationUserBlockReason) --- let countRows' :: Ex.SqlExpr (Ex.Value Int64) = Ex.countRows --- Ex.orderBy [Ex.desc countRows'] --- Ex.limit 7 --- pure (qblock Ex.^. QualificationUserBlockReason) --- mkOption :: Ex.Value Text -> Option Text --- mkOption (Ex.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t } +-- let getBlockReasons unblk = E.select $ do +-- (quser :& qblock) <- E.from $ E.table @QualificationUser +-- `E.innerJoin` E.table @QualificationUserBlock +-- `E.on` (\(quser :& qblock) -> quser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser) +-- E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid +-- E.&&. unblk (qblock E.^. QualificationUserBlockUnblock) +-- E.groupBy (qblock E.^. QualificationUserBlockReason) +-- let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows +-- E.orderBy [E.desc countRows'] +-- E.limit 7 +-- pure (qblock E.^. QualificationUserBlockReason) +-- mkOption :: E.Value Text -> Option Text +-- mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t } -- suggestionsBlock :: HandlerFor UniWorX (OptionList Text) --- suggestionsBlock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons Ex.not_) +-- suggestionsBlock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons E.not_) -- suggestionsUnblock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons id) -- dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> validMonths -- acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData) From ebf250bd8cc5b2dff25f56a02fac0594b3232def Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 18 Oct 2023 06:55:47 +0000 Subject: [PATCH 49/59] 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 50/59] 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 51/59] 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 92e83475a94b6b0a1ea0ecd2f03b493422459ba2 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 18 Oct 2023 15:45:59 +0000 Subject: [PATCH 52/59] chore(firm): link firms throughout --- routes | 8 ++++---- src/Handler/Admin/Avs.hs | 11 +++++----- src/Handler/Firm.hs | 35 +++++++++++++++----------------- src/Handler/LMS.hs | 13 +++++------- src/Handler/Qualification.hs | 11 ++++------ src/Handler/Users.hs | 10 ++++----- src/Handler/Utils/Table/Cells.hs | 10 +++++++++ src/Utils.hs | 4 ++++ 8 files changed, 54 insertions(+), 48 deletions(-) diff --git a/routes b/routes index 0af78745f..b4485c890 100644 --- a/routes +++ b/routes @@ -113,7 +113,7 @@ /for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self /for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self -/firm FirmAllR GET +/firm FirmAllR GET /firm/#CompanyShorthand FirmR GET POST /exam-office ExamOfficeR !exam-office: @@ -278,7 +278,7 @@ /lms/#SchoolId/#QualificationShorthand/edit LmsEditR GET POST -- old V1 LMS Interface /lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET -/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET !token -- LMS +/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET !token -- LMS /lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST /lms/#SchoolId/#QualificationShorthand/userlist/upload LmsUserlistUploadR GET POST !development /lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST !token -- LMS, also remove JobLmsUserlist constructor @@ -287,11 +287,11 @@ /lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST !token -- LMS, also remove JobLmsResults constructor -- new V2 LMS Interface /lms/#SchoolId/#QualificationShorthand/learners LmsLearnersR GET -/lms/#SchoolId/#QualificationShorthand/learners/direct LmsLearnersDirectR GET !token -- LMS +/lms/#SchoolId/#QualificationShorthand/learners/direct LmsLearnersDirectR GET !token -- LMS /lms/#SchoolId/#QualificationShorthand/report LmsReportR GET POST /lms/#SchoolId/#QualificationShorthand/report/upload LmsReportUploadR GET POST !development /lms/#SchoolId/#QualificationShorthand/report/direct LmsReportDirectR POST !token -- LMS --- other lms routes +-- other lms routes /lms/#SchoolId/#QualificationShorthand/ident/#LmsIdent LmsIdentR GET -- redirect to LmsR with filter-parameter /lms/#SchoolId/#QualificationShorthand/user/#CryptoUUIDUser LmsUserR GET /lmsuser/#CryptoUUIDUser LmsUserAllR GET diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index e7b4fda22..365143304 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -556,11 +556,12 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid E.orderBy [E.asc (comp E.^. CompanyName)] - return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) - let companies = intersperse (text2markup ", ") $ - (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies' - icnSuper = text2markup " " <> icon IconSupervisor - pure $ toWgt $ mconcat companies + return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) + let icnSuper = toWidget $ text2markup " " <> icon IconSupervisor + companies = + (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies' + + pure $ intercalate (text2widget "; ") companies , sortable (Just "qualification") (i18nCell MsgTableQualifications) $ \(preview resultQualification -> q) -> cellMaybe lmsShortCell q , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> cellMaybe dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \(preview $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> cellMaybe dayCell d diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 9e7a56a29..fe487f78c 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -28,7 +28,7 @@ import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications -- import qualified Database.Esqueleto.Legacy as E -- import qualified Database.Esqueleto.PostgreSQL as E -- import qualified Database.Esqueleto.Utils as E --- import Database.Esqueleto.Utils.TH +import Database.Esqueleto.Utils.TH -- avoids repetition of local definitions @@ -38,10 +38,10 @@ import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications getFirmR, postFirmR :: CompanyShorthand -> Handler Html getFirmR = postFirmR -postFirmR _ = do +postFirmR fsh = do siteLayoutMsg MsgMenuFirms $ do setTitleI MsgMenuFirms - [whamlet|STUB TO DO|] + [whamlet|STUB FOR #{fsh} TO DO|] getFirmAllR :: Handler Html @@ -53,8 +53,7 @@ getFirmAllR = do siteLayoutMsg MsgMenuFirms $ do setTitleI MsgMenuFirms -- $(widgetFile "firm-all") - [whamlet|!!!STUB!!!TO DO!!! - + [whamlet|!!!STUB!!!TO DO!!! ^{firmTable} |] @@ -73,9 +72,9 @@ resultAllCompanyForeignSupers :: Lens' AllCompanyTableData Word64 resultAllCompanyForeignSupers = _dbrOutput . _4 . _unValue -mkQualificationAllTable :: Bool -> UserId -> DB (Any, Widget) -mkQualificationAllTable isAdmin uid = do - now <- liftIO getCurrentTime +mkFirmAllTable :: Bool -> UserId -> DB (Any, Widget) +mkFirmAllTable isAdmin uid = do + -- now <- liftIO getCurrentTime let resultDBTable = DBTable{..} where @@ -83,7 +82,7 @@ mkQualificationAllTable isAdmin uid = do let filterCmpy usrCmpy = usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId cforeign = E.subSelectCount $ E.distinct $ do usrSuper <- E.from $ E.table @UserSupervisor - E.where_ (E.exists $ do + E.where_ $ E.exists (do usrCmpy <- E.from $ E.table @UserCompany E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser ) E.&&. E.notExists (do @@ -97,23 +96,21 @@ mkQualificationAllTable isAdmin uid = do csupers = E.subSelectCount $ do usrCmpy <- E.from $ E.table @UserCompany E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanySupervisor - whenIsJust mbUid $ \uid -> - E.where_ $ E.exists $ do -- only show associated companies - usrCmpy <- E.from $ E.table @UserCompany - E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. E.val uid + unless isAdmin $ E.where_ $ E.exists $ do -- only show associated companies + usrCmpy <- E.from $ E.table @UserCompany + E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. E.val uid return (cmpy, csupers, cusers, cforeign) dbtRowKey = (E.^. CompanyShorthand) dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat - [ if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultAllCompany . _companyShorthand)) - , sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> + [ -- if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultAllCompany . _companyShorthand)) + sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> anchorCell (FirmR $ companyShorthand firm) . toWgt $ companyName firm , sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) -> - let fsh = companyShorthand firm - anchorCell (FirmR fsh) $ toWgt fsh + let fsh = companyShorthand firm + in anchorCell (FirmR fsh) $ toWgt fsh , sortable (Just "nr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> - let fsh = companyShorthand firm - anchorCell (FirmR fsh) $ toWgt $ companyAvsId firm + anchorCell (FirmR $ companyShorthand firm) $ toWgt $ companyAvsId firm , sortable Nothing (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr , sortable Nothing (i18nCell MsgTableCompanyNrSupers) $ \(view resultAllCompanySupervisors -> nr) -> wgtCell $ word2widget nr , sortable Nothing (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index cdd720509..c927cc8f8 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -42,7 +42,7 @@ import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.Csv as Csv import qualified Data.Text as T -import qualified Data.CaseInsensitive as CI +-- import qualified Data.CaseInsensitive as CI import qualified Data.Conduit.List as C import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma @@ -445,7 +445,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do cmps <- selectList [] [] -- [Asc CompanyShorthand] return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps let - csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) + csvName = T.replace " " "-" $ ciOriginal (quali ^. _qualificationName) dbtIdent :: Text dbtIdent = "lms" dbtSQLQuery = lmsTableQuery now qid @@ -506,7 +506,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf` (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text))) testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId - testcrit = maybe testname testnumber $ readMay $ CI.original criterion + testcrit = maybe testname testnumber $ readMay $ ciOriginal criterion E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit ) @@ -637,14 +637,11 @@ postLmsR sid qsh = do , colUserNameModalHdr MsgLmsUser AdminUserR , colUserEmail , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) -> - let icnSuper = text2markup " " <> icon IconSupervisor - cs = [ (cmpName, cmpSpr) + let cs = [ companyCell (unCompanyKey cmpId) cmpName cmpSpr | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap ] - companies = intercalate (text2markup ", ") $ - (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs - in wgtCell companies + in intercalate spacerCell cs , colUserMatriclenr -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 6553bb300..5297c8801 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -586,14 +586,11 @@ postQualificationR sid qsh = do , colUserNameModalHdr MsgLmsUser linkUserName , colUserEmail , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) -> - let icnSuper = text2markup " " <> icon IconSupervisor - cs = [ (cmpName, cmpSpr) - | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps - , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap + let cs = [ companyCell (unCompanyKey cmpId) cmpName cmpSpr + | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps + , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap ] - companies = intercalate (text2markup ", ") $ - (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs - in wgtCell companies + in intercalate spacerCell cs , guardMonoid isAdmin colUserMatriclenr -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 23ca1e78d..f5ae958e4 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -106,11 +106,11 @@ postUsersR = do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid E.orderBy [E.asc (comp E.^. CompanyName)] - return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) - let companies = intersperse (text2markup ", ") $ - (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies' - icnSuper = text2markup " " <> icon IconSupervisor - pure $ toWgt $ mconcat companies + return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) + let icnSuper = toWidget $ text2markup " " <> icon IconSupervisor + companies = + (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies' + pure $ intercalate (text2widget "; ") companies , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM (AdminUserR <$> encrypt uid) (toWgt userCompanyPersonalNumber) diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 42970a046..e19be03aa 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -307,6 +307,16 @@ courseCell Course{..} = anchorCell link name `mappend` desc ^{modal "Beschreibung" (Right $ toWidget descr)} |] +companyCell :: IsDBTable m a => CompanyShorthand -> CompanyName -> Bool -> DBCell m a +companyCell cid cname isSupervisor = anchorCell link name + where + link = FirmR cid + corg = ciOriginal cname + name + | isSupervisor = text2markup (corg <> " ") <> icon IconSupervisor + | otherwise = text2markup corg + + qualificationCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c qualificationCell (view hasQualification -> Qualification{..}) = anchorCell link name where diff --git a/src/Utils.hs b/src/Utils.hs index 7ff482a96..28b7d88a8 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -305,6 +305,10 @@ tshowCrop = cropText . tshow stripCI :: Text -> CI Text stripCI = CI.mk . Text.strip +-- | just to avoid adding an import for this +ciOriginal :: CI Text -> Text +ciOriginal = CI.original + citext2lower :: CI Text -> Text citext2lower = Text.toLower . CI.original From c011d887cece8338920355b540aa4b233e0b994f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 18 Oct 2023 17:53:00 +0200 Subject: [PATCH 53/59] 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 54/59] 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 55/59] 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 56/59] 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 From 4cdf39a1fd34720d00ce7c055baa5c2d6188b5a7 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 19 Oct 2023 16:42:37 +0000 Subject: [PATCH 57/59] chore(firm): sorting by employee and supervisor numbers --- src/Handler/Firm.hs | 83 ++++++++++++++++++++++++++++--------------- src/Handler/LMS.hs | 1 - test/Database/Fill.hs | 1 + 3 files changed, 55 insertions(+), 30 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index fe487f78c..de717655f 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -2,6 +2,7 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later +{-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances {-# LANGUAGE TypeApplications #-} @@ -39,9 +40,28 @@ import Database.Esqueleto.Utils.TH getFirmR, postFirmR :: CompanyShorthand -> Handler Html getFirmR = postFirmR postFirmR fsh = do + cusers <- runDB $ do + cusers <- selectList [UserCompanyCompany ==. CompanyKey fsh] [] + selectList [UserId <-. fmap (userCompanyUser . entityVal) cusers] [Asc UserDisplayName] + csuper <- runDB $ do + csuper <- selectList [UserCompanyCompany ==. CompanyKey fsh, UserCompanySupervisor ==. True] [] + selectList [UserId <-. fmap (userCompanyUser . entityVal) csuper] [Asc UserDisplayName] siteLayoutMsg MsgMenuFirms $ do setTitleI MsgMenuFirms - [whamlet|STUB FOR #{fsh} TO DO|] + [whamlet|STUB HANDLER FOR #{fsh} TO DO + +

Supervisors (non-foreign only) +
    + $forall u <- csuper +
  • ^{userWidget u} + +

    Employees +
      + $forall u <- cusers +
    • ^{userWidget u} + + In the end, this needs to be a dbTable, of course! + |] getFirmAllR :: Handler Html @@ -71,6 +91,24 @@ resultAllCompanyUsers = _dbrOutput . _3 . _unValue resultAllCompanyForeignSupers :: Lens' AllCompanyTableData Word64 resultAllCompanyForeignSupers = _dbrOutput . _4 . _unValue +fromUserCompany :: Maybe (E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Company) -> E.SqlQuery () +fromUserCompany mbFltr cmpy = do + usrCmpy <- E.from $ E.table @UserCompany + let basecond = usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId + E.where_ $ maybe basecond ((basecond E.&&.).($ usrCmpy)) mbFltr + +firmCountUsers :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountUsers = E.subSelectCount . fromUserCompany Nothing + +firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountSupervisors = E.subSelectCount . fromUserCompany (Just (E.^. UserCompanySupervisor)) + +firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountForeignSupervisors cmpy = E.subSelectCount $ E.distinct $ do + usrSuper <- E.from $ E.table @UserSupervisor + E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) + E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy) + return $ usrSuper E.^. UserSupervisorSupervisor mkFirmAllTable :: Bool -> UserId -> DB (Any, Widget) mkFirmAllTable isAdmin uid = do @@ -79,46 +117,33 @@ mkFirmAllTable isAdmin uid = do resultDBTable = DBTable{..} where dbtSQLQuery cmpy = do - let filterCmpy usrCmpy = usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId - cforeign = E.subSelectCount $ E.distinct $ do - usrSuper <- E.from $ E.table @UserSupervisor - E.where_ $ E.exists (do - usrCmpy <- E.from $ E.table @UserCompany - E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser - ) E.&&. E.notExists (do - usrCmpy <- E.from $ E.table @UserCompany - E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor - ) - return $ usrSuper E.^. UserSupervisorSupervisor - cusers = E.subSelectCount $ do - usrCmpy <- E.from $ E.table @UserCompany - E.where_ $ filterCmpy usrCmpy - csupers = E.subSelectCount $ do - usrCmpy <- E.from $ E.table @UserCompany - E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanySupervisor unless isAdmin $ E.where_ $ E.exists $ do -- only show associated companies usrCmpy <- E.from $ E.table @UserCompany - E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. E.val uid - return (cmpy, csupers, cusers, cforeign) + E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId + E.&&. usrCmpy E.^. UserCompanyUser E.==. E.val uid + return (cmpy, firmCountForeignSupervisors cmpy, firmCountUsers cmpy, firmCountSupervisors cmpy) dbtRowKey = (E.^. CompanyShorthand) dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat [ -- if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultAllCompany . _companyShorthand)) - sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> + sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> anchorCell (FirmR $ companyShorthand firm) . toWgt $ companyName firm - , sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) -> + , sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) -> let fsh = companyShorthand firm in anchorCell (FirmR fsh) $ toWgt fsh - , sortable (Just "nr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> + , sortable (Just "avsnr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> anchorCell (FirmR $ companyShorthand firm) $ toWgt $ companyAvsId firm - , sortable Nothing (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr - , sortable Nothing (i18nCell MsgTableCompanyNrSupers) $ \(view resultAllCompanySupervisors -> nr) -> wgtCell $ word2widget nr - , sortable Nothing (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr + , sortable (Just "users") (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr + , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupers) $ \(view resultAllCompanySupervisors -> nr) -> wgtCell $ word2widget nr + , sortable (Just "foreigners") (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr ] dbtSorting = mconcat - [ singletonMap "name" $ SortColumn (E.^. CompanyName) - , singletonMap "short" $ SortColumn (E.^. CompanyShorthand) - , singletonMap "nr" $ SortColumn (E.^. CompanyAvsId) + [ singletonMap "name" $ SortColumn (E.^. CompanyName) + , singletonMap "short" $ SortColumn (E.^. CompanyShorthand) + , singletonMap "avsnr" $ SortColumn (E.^. CompanyAvsId) + , singletonMap "users" $ SortColumn firmCountUsers + , singletonMap "supervisors" $ SortColumn firmCountSupervisors + , singletonMap "foreigners" $ SortColumn firmCountForeignSupervisors ] dbtFilter = mconcat [ diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index c927cc8f8..84892c760 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -3,7 +3,6 @@ -- SPDX-License-Identifier: AGPL-3.0-or-later {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances -{-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only {-# LANGUAGE TypeApplications #-} module Handler.LMS diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index a4d2ab2c4..ce98b437f 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -636,6 +636,7 @@ fillDb = do void . insert' $ UserCompany fhamann bpol False False void . insert' $ UserCompany fhamann ffacil True True void . insert' $ UserCompany fhamann nice False False + insertMany_ [UserCompany uid fraGround False False| Entity uid User{userMatrikelnummer = fmap readMay -> Just (Just n)} <- matUsers] -- void . insert' $ UserSupervisor jost gkleen True -- void . insert' $ UserSupervisor jost svaupel False -- void . insert' $ UserSupervisor jost sbarth False From 601ce7abdf2a392d30f1ff799a2338968be795f1 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 20 Oct 2023 15:29:40 +0000 Subject: [PATCH 58/59] fix(firm): foreign supervisor counts correct and sortable --- src/Database/Esqueleto/Utils.hs | 7 ++ src/Handler/Firm.hs | 120 ++++++++++++++++++++++++-------- src/Utils.hs | 3 + test/Database/Fill.hs | 7 +- 4 files changed, 106 insertions(+), 31 deletions(-) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 70cdaaecc..af0fd0e76 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -43,6 +43,7 @@ module Database.Esqueleto.Utils , (->.), (->>.), (#>>.) , fromSqlKey , unKey + , subSelectCountDistinct , selectCountRows, selectCountDistinct , selectMaybe , day, day', dayMaybe, interval, diffDays, diffTimes @@ -628,6 +629,12 @@ unKey :: ( Coercible (Key entity) a unKey = E.veryUnsafeCoerceSqlExprValue +subSelectCountDistinct :: (Num a, PersistField a) => Ex.SqlQuery (Ex.SqlExpr (Ex.Value typ)) -> Ex.SqlExpr (Ex.Value a) +subSelectCountDistinct query = Ex.subSelectUnsafe (Ex.countDistinct <$> query) + +-- PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a) +-- countDistinct :: Num a => SqlExpr (Value typ) -> SqlExpr (Value a) + selectCountRows :: (Num a, PersistField a, MonadIO m) => E.SqlQuery ignored -> E.SqlReadT m a selectCountRows q = do res <- E.select $ E.countRows <$ q diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index de717655f..d711045a7 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -2,13 +2,15 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later -{-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only +{-# OPTIONS -Wno-unused-top-binds -Wno-unused-imports #-} -- TODO: remove me, for debugging only {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances {-# LANGUAGE TypeApplications #-} module Handler.Firm - ( getFirmAllR - , getFirmR, postFirmR + ( getFirmAllR , postFirmAllR + , getFirmR , postFirmR + , getFirmUsersR , postFirmUsersR + , getFirmSupersR, postFirmSupersR ) where @@ -24,11 +26,11 @@ import Handler.Utils -- import qualified Data.CaseInsensitive as CI -- import qualified Data.Conduit.List as C -- import Database.Persist.Sql (updateWhereCount) --- import Database.Esqueleto.Experimental ((:&)(..)) +import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma --- import qualified Database.Esqueleto.Legacy as E +-- import qualified Database.Esqueleto.Legacy as EL -- import qualified Database.Esqueleto.PostgreSQL as E --- import qualified Database.Esqueleto.Utils as E +import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH @@ -40,32 +42,58 @@ import Database.Esqueleto.Utils.TH getFirmR, postFirmR :: CompanyShorthand -> Handler Html getFirmR = postFirmR postFirmR fsh = do + let fshId = CompanyKey fsh cusers <- runDB $ do - cusers <- selectList [UserCompanyCompany ==. CompanyKey fsh] [] + cusers <- selectList [UserCompanyCompany ==. fshId] [] selectList [UserId <-. fmap (userCompanyUser . entityVal) cusers] [Asc UserDisplayName] csuper <- runDB $ do - csuper <- selectList [UserCompanyCompany ==. CompanyKey fsh, UserCompanySupervisor ==. True] [] + csuper <- selectList [UserCompanyCompany ==. fshId, UserCompanySupervisor ==. True] [] selectList [UserId <-. fmap (userCompanyUser . entityVal) csuper] [Asc UserDisplayName] - siteLayoutMsg MsgMenuFirms $ do - setTitleI MsgMenuFirms - [whamlet|STUB HANDLER FOR #{fsh} TO DO - -

      Supervisors (non-foreign only) + cactSuper <- runDB $ E.select $ do + (usr :& spr :& scmpy) <- E.from $ + E.table @User + `E.innerJoin` E.table @UserSupervisor + `E.on` (\(usr :& spr ) -> spr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId) + `E.leftJoin` E.table @UserCompany + `E.on` (\(_ :& spr :& scmpy) -> spr E.^. UserSupervisorSupervisor E.=?. scmpy E.?. UserCompanyUser) + E.where_ $ (spr E.^. UserSupervisorUser) `E.in_` E.valList (entityKey <$> cusers) + E.groupBy (usr E.^. UserId, usr E.^. UserDisplayName, usr E.^. UserSurname, scmpy E.?. UserCompanyCompany) + E.orderBy [E.asc $ usr E.^. UserId, E.asc $ usr E.^. UserDisplayName, E.asc $ usr E.^. UserSurname, E.asc $ scmpy E.?. UserCompanyCompany] + let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows + return (usr E.^. UserId, usr E.^. UserDisplayName, usr E.^. UserSurname, scmpy E.?. UserCompanyCompany, countRows') + + siteLayoutMsg (SomeMessage fsh) $ do + setTitle $ citext2Html fsh + [whamlet| +

      #{length csuper} Company Default Supervisors (non-foreign only)
        $forall u <- csuper -
      • ^{userWidget u} +
      • ^{linkUserWidget ForProfileDataR u} -

        Employees +

        #{length cactSuper} Active Supervisors for Employees +
          + $forall (E.Value _, E.Value dn, E.Value sn, E.Value mbCsh, E.Value nr) <- cactSuper +
        • #{nr} Employees supervised by ^{nameWidget dn sn} + $maybe csh <- mbCsh + $if csh /= fshId + from foreign company #{unCompanyKey csh} + $else + from this company + $nothing + having no associated company + +

          #{length cusers} Employees
            $forall u <- cusers -
          • ^{userWidget u} +
          • ^{linkUserWidget ForProfileDataR u} In the end, this needs to be a dbTable, of course! |] -getFirmAllR :: Handler Html -getFirmAllR = do +getFirmAllR, postFirmAllR :: Handler Html +getFirmAllR = postFirmAllR +postFirmAllR = do uid <- requireAuthId isAdmin <- hasReadAccessTo AdminR firmTable <- runDB $ do @@ -82,11 +110,11 @@ type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Word64 resultAllCompany :: Lens' AllCompanyTableData Company resultAllCompany = _dbrOutput . _1 . _entityVal -resultAllCompanySupervisors :: Lens' AllCompanyTableData Word64 -resultAllCompanySupervisors = _dbrOutput . _2 . _unValue - resultAllCompanyUsers :: Lens' AllCompanyTableData Word64 -resultAllCompanyUsers = _dbrOutput . _3 . _unValue +resultAllCompanyUsers = _dbrOutput . _2 . _unValue + +resultAllCompanySupervisors :: Lens' AllCompanyTableData Word64 +resultAllCompanySupervisors = _dbrOutput . _3 . _unValue resultAllCompanyForeignSupers :: Lens' AllCompanyTableData Word64 resultAllCompanyForeignSupers = _dbrOutput . _4 . _unValue @@ -102,13 +130,30 @@ firmCountUsers = E.subSelectCount . fromUserCompany Nothing firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) firmCountSupervisors = E.subSelectCount . fromUserCompany (Just (E.^. UserCompanySupervisor)) +-- firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +-- firmCountSupervisors cmpy = E.subSelectCount $ E.distinct $ do +-- usrCmpy <- E.from $ E.table @UserCompany +-- E.where_ $ (usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId) +-- E.&&. (usrCmpy E.^. UserCompanySupervisor E.==. E.true) +-- return $ usrCmpy E.^. UserCompanyUser + +-- firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +-- firmCountForeignSupervisors cmpy = E.coalesceDefault +-- [E.subSelect $ do +-- usrSuper <- E.from $ E.table @UserSupervisor +-- E.groupBy (usrSuper E.^. UserSupervisorSupervisor) +-- E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) +-- E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy) +-- return E.countRows +-- ] (E.val 0) firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -firmCountForeignSupervisors cmpy = E.subSelectCount $ E.distinct $ do - usrSuper <- E.from $ E.table @UserSupervisor - E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) - E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy) - return $ usrSuper E.^. UserSupervisorSupervisor +firmCountForeignSupervisors cmpy = E.subSelectCountDistinct $ do + usrSuper <- E.from $ E.table @UserSupervisor + E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) + E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy) + pure $ usrSuper E.^. UserSupervisorSupervisor + mkFirmAllTable :: Bool -> UserId -> DB (Any, Widget) mkFirmAllTable isAdmin uid = do @@ -121,8 +166,8 @@ mkFirmAllTable isAdmin uid = do usrCmpy <- E.from $ E.table @UserCompany E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId E.&&. usrCmpy E.^. UserCompanyUser E.==. E.val uid - return (cmpy, firmCountForeignSupervisors cmpy, firmCountUsers cmpy, firmCountSupervisors cmpy) - dbtRowKey = (E.^. CompanyShorthand) + return (cmpy, firmCountUsers cmpy, firmCountSupervisors cmpy, firmCountForeignSupervisors cmpy) + dbtRowKey = (E.^. CompanyId) dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat [ -- if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultAllCompany . _companyShorthand)) @@ -169,6 +214,23 @@ mkFirmAllTable isAdmin uid = do -- -- getQualificationEditR = postQualificationEditR -- -- postQualificationEditR = error "TODO" +getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html +getFirmUsersR = postFirmUsersR +postFirmUsersR fsh = do + let _fshId = CompanyKey fsh + siteLayout (citext2widget fsh) $ do + setTitle $ citext2Html fsh + [whamlet|!!!STUB!!!TO DO!!!|] + +getFirmSupersR, postFirmSupersR :: CompanyShorthand -> Handler Html +getFirmSupersR = postFirmSupersR +postFirmSupersR fsh = do + let _fshId = CompanyKey fsh + siteLayout (citext2widget fsh) $ do + setTitle $ citext2Html fsh + [whamlet|!!!STUB!!!TO DO!!!|] + + -- data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc.. -- { qtcDisplayName :: UserDisplayName -- , qtcEmail :: UserEmail diff --git a/src/Utils.hs b/src/Utils.hs index 28b7d88a8..e91f92015 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -364,6 +364,9 @@ text2asciiAlphaNum = Text.filter (\c -> Char.isAlphaNum c && Char.isAscii c) text2Html :: Text -> Html text2Html = toHtml +citext2Html :: CI Text -> Html +citext2Html = toHtml . CI.original + char2Text :: Char -> Text char2Text c | isSpace c = "" diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index ce98b437f..8bda1668b 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -569,7 +569,7 @@ fillDb = do userDisplayEmail' = CI.mk $ case userSurname of "Walker" -> "AVSNO:" <> userMatrikelnummer' "Clark" -> "E" <> userMatrikelnummer' <> "@fraport.de" - "Elizabeth" -> "" + "Jackson" -> "" _ -> userIdent matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int) @@ -636,7 +636,10 @@ fillDb = do void . insert' $ UserCompany fhamann bpol False False void . insert' $ UserCompany fhamann ffacil True True void . insert' $ UserCompany fhamann nice False False - insertMany_ [UserCompany uid fraGround False False| Entity uid User{userMatrikelnummer = fmap readMay -> Just (Just n)} <- matUsers] + insertMany_ [UserCompany uid fraGround False False| Entity uid User{userFirstName = "John"} <- matUsers] + insertMany_ [UserCompany uid bpol False False| Entity uid User{userFirstName = "Elizabeth"} <- matUsers] + insertMany_ [UserCompany uid bpol True True| Entity uid User{userFirstName = "Clark", userDisplayName = dn} <- matUsers, dn == "Walker" || dn == "John"] + insertMany_ [UserCompany uid ffacil False False| Entity uid User{userSurname = "Walker"} <- matUsers] -- void . insert' $ UserSupervisor jost gkleen True -- void . insert' $ UserSupervisor jost svaupel False -- void . insert' $ UserSupervisor jost sbarth False From 6d221fa3c2878da69c3eec61a4593152e42482a8 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 20 Oct 2023 16:44:55 +0000 Subject: [PATCH 59/59] chore(firm): add rerouting counts --- .../utils/table_column/de-de-formal.msg | 2 + messages/uniworx/utils/table_column/en-eu.msg | 2 + routes | 6 +- src/Database/Esqueleto/Utils.hs | 2 +- src/Foundation/Navigation.hs | 24 +++++++ src/Handler/Firm.hs | 64 +++++++++++++++---- src/Utils/Icon.hs | 2 + test/Database/Fill.hs | 11 +++- 8 files changed, 94 insertions(+), 19 deletions(-) diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index b25230af4..850cbb651 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -82,6 +82,8 @@ TableCompanyNos: Firmennummern TableCompanyNrUsers: Firmenangehörige TableCompanyNrSupers: Ansprechpartner TableCompanyNrForeignSupers: Firmenfremde Ansprechpartner +TableCompanyNrRerouteDefault: Standard Umleitungen +TableCompanyNrRerouteActive: Aktive Umleitungen TableSupervisor: Ansprechpartner TableCreationTime: Erstellungszeit TableJob !ident-ok: Job diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index e3d095d4f..5642ba22f 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -82,6 +82,8 @@ TableCompanyNos: Company numbers TableCompanyNrUsers: Associates TableCompanyNrSupers: Supervisors TableCompanyNrForeignSupers: External Supervisors +TableCompanyNrRerouteDefault: Default reroutes +TableCompanyNrRerouteActive: Active reroutes TableSupervisor: Supervisor TableCreationTime: Creation TableJob !ident-ok: Job diff --git a/routes b/routes index b4485c890..e6e4618b7 100644 --- a/routes +++ b/routes @@ -113,8 +113,10 @@ /for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self /for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self -/firm FirmAllR GET -/firm/#CompanyShorthand FirmR GET POST +/firm FirmAllR GET +/firm/#CompanyShorthand FirmR GET POST +/firm/#CompanyShorthand/users FirmUsersR GET POST +/firm/#CompanyShorthand/supers FirmSupersR GET POST /exam-office ExamOfficeR !exam-office: / EOExamsR GET POST !system-exam-office diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index af0fd0e76..f9a1dde82 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -628,7 +628,7 @@ unKey :: ( Coercible (Key entity) a => E.SqlExpr (E.Value (Key entity)) -> E.SqlExpr (E.Value a) unKey = E.veryUnsafeCoerceSqlExprValue - +-- | distinct version of `Database.Esqueleto.subSelectCount` subSelectCountDistinct :: (Num a, PersistField a) => Ex.SqlQuery (Ex.SqlExpr (Ex.Value typ)) -> Ex.SqlExpr (Ex.Value a) subSelectCountDistinct query = Ex.subSelectUnsafe (Ex.countDistinct <$> query) diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index a38b62b93..4c405b25f 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -125,6 +125,8 @@ breadcrumb ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing breadcrumb FirmR{} = i18nCrumb MsgMenuFirms $ Just FirmAllR +breadcrumb FirmUsersR{} = i18nCrumb MsgMenuFirms $ Just FirmAllR +breadcrumb FirmSupersR{} = i18nCrumb MsgMenuFirms $ Just FirmAllR breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR @@ -757,6 +759,18 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navForceActive = False } } + , return NavHeader + { navHeaderRole = NavHeaderPrimary + , navIcon = IconCompany + , navLink = NavLink + { navLabel = MsgMenuFirms + , navRoute = FirmAllR + , navAccess' = NavAccessTrue + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + } , return NavHeader { navHeaderRole = NavHeaderPrimary , navIcon = IconPrintCenter @@ -2401,6 +2415,16 @@ pageActions ApiDocsR = return , navChildren = [] } ] +pageActions (FirmR fsh) = return + [ NavPageActionPrimary + { navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh + , navChildren = [] + } + , NavPageActionPrimary + { navLink = defNavLink MsgTableCompanyNrUsers $ FirmUsersR fsh + , navChildren = [] + } + ] pageActions PrintCenterR = do openDays <- useRunDB $ Ex.select $ do pj <- Ex.from $ Ex.table @PrintJob diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index d711045a7..0af9b186c 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -106,18 +106,27 @@ postFirmAllR = do |] -type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64) -resultAllCompany :: Lens' AllCompanyTableData Company -resultAllCompany = _dbrOutput . _1 . _entityVal +type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64) +resultAllCompany :: Lens' AllCompanyTableData Company +resultAllCompany = _dbrOutput . _1 . _entityVal -resultAllCompanyUsers :: Lens' AllCompanyTableData Word64 -resultAllCompanyUsers = _dbrOutput . _2 . _unValue +resultAllCompanyUsers :: Lens' AllCompanyTableData Word64 +resultAllCompanyUsers = _dbrOutput . _2 . _unValue -resultAllCompanySupervisors :: Lens' AllCompanyTableData Word64 -resultAllCompanySupervisors = _dbrOutput . _3 . _unValue +resultAllCompanySupervisors :: Lens' AllCompanyTableData Word64 +resultAllCompanySupervisors = _dbrOutput . _3 . _unValue -resultAllCompanyForeignSupers :: Lens' AllCompanyTableData Word64 -resultAllCompanyForeignSupers = _dbrOutput . _4 . _unValue +resultAllCompanyForeignSupers :: Lens' AllCompanyTableData Word64 +resultAllCompanyForeignSupers = _dbrOutput . _4 . _unValue + +resultAllCompanyDefaultReroutes :: Lens' AllCompanyTableData Word64 +resultAllCompanyDefaultReroutes = _dbrOutput . _5 . _unValue + +resultAllCompanyActiveReroutes :: Lens' AllCompanyTableData Word64 +resultAllCompanyActiveReroutes = _dbrOutput . _6 . _unValue + +resultAllCompanyActiveReroutes' :: Lens' AllCompanyTableData Word64 +resultAllCompanyActiveReroutes' = _dbrOutput . _7 . _unValue fromUserCompany :: Maybe (E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Company) -> E.SqlQuery () fromUserCompany mbFltr cmpy = do @@ -137,6 +146,9 @@ firmCountSupervisors = E.subSelectCount . fromUserCompany (Just (E.^. UserCompa -- E.&&. (usrCmpy E.^. UserCompanySupervisor E.==. E.true) -- return $ usrCmpy E.^. UserCompanyUser +firmCountDefaultReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountDefaultReroutes = E.subSelectCount . fromUserCompany (Just (\uc -> uc E.^. UserCompanySupervisor E.&&. uc E.^. UserCompanySupervisorReroute)) + -- firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -- firmCountForeignSupervisors cmpy = E.coalesceDefault -- [E.subSelect $ do @@ -154,6 +166,19 @@ firmCountForeignSupervisors cmpy = E.subSelectCountDistinct $ do E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy) pure $ usrSuper E.^. UserSupervisorSupervisor +firmCountActiveReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountActiveReroutes cmpy = E.subSelectCountDistinct $ do + usrSuper <- E.from $ E.table @UserSupervisor + E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) + E.&&. usrSuper E.^. UserSupervisorRerouteNotifications + pure $ usrSuper E.^. UserSupervisorSupervisor + +firmCountActiveReroutes' :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountActiveReroutes' cmpy = E.subSelectCount $ do + usrSuper <- E.from $ E.table @UserSupervisor + E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) + E.&&. usrSuper E.^. UserSupervisorRerouteNotifications + mkFirmAllTable :: Bool -> UserId -> DB (Any, Widget) mkFirmAllTable isAdmin uid = do @@ -166,7 +191,14 @@ mkFirmAllTable isAdmin uid = do usrCmpy <- E.from $ E.table @UserCompany E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId E.&&. usrCmpy E.^. UserCompanyUser E.==. E.val uid - return (cmpy, firmCountUsers cmpy, firmCountSupervisors cmpy, firmCountForeignSupervisors cmpy) + return ( cmpy + , cmpy & firmCountUsers + , cmpy & firmCountSupervisors + , cmpy & firmCountForeignSupervisors + , cmpy & firmCountDefaultReroutes + , cmpy & firmCountActiveReroutes + , cmpy & firmCountActiveReroutes' + ) dbtRowKey = (E.^. CompanyId) dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat @@ -178,9 +210,12 @@ mkFirmAllTable isAdmin uid = do in anchorCell (FirmR fsh) $ toWgt fsh , sortable (Just "avsnr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> anchorCell (FirmR $ companyShorthand firm) $ toWgt $ companyAvsId firm - , sortable (Just "users") (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr - , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupers) $ \(view resultAllCompanySupervisors -> nr) -> wgtCell $ word2widget nr - , sortable (Just "foreigners") (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr + , sortable (Just "users") (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr + , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupers) $ \(view resultAllCompanySupervisors -> nr) -> wgtCell $ word2widget nr + , sortable (Just "reroute-def") (i18nCell MsgTableCompanyNrRerouteDefault) $ \(view resultAllCompanyDefaultReroutes -> nr) -> wgtCell $ word2widget nr + , sortable (Just "foreigners") (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr + , sortable (Just "reroute-act") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes -> nr) -> wgtCell $ word2widget nr + , sortable (Just "reroute-all") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes' -> nr) -> wgtCell $ word2widget nr ] dbtSorting = mconcat [ singletonMap "name" $ SortColumn (E.^. CompanyName) @@ -188,7 +223,10 @@ mkFirmAllTable isAdmin uid = do , singletonMap "avsnr" $ SortColumn (E.^. CompanyAvsId) , singletonMap "users" $ SortColumn firmCountUsers , singletonMap "supervisors" $ SortColumn firmCountSupervisors + , singletonMap "reroute-def" $ SortColumn firmCountDefaultReroutes , singletonMap "foreigners" $ SortColumn firmCountForeignSupervisors + , singletonMap "reroute-act" $ SortColumn firmCountActiveReroutes + , singletonMap "reroute-all" $ SortColumn firmCountActiveReroutes' ] dbtFilter = mconcat [ diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 2c8d9de6a..a3602faec 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -114,6 +114,7 @@ data Icon | IconLocked | IconUnlocked | IconResetTries -- also see IconReset + | IconCompany deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic) deriving anyclass (Universe, Finite, NFData) @@ -205,6 +206,7 @@ iconText = \case IconLocked -> "lock" IconUnlocked -> "lock-open-alt" IconResetTries -> "trash-undo" + IconCompany -> "building" nullaryPathPiece ''Icon $ camelToPathPiece' 1 deriveLift ''Icon diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 8bda1668b..7161397c7 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -636,9 +636,10 @@ fillDb = do void . insert' $ UserCompany fhamann bpol False False void . insert' $ UserCompany fhamann ffacil True True void . insert' $ UserCompany fhamann nice False False + -- need more tests insertMany_ [UserCompany uid fraGround False False| Entity uid User{userFirstName = "John"} <- matUsers] insertMany_ [UserCompany uid bpol False False| Entity uid User{userFirstName = "Elizabeth"} <- matUsers] - insertMany_ [UserCompany uid bpol True True| Entity uid User{userFirstName = "Clark", userDisplayName = dn} <- matUsers, dn == "Walker" || dn == "John"] + insertMany_ [UserCompany uid bpol True True| Entity uid User{userFirstName = "Clark", userSurname = dn} <- matUsers, dn == "Walker" || dn == "Robinson"] insertMany_ [UserCompany uid ffacil False False| Entity uid User{userSurname = "Walker"} <- matUsers] -- void . insert' $ UserSupervisor jost gkleen True -- void . insert' $ UserSupervisor jost svaupel False @@ -651,13 +652,17 @@ fillDb = do , UserSupervisor jost svaupel False , UserSupervisor jost sbarth False , UserSupervisor jost tinaTester True + , UserSupervisor jost jost True , UserSupervisor svaupel gkleen False , UserSupervisor svaupel fhamann True , UserSupervisor sbarth tinaTester True , UserSupervisor gkleen fhamann False + , UserSupervisor gkleen gkleen True + , UserSupervisor tinaTester tinaTester False ] - ++ take 333 [ UserSupervisor fhamann uid False | Entity uid _ <- matUsers ] - ++ take 111 [ UserSupervisor gkleen uid False | Entity uid _ <- drop 300 matUsers ] + ++ take 333 [ UserSupervisor fhamann uid True | Entity uid _ <- matUsers ] + ++ take 111 [ UserSupervisor gkleen uid True | Entity uid _ <- drop 300 matUsers ] + ++ take 11 [ UserSupervisor jost uid False | Entity uid _ <- drop 401 matUsers ] upsertManyWhere supvs [] [] [] -- upsertManyWhere supvs [] [] [] -- NOTE: multiple calls like this are ok -- insertMany_ supvs -- NOTE: multiple calls like this throw an error!