From 589617351f3c3297b590c0b38e91253a15c00e97 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 10 May 2023 15:17:36 +0000 Subject: [PATCH 01/11] chore: update mailmap for s.jost@frapor.de --- .mailmap | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.mailmap b/.mailmap index 2b49f4244..00bdc9684 100644 --- a/.mailmap +++ b/.mailmap @@ -2,7 +2,8 @@ Gregor Kleen Gregor Kleen Gregor Kleen Felix Hamann -Steffen Jost +Steffen Jost +Steffen Jost Sarah Vaupel Sarah Vaupel Sarah Vaupel <> Winnie Ros From 6339e71efd0d9617ce34e62882e02b0ae739d34e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 10 May 2023 15:18:16 +0000 Subject: [PATCH 02/11] chore(company): attempt to debug company column --- src/Handler/LMS.hs | 6 +++--- src/Handler/Qualification.hs | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 3910e1309..1626939cc 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -378,8 +378,8 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do now <- liftIO getCurrentTime -- lookup all companies cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do - cmps <- selectList [] [Asc CompanyId] - return $ Map.fromAscList $ fmap (\c -> (entityKey c, entityVal c)) cmps + cmps <- selectList [] [Asc CompanyShorthand] + return $ Map.fromList $ fmap (\c -> (entityKey c, entityVal c)) cmps let nowaday = utctDay now -- mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday @@ -556,7 +556,7 @@ postLmsR sid qsh = do let icnSuper = text2markup " " <> icon IconSupervisor cs = [ (cmpName, cmpSpr) | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps - , let cmpName = maybe cmpId companyName $ Map.lookup cmpId cmpMap + , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap ] companies = intercalate (text2markup ", ") $ (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index c4b3d64e0..df337047d 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -314,8 +314,8 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do now <- liftIO getCurrentTime -- lookup all companies cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do - cmps <- selectList [] [Asc CompanyId] - return $ Map.fromAscList $ fmap (\c -> (entityKey c, entityVal c)) cmps + cmps <- selectList [] [Asc CompanyShorthand] + return $ Map.fromList $ fmap (\c -> (entityKey c, entityVal c)) cmps let nowaday = utctDay now mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday @@ -505,7 +505,7 @@ postQualificationR sid qsh = do let icnSuper = text2markup " " <> icon IconSupervisor cs = [ (cmpName, cmpSpr) | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps - , let cmpName = maybe cmpId companyName $ Map.lookup cmpId cmpMap + , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap ] companies = intercalate (text2markup ", ") $ (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs From 54c91986698b64cb1e4efa27bc524193dcfb9b8e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 10 May 2023 15:18:58 +0000 Subject: [PATCH 03/11] chore(forms): revert apreq change and use areq directly for boolFields with defaults --- models/company.model | 2 +- src/Handler/Admin/Avs.hs | 2 +- src/Utils/Form.hs | 3 +-- 3 files changed, 3 insertions(+), 4 deletions(-) diff --git a/models/company.model b/models/company.model index 883aba0ff..5443b64b0 100644 --- a/models/company.model +++ b/models/company.model @@ -13,7 +13,7 @@ Company UniqueCompanyName name UniqueCompanyShorthand shorthand -- UniqueCompanyAvsId avsId -- should be the case, unclear if enforcing works here, since we cannot query avs by company id - Primary shorthand -- newtype Key Company = CompanyKey { unSchoolKey :: CompanyShorthand } + Primary shorthand -- newtype Key Company = CompanyKey { unCompanyKey :: CompanyShorthand } deriving Ord Eq Show Generic Binary -- TODO: a way to populate this table (manually) diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 62ac59f13..746a89a7f 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -605,7 +605,7 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do then singletonMap LicenceTableRevokeFDrive $ LicenceTableRevokeFDriveData <$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid <*> apreq textField (fslI MsgQualificationBlockReason) Nothing - <*> apreq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) + <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) else singletonMap LicenceTableGrantFDrive $ LicenceTableGrantFDriveData <$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 79a3604b1..669c6c440 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -1667,8 +1667,7 @@ mpreq :: (RenderMessage site (ValueRequired site), HandlerSite m ~ site, MonadHa -- ^ Pseudo required -- -- `FieldView` has `fvRequired` set to `True` and @FormSuccess Nothing@ is cast to `FormFailure`. --- Otherwise acts exactly like `mopt` without a default value and like `mreq` with a given default value -mpreq f fs mx@(Just _) = mreq f fs mx -- This shortcut hides the invalid no-answer option if a default is provided +-- Otherwise acts exactly like `mopt`. Note that a shortcut to mreq for isJust mx does create problems mit checkBoxField mpreq f fs@FieldSettings{..} mx = do mr <- getMessageRender (res, fv') <- mpreq' f fs $ Just <$> mx From b22ee4f601c3398e9aff1e210135462010e87eae Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 10 May 2023 15:49:42 +0000 Subject: [PATCH 04/11] chore(company): minor refactor --- src/Handler/LMS.hs | 6 +++--- src/Handler/Qualification.hs | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 1626939cc..4685994f0 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2023 Sarah Vaupel ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -378,8 +378,8 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do now <- liftIO getCurrentTime -- lookup all companies cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do - cmps <- selectList [] [Asc CompanyShorthand] - return $ Map.fromList $ fmap (\c -> (entityKey c, entityVal c)) cmps + cmps <- selectList [] [] -- [Asc CompanyShorthand] + return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps let nowaday = utctDay now -- mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index df337047d..0f4bac949 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -314,8 +314,8 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do now <- liftIO getCurrentTime -- lookup all companies cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do - cmps <- selectList [] [Asc CompanyShorthand] - return $ Map.fromList $ fmap (\c -> (entityKey c, entityVal c)) cmps + cmps <- selectList [] [] -- [Asc CompanyShorthand] + return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps let nowaday = utctDay now mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday From c1abe96fb2b08e2eab776959592fd790bd9caf2e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 11 May 2023 06:56:52 +0000 Subject: [PATCH 05/11] chore(renewal): add time estimate for e-learning --- templates/letter/fraport_renewal.md | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/templates/letter/fraport_renewal.md b/templates/letter/fraport_renewal.md index d7707d78a..be6d80117 100644 --- a/templates/letter/fraport_renewal.md +++ b/templates/letter/fraport_renewal.md @@ -72,6 +72,7 @@ $if(supervisor)$ $else$ Dazu bitte die Anmeldedaten aus dem geschützen Sichtfenster weiter unten verwenden. $endif$ +Die Durchführung des Lernprogramms und des Abschlusstests dauert etwa 2 bis 2,5 h. Fahrberechtigungsinhaber @@ -112,7 +113,8 @@ $if(supervisor)$ below confidentially to the examinee. $else$ Please use the login data from the protected area below. -$endif$ +$endif$ +Reserve 2--2.5h for the entire e-learning, including the exam. Examinee From 86c43f5115eb3f0f097a051356286b52baed8529 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 11 May 2023 16:17:11 +0000 Subject: [PATCH 06/11] chore(lms): fix #35 restart lms, link qualification entry to lms, rename lms pin to password --- .../categories/qualification/de-de-formal.msg | 21 +++-- .../categories/qualification/en-eu.msg | 23 ++--- routes | 2 + src/Foundation/Navigation.hs | 1 + src/Handler/LMS.hs | 83 ++++++++++++------- src/Handler/Qualification.hs | 5 -- src/Model/Types/Lms.hs | 2 +- src/Utils/Form.hs | 7 ++ templates/lms-user.hamlet | 5 +- 9 files changed, 92 insertions(+), 57 deletions(-) diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 203bd9c17..25b99e954 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -35,11 +35,11 @@ QualificationExpired: Ungültig seit LmsUser: Inhaber LmsURL: Link E‑Learning TableLmsEmail: E‑Mail -TableLmsIdent: LMS Identifikation +TableLmsIdent: E-Learnung Benutzer TableLmsElearning: E‑Learning -TableLmsPin: E‑Learning Pin -TableLmsResetPin: Pin zurücksetzen? -TableLmsDatePin: Pin erstellt +TableLmsPin: E‑Learning Passwort +TableLmsResetPin: E-Learning Passwort zurücksetzen? +TableLmsDatePin: E-Learning Passwort erstellt TableLmsDelete: Löschen? TableLmsStaff: Interner Mitarbeiter? TableLmsStarted: Begonnen @@ -61,8 +61,8 @@ FilterLmsValid: Aktuell gültig FilterLmsRenewal: Erneuerung anstehend FilterLmsNotified: Benachrichtigt CsvColumnLmsIdent: E‑Learning Identifikator, einzigartig pro Qualifikation und Teilnehmer -CsvColumnLmsPin: PIN des E#{nonBreakableDash}Learning Zugangs -CsvColumnLmsResetPin: Wird die PIN bei der nächsten Synchronisation zurückgesetzt? +CsvColumnLmsPin: Passwort E#{nonBreakableDash}Learning Zugang +CsvColumnLmsResetPin: Wird das E-Learning Passwort bei der nächsten Synchronisation zurückgesetzt? CsvColumnLmsDelete: Wird der Identifikator in der E‑Learning Plattform bei der nächsten Synchronisation gelöscht? CsvColumnLmsStaff: Handelt es sich um einen internen Mitarbeiter? (Aus historischen Gründen, wird momentan ignoriert.) CsvColumnLmsSuccess: Zeitstempel der erfolgreichen Teilnahme (UTC) @@ -95,11 +95,14 @@ QualificationStatusUnblock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} LmsRenewalInstructions: Weitere Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF mit dem im FRADrive hinterlegten PDF-Passwort des Prüflings verschlüsselt. Falls kein PDF-Passwort manuell hinterlegt wurde, ist das PDF-Passwort die Flughafen Ausweisnummer, inklusive Punkt und der Ziffer danach. LmsNoRenewal: Leider kann diese Qualifikation nicht alleine durch E‑Learning verlängert werden. LmsActNotify: Benachrichtigung E‑Learning erneut per Post oder E-Mail versenden -LmsActRenewPin: Neue zufällige E‑Learning PIN zuweisen -LmsActRenewNotify: Neue zufällige E‑Learning PIN zuweisen und Benachrichtigung per Post oder E-Mail versenden +LmsActRenewPin: Neues zufällige E‑Learning Passwort zuweisen +LmsActRenewNotify: Neue zufällige E‑Learning Passwort zuweisen und Benachrichtigung per Post oder E-Mail versenden +LmsActRestart: E-Learning neu starten +LmsActRestartWarning: Das vorhandene E-Learning wird sofort komplett gelöscht. Benutzer und Passwort werden neu vergeben und es wird eine neue Benachrichtigung versendet werden. +LmsActRestartFeedback n@Int m@Int: #{n}/#{m} E-Learning wurden neu gestartet. LmsStatusNotificationSent: Anmeldedaten wurden an Prüfling oder Ansprechpartner per Post oder E#{nonBreakableDash}Mail versendet; E#{nonBreakableDash}Learning ist derzeit offen LmsNotificationSend n@Int: E‑Learning Benachrichtigungen an #{n} #{pluralDE n "Prüfling" "Prüflinge"} werden per Post oder E-Mail versendet. -LmsPinRenewal n@Int: E‑Learning Pin ausgetauscht für #{n} #{pluralDE n "Prüfling" "Prüflinge"}. +LmsPinRenewal n@Int: E‑Learning Passwort ausgetauscht für #{n} #{pluralDE n "Prüfling" "Prüflinge"}. LmsActionFailed n@Int: Aktion nicht durchgeführt für #{n} #{pluralDE n "Person" "Personen"}, da diese derzeit nicht an einer Prüfung teilnehmen. LmsStarted: E‑Learning eröffnet LmsAutomaticQueuing n@Natural: Die folgenden Funktionen werden normalerweise einmal pro Tag um #{show n} Uhr ausgeführt. diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 3c2037be0..8e7eea4b5 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -35,11 +35,11 @@ QualificationExpired: Expired on LmsUser: Licensee LmsURL: Link E-learning TableLmsEmail: Email -TableLmsIdent: LMS Identifier -TableLmsPin: E‑learning pin +TableLmsIdent: E-learning user +TableLmsPin: E‑learning password TableLmsElearning: E‑learning -TableLmsResetPin: Reset pin? -TableLmsDatePin: Pin created +TableLmsResetPin: Reset E-learning password? +TableLmsDatePin: E-learning password created TableLmsDelete: Delete? TableLmsStaff: Staff? TableLmsStarted: Started @@ -61,8 +61,8 @@ FilterLmsValid: Currently valid FilterLmsRenewal: Renewal due FilterLmsNotified: Notified CsvColumnLmsIdent: E#{nonBreakableDash}learning identifier, unique for each qualification and user -CsvColumnLmsPin: PIN for e#{nonBreakableDash}learning access -CsvColumnLmsResetPin: Will the e#{nonBreakableDash}learning PIN be reset upon next synchronisation? +CsvColumnLmsPin: Password e#{nonBreakableDash}learning access +CsvColumnLmsResetPin: Will the e#{nonBreakableDash}learning password be reset upon next synchronisation? CsvColumnLmsDelete: Will the identifier be deleted from the E-learning platfrom upon next synchronisation? CsvColumnLmsStaff: Is the user an internal staff member? (Legacy, currently ignored) CsvColumnLmsSuccess: Timestamp of successful completion (UTC) @@ -95,11 +95,14 @@ QualificationStatusUnblock l n m: #{n}/#{m} #{l} reactivated LmsRenewalInstructions: Instruction on how to accomplish the renewal are enclosed in the attached PDF. In order to avoid misuse, the PDF is encrypted with the FRADrive PDF-password of the examinee. If no PDF-password had been chosen yet, then the password is the Fraport id card number of the examinee, including the punctuation mark and the digit thereafter. LmsNoRenewal: Unfortunately, this particular qualification cannot be renewed through E-learning only. LmsActNotify: Resend e‑learning notification by post or email -LmsActRenewPin: Randomly replace e‑learning PIN -LmsActRenewNotify: Randomly replace e‑learning PIN and re-send notification by post or email -LmsStatusNotificationSent: E-learning pin has been sent to examinee or supervisor by letter post or by email; e‑learning is currently open +LmsActRenewPin: Randomly replace e‑learning password +LmsActRenewNotify: Randomly replace e‑learning password and re-send notification by post or email +LmsActRestart: Restart e-learning +LmsActRestartWarning: The existing e-learning will be erased immediately. User and password will be generated anew and a notification will be queued as usual. +LmsActRestartFeedback n@Int m@Int: #{n}/#{m} e-learnings were restarted. +LmsStatusNotificationSent: E-learning password has been sent to examinee or supervisor by letter post or by email; e‑learning is currently open LmsNotificationSend n: E-learning notifications will be sent to #{n} #{pluralENs n "examinee"} by letter post or by email. -LmsPinRenewal n: E-learning pin replaced randomly for #{n} #{pluralENs n "examinee"}. +LmsPinRenewal n: E-learning password replaced randomly for #{n} #{pluralENs n "examinee"}. LmsActionFailed n: No action for #{n} #{pluralENs n "person"}, since there was no ongoing examination. LmsStarted: E-learning open since LmsAutomaticQueuing n@Natural: The following functions are executed daily at #{show n} o'clock. diff --git a/routes b/routes index e8067afcf..32721396e 100644 --- a/routes +++ b/routes @@ -279,9 +279,11 @@ /lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST /lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST !development /lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST !token -- LMS +/lms/#SchoolId/#QualificationShorthand/ident/#LmsIdent LmsIdentR GET -- redirect to LmsR with filter-parameter /lmsuser/#CryptoUUIDUser LmsUserR GET + /api ApiDocsR GET !free /swagger SwaggerR GET !free /swagger.json SwaggerJsonR GET !free diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index a4920014f..b889d5436 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -185,6 +185,7 @@ breadcrumb (LmsUserlistDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Jus breadcrumb (LmsResultR ssh qsh) = i18nCrumb MsgMenuLmsResult $ Just $ LmsR ssh qsh breadcrumb (LmsResultUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh breadcrumb (LmsResultDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh -- never displayed +breadcrumb (LmsIdentR ssh qsh _ ) = breadcrumb $ LmsR ssh qsh -- just a redirect breadcrumb (LmsUserR _) = i18nCrumb MsgMenuLmsUser $ Just LmsAllR -- breadcrumb (LmsFakeR ssh qsh) = i18nCrumb MsgMenuLmsFake $ Just $ LmsR ssh qsh -- TODO: remove in production diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 4685994f0..8cfda0043 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -10,6 +10,7 @@ module Handler.LMS ( getLmsAllR , postLmsAllR , getLmsSchoolR , getLmsR , postLmsR + , getLmsIdentR , getLmsEditR , postLmsEditR , getLmsUsersR , getLmsUsersDirectR , getLmsUserlistR , postLmsUserlistR @@ -41,6 +42,7 @@ 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.Persist.Sql (deleteWhereCount) import Handler.LMS.Users as Handler.LMS import Handler.LMS.Userlist as Handler.LMS @@ -316,6 +318,7 @@ instance HasUser LmsTableData where data LmsTableAction = LmsActNotify | LmsActRenewNotify | LmsActRenewPin + | LmsActRestart deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) instance Universe LmsTableAction @@ -326,18 +329,19 @@ embedRenderMessage ''UniWorX ''LmsTableAction id -- Not yet needed, since there is no additional data for now: data LmsTableActionData = LmsActNotifyData | LmsActRenewNotifyData - | LmsActRenewPinData -- no longer used + | LmsActRenewPinData -- no longer used + | LmsActRestartData deriving (Eq, Ord, Read, Show, Generic) isNotifyAct :: LmsTableActionData -> Bool isNotifyAct LmsActNotifyData = True isNotifyAct LmsActRenewNotifyData = True -isNotifyAct LmsActRenewPinData = False +isNotifyAct _ = False isRenewPinAct :: LmsTableActionData -> Bool -isRenewPinAct LmsActNotifyData = False isRenewPinAct LmsActRenewNotifyData = True isRenewPinAct LmsActRenewPinData = True +isRenewPinAct _ = False lmsTableQuery :: QualificationId -> LmsTableExpr -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) @@ -385,7 +389,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do -- mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) dbtIdent :: Text - dbtIdent = "qualification" + dbtIdent = "lms" dbtSQLQuery = lmsTableQuery qid dbtRowKey = queryUser >>> (E.^. UserId) dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, printAcks) -> do @@ -401,14 +405,14 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do , single ("first-held" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) , single ("blocked-due" , SortColumnNeverNull$ queryQualUser >>> (E.^. QualificationUserBlockedDue)) , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) - , single ("lms-ident" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserIdent)) - , single ("lms-pin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserPin)) - , single ("lms-status" , SortColumnNullsInv $ views (to queryLmsUser) (E.^. LmsUserStatus)) - , single ("lms-started" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserStarted)) - , single ("lms-datepin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserDatePin)) - , single ("lms-received" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserReceived)) - , single ("lms-notified" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserNotified)) -- cannot include printJob acknowledge date - , single ("lms-ended" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserEnded)) + , single ("ident" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserIdent)) + , single ("pin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserPin)) + , single ("status" , SortColumnNullsInv $ views (to queryLmsUser) (E.^. LmsUserStatus)) + , single ("started" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserStarted)) + , single ("datepin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserDatePin)) + , single ("received" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserReceived)) + , single ("notified" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserNotified)) -- cannot include printJob acknowledge date + , single ("ended" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserEnded)) , 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 @@ -418,8 +422,8 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do ] dbtFilter = mconcat [ single $ fltrUserNameEmail queryUser - , single ("lms-ident" , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsUser) (E.^. LmsUserIdent)) - -- , single ("lms-status" , FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) ((E.>=. E.val nowaday) . (E.^. LmsUserStatus))) -- LmsStatus cannot be filtered easily within the DB + , single ("ident" , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsUser) (E.^. LmsUserIdent)) + -- , single ("status" , FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) ((E.>=. E.val nowaday) . (E.^. LmsUserStatus))) -- LmsStatus cannot be filtered easily within the DB -- , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil))) , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday)) -- , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> @@ -428,7 +432,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do -- E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday -- | otherwise -> E.true -- ) - , single ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.^. LmsUserNotified))) + , single ("notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.^. LmsUserNotified))) , single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion -> E.from $ \usrAvs -> -- do E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId @@ -461,10 +465,10 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do , 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 "lms-ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) + , prismAForm (singletonFilter "ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) - , prismAForm (singletonFilter "lms-notified" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsNotified) - -- , prismAForm (singletonFilter "lms-status" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return (optionsPairs [(MsgTableLmsSuccess,"success"::Text),(MsgTableLmsFailed,"blocked")])) (fslI MsgTableLmsStatus) + , prismAForm (singletonFilter "notified" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsNotified) + -- , prismAForm (singletonFilter "status" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return (optionsPairs [(MsgTableLmsSuccess,"success"::Text),(MsgTableLmsFailed,"blocked")])) (fslI MsgTableLmsStatus) -- , if isNothing mbRenewal then mempty -- else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) ] @@ -538,7 +542,8 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html getLmsR = postLmsR postLmsR sid qsh = do - isAdmin <- hasReadAccessTo AdminR + isAdmin <- hasReadAccessTo AdminR + msgRestartWarning <- messageIconI Warning IconWarning MsgLmsActRestartWarning ((lmsRes, lmsTable), Entity qid quali) <- runDB $ do qent <- getBy404 $ SchoolQualificationShort sid qsh let acts :: Map LmsTableAction (AForm Handler LmsTableActionData) @@ -546,6 +551,8 @@ postLmsR sid qsh = do [ singletonMap LmsActNotify $ pure LmsActNotifyData , singletonMap LmsActRenewNotify $ pure LmsActRenewNotifyData -- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData + , singletonMap LmsActRestart $ LmsActRestartData <$ aformMessage msgRestartWarning + -- <*> aopt (commentField MsgQualificationActBlockSupervisor) (fslI MsgMessageWarning) Nothing ] -- lmsStatusLink = toMaybe isAdmin LmsUserR colChoices cmpMap = mconcat @@ -569,15 +576,15 @@ postLmsR sid qsh = do ) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> qualificationBlockedCell b , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification - , sortable (Just "lms-ident") (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> textCell lid - , sortable (Just "lms-pin") (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)] + , sortable (Just "ident") (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> textCell lid + , sortable (Just "pin") (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)] ) $ \(view $ resultLmsUser . _entityVal . _lmsUserPin -> pin) -> textCell pin - , sortable (Just "lms-status") (i18nCell MsgTableLmsStatus) $ \(view $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell status - , sortable (Just "lms-started") (i18nLms MsgTableLmsStarted) $ \(view $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> dateTimeCell d - , sortable (Just "lms-datepin") (i18nLms MsgTableLmsDatePin) $ \(view $ resultLmsUser . _entityVal . _lmsUserDatePin -> d) -> dateTimeCell d - , sortable (Just "lms-received") (i18nLms MsgTableLmsReceived) $ \(view $ resultLmsUser . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell d - --, sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified) $ \(view $ resultLmsUser . _entityVal . _lmsUserNotified -> d) -> foldMap dateTimeCell $ join d - , sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified & cellTooltip MsgTableLmsNotifiedTooltip) $ \row -> + , sortable (Just "status") (i18nCell MsgTableLmsStatus) $ \(view $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell status + , sortable (Just "started") (i18nLms MsgTableLmsStarted) $ \(view $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> dateTimeCell d + , sortable (Just "datepin") (i18nLms MsgTableLmsDatePin) $ \(view $ resultLmsUser . _entityVal . _lmsUserDatePin -> d) -> dateTimeCell d + , sortable (Just "received") (i18nLms MsgTableLmsReceived) $ \(view $ resultLmsUser . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell d + --, sortable (Just "notified") (i18nLms MsgTableLmsNotified) $ \(view $ resultLmsUser . _entityVal . _lmsUserNotified -> d) -> foldMap dateTimeCell $ join d + , sortable (Just "notified") (i18nLms MsgTableLmsNotified & cellTooltip MsgTableLmsNotifiedTooltip) $ \row -> -- 4 Cases: -- - No notification: LmsUserNotified == Nothing -- - Email sent : LmsUserNotified == Just _ && PrintJobId == Nothing @@ -617,19 +624,29 @@ postLmsR sid qsh = do in if notNotified then mempty else cIcon <> spacerCell <> cDate <> cAckDates - -- , sortable (Just "lms-notified-alternative") (i18nLms MsgTableLmsNotified) $ \(preview resultPrintAck -> d) -> textCell (show d) - , sortable (Just "lms-ended") (i18nLms MsgTableLmsEnded) $ \(view $ resultLmsUser . _entityVal . _lmsUserEnded -> d) -> foldMap dateTimeCell d + -- , sortable (Just "notified-alternative") (i18nLms MsgTableLmsNotified) $ \(preview resultPrintAck -> d) -> textCell (show d) + , sortable (Just "ended") (i18nLms MsgTableLmsEnded) $ \(view $ resultLmsUser . _entityVal . _lmsUserEnded -> d) -> foldMap dateTimeCell d ] where -- i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a i18nLms msg = cell [whamlet|LMS #|] <> i18nCell msg - psValidator = def & defaultSorting [SortDescBy "lms-started", SortDescBy "lms-status"] + psValidator = def & defaultSorting [SortDescBy "started", SortDescBy "status"] tbl <- mkLmsTable isAdmin qent acts colChoices psValidator return (tbl, qent) formResult lmsRes $ \case _ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page - (action, selectedUsers) -> do -- | isRenewPinAct action || isNotifyAct action -> do + + (LmsActRestartData, selectedUsers) -> do + delUsers <- runDB $ fromIntegral <$> deleteWhereCount [LmsUserQualification ==. qid, LmsUserUser <-. Set.toList selectedUsers] + runDBJobs $ forM_ selectedUsers $ \uid -> + queueDBJob $ JobLmsEnqueueUser { jQualification = qid, jUser = uid } + let numUsers = length selectedUsers + mStatus = bool Success Warning $ delUsers < numUsers + addMessageI mStatus $ MsgLmsActRestartFeedback delUsers numUsers + reloadKeepGetParams $ LmsR sid qsh + + (action, selectedUsers) | isRenewPinAct action || isNotifyAct action -> do now <- liftIO getCurrentTime numExaminees <- runDBJobs $ do okUsers <- selectList [LmsUserUser <-. Set.toList selectedUsers, LmsUserQualification ==. qid] [] @@ -646,12 +663,16 @@ postLmsR sid qsh = do when (isNotifyAct action) $ addMessageI Success $ MsgLmsNotificationSend numExaminees when (diffSelected /= 0) $ addMessageI Warning $ MsgLmsActionFailed diffSelected reloadKeepGetParams $ LmsR sid qsh + _ -> addMessageI Error MsgUnauthorized -- should not happen let heading = citext2widget $ "LMS " <> qualificationName quali siteLayout heading $ do setTitle $ toHtml $ "LMS " <> unSchoolKey sid <> "-" <> qsh $(widgetFile "lms") +-- redirect to a specific lms user +getLmsIdentR :: SchoolId -> QualificationShorthand -> LmsIdent -> Handler Html +getLmsIdentR sid qid ident = redirect (LmsR sid qid, [("lms-ident", toPathPiece ident)]) -- intended to be viewed primarily in a modal, wie lmsStatusPlusCell getLmsUserR :: CryptoUUIDUser -> Handler Html diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 0f4bac949..81373f37c 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -342,8 +342,6 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) , single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified)) , single ("blocked-due" , SortColumnNeverNull $ queryQualUser >>> (E.^. QualificationUserBlockedDue)) - -- , single ("lms-started" , SortColumn $ queryLmsUser >>> (E.?. LmsUserStarted)) - -- , single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus)) , 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)) @@ -517,9 +515,6 @@ postQualificationR sid qsh = do ) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> blockedDueCell b , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification - -- , sortable (Just "lms-started") (i18nCell MsgTableLmsElearning <> spacerCell <> i18nCell MsgTableLmsStarted) - -- $ \(preview $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> foldMap dateTimeCell d - -- , sortable (Just "lms-status") (i18nCell MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status , sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths)) $ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap (lmsStatusPlusCell linkLmsUser) lu , sortable (Just "last-notified") (i18nCell MsgTableQualificationLastNotified) $ \( view $ resultQualUser . _entityVal . _qualificationUserLastNotified -> d) -> dateTimeCell d diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index a9421a496..85483197b 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -22,7 +22,7 @@ import Utils.Lens.TH newtype LmsIdent = LmsIdent { getLmsIdent :: Text } deriving (Eq, Ord, Read, Show, Generic) - deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField) + deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField, Hashable) instance E.SqlString LmsIdent makeLenses_ ''LmsIdent diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 669c6c440..2d00d373e 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -108,6 +108,13 @@ noField = Field{..} fieldView _ _ _ _ _ = mempty fieldEnctype = UrlEncoded +-- | Field to inject comments into forms, also see aformMessage +commentField :: (Monad m, RenderMessage (HandlerSite m) a) => a -> Field m () +commentField msg = Field {..} + where + fieldParse _ _ = return $ Right $ Just () + fieldView _ _ _ _ _ = msg2widget msg + fieldEnctype = UrlEncoded -------------------- -- Field Settings -- diff --git a/templates/lms-user.hamlet b/templates/lms-user.hamlet index a09a25886..842013fc4 100644 --- a/templates/lms-user.hamlet +++ b/templates/lms-user.hamlet @@ -36,7 +36,10 @@ $else
_{MsgTableLmsStatus}
^{lmsUserStatusWidget True lmsUsr}
_{MsgTableLmsIdent} -
#{getLmsIdent (lmsUserIdent lmsUsr)} +
+ + + #{getLmsIdent (lmsUserIdent lmsUsr)}
_{MsgTableLmsPin}
From 0a0a6f6ad79ebbecc6489ea95eb9c3a12e581e14 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 12 May 2023 13:52:55 +0200 Subject: [PATCH 07/11] chore: fix build --- test/Model/TypesSpec.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 8a38486ff..9f5598b68 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -406,6 +406,7 @@ instance Arbitrary SheetAuthorshipStatementMode where instance Arbitrary LmsStatus where arbitrary = genericArbitrary +deriving newtype instance Arbitrary LmsIdent spec :: Spec spec = do From 490857331633f9790efdcdcaf1834adb704ca87e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 12 May 2023 12:36:11 +0000 Subject: [PATCH 08/11] chore(lms): restart e-learning allows unblocking and validity-extension --- .../categories/qualification/de-de-formal.msg | 12 ++++-- .../categories/qualification/en-eu.msg | 10 +++-- src/Handler/LMS.hs | 39 ++++++++++++++++--- src/Handler/Qualification.hs | 12 ++++-- src/Utils.hs | 1 + 5 files changed, 58 insertions(+), 16 deletions(-) diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 25b99e954..5f8a15c73 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -82,14 +82,16 @@ MailBodyQualificationRenewal qname@Text: Qualifikation #{qname} muss demnächst MailBodyQualificationExpiry: Diese Qualifikation läuft bald ab. Tätigkeiten, welche diese Qualifikation voraussetzen dürfen dann nicht länger ausgeübt werden! MailBodyQualificationExpired: Diese Qualifikation is nun abgelaufen. Tätigkeiten, welche diese Qualifikation voraussetzen dürfen ab sofort nicht länger ausgeübt werden! Es ist möglich, dass die Qualifikation vorzeit ungültig wurde, z.B. wegen erfolgloser Teilnahme an einem verpflichtendem E‑Learning. QualificationActExpire: Auslaufend markieren - keine Benachrichtigung zur Erneuerung senden -QualificationActUnexpire: Auslaufend aufheben - kostenpflichtige Benachrichtigung bei anstehender Erneuerung senden +QualificationActUnexpire: Auslaufend aufheben - zur Erneuerung benachrichtigen +QualificationActUnexpireWarning: Benachrichtigungen bei anstehender Erneuerung können kostenpflichtig sein! QualificationSetExpire n@Int64: Benachrichtigung bei anstehender Erneuerung und E‑Learning abgeschaltet für #{n} #{pluralDE n "Person" "Personen"} QualificationSetUnexpire n@Int64: Benachrichtigung bei anstehender Erneuerung und E‑Learning aktiviert für #{n} #{pluralDE n "Person" "Personen"} QualificationActBlockSupervisor: Dauerhaft entziehen und Ansprechpartner entfernen, mit sofortiger Wirkung QualificationActBlock: Entziehen -QualificationActUnblock: Entzug löschen -QualificationActGrant: Qualifikation vergeben +QualificationActUnblock: Entzug aufheben QualificationActRenew: Qualifikation regulär verlängern +QualificationActGrant: Qualifikation vergeben +QualificationActGrantWarning: Diese Funktion ist nur für seltene Ausnahmefälle vorgesehen! Ein Entzug wird ggf. aufgehoben. QualificationStatusBlock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} entzogen QualificationStatusUnblock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} reaktiviert LmsRenewalInstructions: Weitere Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF mit dem im FRADrive hinterlegten PDF-Passwort des Prüflings verschlüsselt. Falls kein PDF-Passwort manuell hinterlegt wurde, ist das PDF-Passwort die Flughafen Ausweisnummer, inklusive Punkt und der Ziffer danach. @@ -98,8 +100,10 @@ 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 LmsActRestart: E-Learning neu starten -LmsActRestartWarning: Das vorhandene E-Learning wird sofort komplett gelöscht. Benutzer und Passwort werden neu vergeben und es wird eine neue Benachrichtigung versendet werden. +LmsActRestartWarning: Das vorhandene E-Learning wird sofort komplett gelöscht! Für Inhaber einer gültigen Fahrlizenz werden später Benutzer und Passwort neu vergeben und es wird eine neue Benachrichtigung versendet werden. LmsActRestartFeedback n@Int m@Int: #{n}/#{m} E-Learning wurden neu gestartet. +LmsActRestartExtend: Gültig bis ggf. erhöhen für die nächsten # Tage +LmsActRestartUnblock: Entzug ggf. aufheben LmsStatusNotificationSent: Anmeldedaten wurden an Prüfling oder Ansprechpartner per Post oder E#{nonBreakableDash}Mail versendet; E#{nonBreakableDash}Learning ist derzeit offen LmsNotificationSend n@Int: E‑Learning Benachrichtigungen an #{n} #{pluralDE n "Prüfling" "Prüflinge"} werden per Post oder E-Mail versendet. LmsPinRenewal n@Int: E‑Learning Passwort ausgetauscht für #{n} #{pluralDE n "Prüfling" "Prüflinge"}. diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 8e7eea4b5..21445a418 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -82,14 +82,16 @@ MailBodyQualificationRenewal qname: The qualification #{qname} must be renewed s MailBodyQualificationExpiry: This qualification expires soon. You may then no longer execute any duties that require this qualification as a precondition! MailBodyQualificationExpired: This qualification is now expired. You may no longer execute any duties that require this qualification as a precondition! It is possible that the qualification expired prematurely, e.g. due to a failed compulsory e‑learning. QualificationActExpire: Discontinue - qualification expires silently -QualificationActUnexpire: Continue - send a possibly fee-paying notification upon due renewal +QualificationActUnexpire: Continue - notify for renwals +QualificationActUnexpireWarning: Renewal notification may incur a fee! QualificationSetExpire n: Expiry notification and e‑learning deactivated for #{n} #{pluralENs n "person"} QualificationSetUnexpire n: Expiry notification and e‑learning activated for #{n} #{pluralENs n "person"} QualificationActBlockSupervisor: Waive permanently and remove all supervisiors, effective immediately QualificationActBlock: Revoke QualificationActUnblock: Clear revocation -QualificationActGrant: Grant qualification QualificationActRenew: Renew qualification +QualificationActGrant: Grant qualification +QualificationActGrantWarning: Use with caution in rare exceptional cases only! Any revocation will be undone. QualificationStatusBlock l n m: #{n}/#{m} #{l} revoked QualificationStatusUnblock l n m: #{n}/#{m} #{l} reactivated LmsRenewalInstructions: Instruction on how to accomplish the renewal are enclosed in the attached PDF. In order to avoid misuse, the PDF is encrypted with the FRADrive PDF-password of the examinee. If no PDF-password had been chosen yet, then the password is the Fraport id card number of the examinee, including the punctuation mark and the digit thereafter. @@ -98,7 +100,9 @@ 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 LmsActRestart: Restart e-learning -LmsActRestartWarning: The existing e-learning will be erased immediately. User and password will be generated anew and a notification will be queued as usual. +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. +LmsActRestartExtend: Ensure validity for the next # days +LmsActRestartUnblock: Undo any revocations LmsActRestartFeedback n@Int m@Int: #{n}/#{m} e-learnings were restarted. LmsStatusNotificationSent: E-learning password has been sent to examinee or supervisor by letter post or by email; e‑learning is currently open LmsNotificationSend n: E-learning notifications will be sent to #{n} #{pluralENs n "examinee"} by letter post or by email. diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 8cfda0043..2fbb562bc 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -330,7 +330,10 @@ embedRenderMessage ''UniWorX ''LmsTableAction id data LmsTableActionData = LmsActNotifyData | LmsActRenewNotifyData | LmsActRenewPinData -- no longer used - | LmsActRestartData + | LmsActRestartData + { lmsActRestartExtend :: Maybe Integer + , lmsActRestartUnblock :: Maybe Bool + } deriving (Eq, Ord, Read, Show, Generic) isNotifyAct :: LmsTableActionData -> Bool @@ -551,8 +554,11 @@ postLmsR sid qsh = do [ singletonMap LmsActNotify $ pure LmsActNotifyData , singletonMap LmsActRenewNotify $ pure LmsActRenewNotifyData -- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData - , singletonMap LmsActRestart $ LmsActRestartData <$ aformMessage msgRestartWarning + , singletonMap LmsActRestart $ LmsActRestartData + <$> aopt intField (fslI MsgLmsActRestartExtend) Nothing + <*> aopt checkBoxField (fslI MsgLmsActRestartUnblock) Nothing -- <*> aopt (commentField MsgQualificationActBlockSupervisor) (fslI MsgMessageWarning) Nothing + <* aformMessage msgRestartWarning ] -- lmsStatusLink = toMaybe isAdmin LmsUserR colChoices cmpMap = mconcat @@ -637,13 +643,36 @@ postLmsR sid qsh = do formResult lmsRes $ \case _ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page - (LmsActRestartData, selectedUsers) -> do - delUsers <- runDB $ fromIntegral <$> deleteWhereCount [LmsUserQualification ==. qid, LmsUserUser <-. Set.toList selectedUsers] + (LmsActRestartData{..}, selectedUsers) -> do + let usersList = Set.toList selectedUsers + delUsers <- runDB $ do + when (lmsActRestartUnblock == Just True) $ do + unblockUsers <- view (_entityVal . _qualificationUserUser) <<$>> selectList + [ QualificationUserQualification ==. qid + , QualificationUserUser <-. usersList + , QualificationUserBlockedDue !=. Nothing + ] [] + void $ qualificationUserBlocking qid unblockUsers False Nothing + + whenIsJust lmsActRestartExtend $ \extDays -> do + now <- liftIO getCurrentTime + let nowaday = utctDay now + cutoff = addDays extDays nowaday + shortUsers <- view (_entityVal . _qualificationUserUser) <<$>> selectList + [ QualificationUserQualification ==. qid + , QualificationUserUser <-. usersList + , QualificationUserBlockedDue ==. Nothing + , QualificationUserValidUntil <. cutoff + ] [] + forM_ shortUsers $ upsertQualificationUser qid nowaday cutoff Nothing + + fromIntegral <$> deleteWhereCount [LmsUserQualification ==. qid, LmsUserUser <-. usersList] + runDBJobs $ forM_ selectedUsers $ \uid -> queueDBJob $ JobLmsEnqueueUser { jQualification = qid, jUser = uid } let numUsers = length selectedUsers mStatus = bool Success Warning $ delUsers < numUsers - addMessageI mStatus $ MsgLmsActRestartFeedback delUsers numUsers + addMessageI mStatus $ MsgLmsActRestartFeedback delUsers numUsers reloadKeepGetParams $ LmsR sid qsh (action, selectedUsers) | isRenewPinAct action || isNotifyAct action -> do diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 81373f37c..faa429ba9 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -468,7 +468,9 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html getQualificationR = postQualificationR postQualificationR sid qsh = do - isAdmin <- hasReadAccessTo AdminR + 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 @@ -481,7 +483,8 @@ postQualificationR sid qsh = do acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData) acts = mconcat $ [ singletonMap QualificationActExpire $ pure QualificationActExpireData - , singletonMap QualificationActUnexpire $ pure QualificationActUnexpireData + , singletonMap QualificationActUnexpire $ QualificationActUnexpireData + <$ aformMessage msgUnexpire ] ++ bool [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] -- nonAdmin actions, ie. Supervisor [ singletonMap QualificationActUnblock $ pure QualificationActUnblockData -- Admin-only actions @@ -489,8 +492,9 @@ postQualificationR sid qsh = do <$> apreq textField (fslI MsgQualificationBlockReason) Nothing <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) , singletonMap QualificationActRenew $ pure QualificationActRenewData - , singletonMap QualificationActGrant - (QualificationActGrantData <$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry) + , singletonMap QualificationActGrant $ QualificationActGrantData + <$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry + <* aformMessage msgGrantWarning ] isAdmin linkLmsUser = toMaybe isAdmin LmsUserR linkUserName = bool ForProfileR ForProfileDataR isAdmin diff --git a/src/Utils.hs b/src/Utils.hs index 0bafb212b..be7a78eef 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -870,6 +870,7 @@ deepAlt altFst _ = altFst maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m maybeEmpty = flip foldMap +-- | also referred to as whenJust whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenIsJust (Just x) f = f x whenIsJust Nothing _ = return () From 637af129927c1f1e5205dc653dded6bebf4e04ca Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 12 May 2023 19:00:26 +0000 Subject: [PATCH 09/11] chore(release): 27.4.3 --- CHANGELOG.md | 2 ++ nix/docker/demo-version.json | 2 +- nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 6 files changed, 7 insertions(+), 5 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index c3980043a..4cf21ae61 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.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.2...v27.4.3) (2023-05-12) + ## [27.4.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.1...v27.4.2) (2023-05-09) ## [27.4.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.0...v27.4.1) (2023-05-08) diff --git a/nix/docker/demo-version.json b/nix/docker/demo-version.json index 19d6b4864..45e18a925 100644 --- a/nix/docker/demo-version.json +++ b/nix/docker/demo-version.json @@ -1,3 +1,3 @@ { - "version": "27.4.2" + "version": "27.4.3" } diff --git a/nix/docker/version.json b/nix/docker/version.json index 19d6b4864..45e18a925 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.2" + "version": "27.4.3" } diff --git a/package-lock.json b/package-lock.json index 22e34611b..7a9e83a50 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.2", + "version": "27.4.3", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index b92667371..5a575e6a3 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.2", + "version": "27.4.3", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 8fe11bb93..098c9524b 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.2 +version: 27.4.3 dependencies: - base - yesod From e4908bc4fcb6212eda2b85dd5d771491df9e0fd0 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 15 May 2023 07:51:09 +0000 Subject: [PATCH 10/11] chore(lms): allow late qualification renewal by lms success --- src/Jobs/Handler/LMS.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 2e2a95a51..1795167c0 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -231,19 +231,19 @@ dispatchJobLmsResults qid = JobHandlerAtomic act -- three separate DB operations per result is not so nice. All within one transaction though. let lmsUserStartedDay = localDay $ TZ.utcToLocalTimeTZ appTZ lmsUserStarted saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil locDay) - && qualificationUserLastRefresh <= utctDay lmsUserStarted + -- && qualificationUserLastRefresh <= utctDay lmsUserStarted NOTE: not always true due to manual intervention; also renewValidQualificationUsers prevents double renewals anyway newStatus = Just $ LmsSuccess lmsResultSuccess -- newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards note <- if saneDate && replaceLmsStatus lmsUserStatus newStatus then do - _ok <- renewValidQualificationUsers qid [qualificationUserUser] -- ignores possible blocks - -- when (ok==1) $ update luid -- we end lms regardless of wether a regular renewal was successful, since BPol users may simultaneoysly have on-premise renewal courses and E-Learnings - -- WORKAROUND LMS-Bug [supposedly fixed now, but isnt]: sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning -- _ok <- qualificationUserUnblockByReason qid [qualificationUserUser] (qualificationBlockedReasonText QualificationBlockFailedELearning) -- affects audit log when (Just (qualificationBlockedReasonText QualificationBlockFailedELearning) == qualificationUserBlockedDue ^? _Just . _qualificationBlockedReason) $ update quid [ QualificationUserBlockedDue =. Nothing ] + _ok <- renewValidQualificationUsers qid [qualificationUserUser] -- ignores possible blocks + -- when (ok==1) $ update luid -- we end lms regardless of whether or not a regular renewal was successful, since BPol users may simultaneoysly have on-premise renewal courses and E-Learnings + update luid [ LmsUserStatus =. newStatus , LmsUserReceived =. Just lmsResultTimestamp From 231cc00fe9856ce4d3975614513c14ec00db519c Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 15 May 2023 07:51:41 +0000 Subject: [PATCH 11/11] chore(lms): consistent lms status cells all tables --- src/Handler/LMS.hs | 5 +++-- src/Handler/Qualification.hs | 2 +- src/Handler/Utils/Table/Cells.hs | 17 +++++------------ 3 files changed, 9 insertions(+), 15 deletions(-) diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 2fbb562bc..ecfaca1ae 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -585,7 +585,8 @@ postLmsR sid qsh = do , sortable (Just "ident") (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> textCell lid , sortable (Just "pin") (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)] ) $ \(view $ resultLmsUser . _entityVal . _lmsUserPin -> pin) -> textCell pin - , sortable (Just "status") (i18nCell MsgTableLmsStatus) $ \(view $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell status + , sortable (Just "status") (i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin $ qent ^. _entityVal . _qualificationAuditDuration)) + $ \(view $ resultLmsUser . _entityVal -> lmsUserVal) -> lmsStatusCell isAdmin Nothing lmsUserVal , sortable (Just "started") (i18nLms MsgTableLmsStarted) $ \(view $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> dateTimeCell d , sortable (Just "datepin") (i18nLms MsgTableLmsDatePin) $ \(view $ resultLmsUser . _entityVal . _lmsUserDatePin -> d) -> dateTimeCell d , sortable (Just "received") (i18nLms MsgTableLmsReceived) $ \(view $ resultLmsUser . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell d @@ -703,7 +704,7 @@ postLmsR sid qsh = do getLmsIdentR :: SchoolId -> QualificationShorthand -> LmsIdent -> Handler Html getLmsIdentR sid qid ident = redirect (LmsR sid qid, [("lms-ident", toPathPiece ident)]) --- intended to be viewed primarily in a modal, wie lmsStatusPlusCell +-- intended to be viewed primarily in a modal, wie lmsStatusCell getLmsUserR :: CryptoUUIDUser -> Handler Html getLmsUserR uuid = do uid <- decrypt uuid diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index faa429ba9..9d57be2b9 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -520,7 +520,7 @@ postQualificationR sid qsh = do , 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 (lmsStatusPlusCell linkLmsUser) lu + $ \(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"] diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index c4fb8ea02..f45b07508 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -13,7 +13,7 @@ import Handler.Utils.Table.Pagination import Handler.Utils.DateTime import Handler.Utils.Widgets import Handler.Utils.Occurrences -import Handler.Utils.LMS (lmsUserStatusWidget, lmsStatusIcon) +import Handler.Utils.LMS (lmsUserStatusWidget) type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with WithHoles ! @@ -364,18 +364,11 @@ roomReferenceCell = cell . roomReferenceWidget cryptoidCell :: (IsDBTable m a, PathPiece cid) => cid -> DBCell m a cryptoidCell = addCellClass ("cryptoid" :: Text) . textCell . toPathPiece -lmsStatusCell :: IsDBTable m a => LmsStatus -> DBCell m a -lmsStatusCell ls = iconCell (lmsStatusIcon ls) <> spacerCell <> dayCell (lmsStatusDay ls) - --- lmsStatusPlusCell :: IsDBTable m a => LmsUser -> DBCell m a --- lmsStatusPlusCell LmsUser{lmsUserStatus=Just lStat} = lmsStatusCell lStat --- lmsStatusPlusCell LmsUser{lmsUserStarted} = iconCell IconWaitingForUser <> spacerCell <> dateCell lmsUserStarted - -lmsStatusPlusCell :: IsDBTable m a => Maybe (CryptoUUIDUser -> Route UniWorX) -> LmsUser -> DBCell m a -lmsStatusPlusCell Nothing lu = wgtCell $ lmsUserStatusWidget False lu -lmsStatusPlusCell (Just toLink) lu = cell $ do +lmsStatusCell :: IsDBTable m a => Bool -> Maybe (CryptoUUIDUser -> Route UniWorX) -> LmsUser -> DBCell m a +lmsStatusCell extendedInfo Nothing lu = wgtCell $ lmsUserStatusWidget extendedInfo lu +lmsStatusCell extendedInfo (Just toLink) lu = cell $ do uuid <- liftHandler $ encrypt $ lu ^. _lmsUserUser - modal (lmsUserStatusWidget True lu) (Left $ SomeRoute $ toLink uuid) + modal (lmsUserStatusWidget extendedInfo lu) (Left $ SomeRoute $ toLink uuid) qualificationBlockedCellNoReason :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a qualificationBlockedCellNoReason Nothing = mempty