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 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/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 203bd9c17..5f8a15c73 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) @@ -82,24 +82,31 @@ 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. 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! 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 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..21445a418 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) @@ -82,24 +82,31 @@ 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. 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! 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. -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/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/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 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/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/Handler/LMS.hs b/src/Handler/LMS.hs index 3910e1309..ecfaca1ae 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 @@ -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,22 @@ 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 + { lmsActRestartExtend :: Maybe Integer + , lmsActRestartUnblock :: Maybe Bool + } 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) @@ -378,14 +385,14 @@ 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 (\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" + dbtIdent = "lms" dbtSQLQuery = lmsTableQuery qid dbtRowKey = queryUser >>> (E.^. UserId) dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, printAcks) -> do @@ -401,14 +408,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 +425,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 +435,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 +468,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 +545,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 +554,11 @@ postLmsR sid qsh = do [ singletonMap LmsActNotify $ pure LmsActNotifyData , singletonMap LmsActRenewNotify $ pure LmsActRenewNotifyData -- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData + , 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 @@ -556,7 +569,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 @@ -569,15 +582,16 @@ 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 & 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 + --, 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 +631,52 @@ 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 + 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 + 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,14 +693,18 @@ 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 +-- 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 c4b3d64e0..9d57be2b9 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 (\Entity{..} -> (entityKey, entityVal)) cmps let nowaday = utctDay now mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday @@ -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)) @@ -470,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 @@ -483,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 @@ -491,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 @@ -505,7 +507,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 @@ -517,11 +519,8 @@ 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 + $ \(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 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 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.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 () diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 79a3604b1..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 -- @@ -1667,8 +1674,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 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 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}
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