diff --git a/config/settings.yml b/config/settings.yml index 582f6e640..d5d64e7c5 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt +# SPDX-FileCopyrightText: 2022-2025 Sarah Vaupel , Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt ,Steffen Jost # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -146,12 +146,14 @@ ldap: ldap-re-test-failover: 60 lms-direct: - upload-header: "_env:LMSUPLOADHEADER:true" - upload-delimiter: "_env:LMSUPLOADDELIMITER:" - download-header: "_env:LMSDOWNLOADHEADER:true" - download-delimiter: "_env:LMSDOWNLOADDELIMITER:," - download-cr-lf: "_env:LMSDOWNLOADCRLF:true" - deletion-days: "_env:LMSDELETIONDAYS:7" + upload-header: "_env:LMSUPLOADHEADER:true" + upload-delimiter: "_env:LMSUPLOADDELIMITER:" + download-header: "_env:LMSDOWNLOADHEADER:true" + download-delimiter: "_env:LMSDOWNLOADDELIMITER:," + download-cr-lf: "_env:LMSDOWNLOADCRLF:true" + orphan-deletion-days: "_env:LMSORPHANDELETIONDAYS:33" + orphan-deletion-batch: "_env:LMSORPHANDELETIONBATCH:12" + orphan-deletion-repeat-hours: "_env:LMSORPHANDELETIONREPEATHOURS:24" avs: host: "_env:AVSHOST:skytest.fra.fraport.de" diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index e0781c09d..6374ae394 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -8,9 +8,8 @@ QualificationDescription: Beschreibung QualificationValidIndicator: Gültigkeit QualificationValidDuration: Gültigkeitsdauer QualificationAuditDuration: Aufbewahrungszeitraum E‑Learning Log -QualificationAuditDurationTooltip n@Int: Optionaler Zeitraum zur Löschung von E‑Learning Daten. Hinweis: Der E‑Learning Server kann seine anonymisierten Daten schon früher löschen, aber spätestens #{n} Tage nach Abschluss. -QualificationAuditDurationReuseNoTime: Diese Qualifikation nutzt das E‑Learning einer anderen Qualifikation, für die derzeit keinen Löschzeitraum konfiguriert wurde. -QualificationAuditDurationReuseError: Fehler: Aufbewahrungszeitraum E‑Learning Log kann nicht individuell konfiguriert werden, wenn das E‑Learning einer anderen Qualifikation mitbenutzt wird. +QualificationAuditDurationTooltip: Anzahl Tage zur Löschung von E‑Learning Daten. Hinweis: Der E‑Learning Server kann seine anonymisierten Daten schon früher löschen. +QualificationAuditDurationReuseInfo: Aufbewahrungszeitraum E‑Learning Log wird ignoriert, da das E‑Learning einer anderen Qualifikation mitbenutzt wird. QualificationRefreshWithin: Erneurerungszeitraum QualificationRefreshWithinTooltip: Optionaler Zeitraum vor Ablauf für eine Benachrichtigung per Email. Bei aktiviertem automatischem E‑Learning wird dieses gestartet und die Benachrichtigung erfolgt per Brief oder Email. QualificationRefreshReminder: Zweite Erinnerung @@ -74,7 +73,7 @@ TableLmsNotified: Versand Benachrichtigung TableLmsNotifiedTooltip: Benachrichtigungen werden erst versendet wenn das LMS bestätigt die Eröffnung des E‑Learning für den Benutzer bestätigt hat, was ein paar Stunden dauern kann! TableLmsEnded: Beendet TableLmsStatus: Status E‑Learning -TableLmsStatusTooltip mbMonth@(Maybe Int): Zeigt #{maybeToMessage "bis zu " (fmap (flip pluralDEeN "Monat") mbMonth) " nach Abschluss"} den letzten Zustand eines E‑Learnings an: +TableLmsStatusTooltip n@Int: Zeigt bis zu #{pluralDEeN n "Tag"} nach Abschluss den letzten Zustand eines E‑Learnings an: TableLmsStatusDay: Datum letzte Statusänderung E‑Learning TableLmsSuccess: Bestanden TableLmsLock: Gesperrt diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 821d5fee7..6da4d3df2 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -8,9 +8,8 @@ QualificationDescription: Description QualificationValidIndicator: Validity QualificationValidDuration: Validity period QualificationAuditDuration: Audit log retention period -QualificationAuditDurationTooltip n@Int: Optional period for deletion of e‑learning data. Note that the e‑learning server may delete its anonymised data earlier, at most #{n} days after closing. -QualificationAuditDurationReuseNoTime: This qualification reuses the e‑learning from another qualification, which has no audit duration configured. -QualificationAuditDurationReuseError: Error: Audit log retention period may not be configure when reusing the e‑learning from another qualification. +QualificationAuditDurationTooltip: Days for deletion of e‑learning data. Note that the e‑learning server may delete its anonymised data earlier. +QualificationAuditDurationReuseInfo: E‑learning audit log retention period ignore, since the e‑learning from another qualification is reused. QualificationRefreshWithin: Refresh within QualificationRefreshWithinTooltip: Optional period before expiry to send a notification by email. If e‑learning is set to start automatically, it will be started and e‑learning credentials are send with this notification by post or email. QualificationRefreshReminder: Second reminder @@ -74,7 +73,7 @@ TableLmsNotified: Notification sent TableLmsNotifiedTooltip: Notfications are not sent before the LMS acknowledges the opening of the e‑learning course category for the user, which may take several hours! TableLmsEnded: Ended TableLmsStatus: Status e‑learning -TableLmsStatusTooltip mbMonth: Shows #{maybeToMessage "for up to " (fmap (flip pluralENsN "month") mbMonth) " after closure"} the last e#{nonBreakableDash}learning status change: +TableLmsStatusTooltip n: Shows for up to #{pluralENsN n "day"} after closure the last e#{nonBreakableDash}learning status change: TableLmsStatusDay: Date of last e‑learning status change TableLmsSuccess: Completed TableLmsLock: Locked diff --git a/models/lms.model b/models/lms.model index 20811ea22..06a614e27 100644 --- a/models/lms.model +++ b/models/lms.model @@ -9,7 +9,7 @@ Qualification name (CI Text) -- 3 description StoredMarkup Maybe -- 4 user-defined large Html, ought to contain full description validDuration Int Maybe -- 5 if > 0, qualification is valid indefinitely or for a specified number of months, use with addMonthsDay - auditDuration Int Maybe -- 6 if > 0, number of months to keep audit log and LmsUserIdents; or indefinitely (dangerous, since LmsIdents may run out) + auditDuration Int default=366 -- 6 number of days to keep LMS audit log and LmsUserIdents -- TODO: audit period for QualificationUser/Block as well refreshWithin CalendarDiffDays Maybe -- 7 notify users about renewal within this number of month/days before expiry; to be used with addGregorianDurationClip refreshReminder CalendarDiffDays Maybe -- 8 send a second notification about renewal within this number of month/days before expiry elearningStart Bool -- 9 automatically schedule e-refresher @@ -170,6 +170,7 @@ LmsOrphan qualification QualificationId OnDeleteCascade OnUpdateCascade ident LmsIdent -- must be unique accross all LMS courses! seenFirst UTCTime default=now() -- first time reported by LMS - seenLast UTCTime default=now() -- last acknowledgement by LMS, deletion uses QualificationAuditDuration + seenLast UTCTime default=now() -- last acknowledgement by LMS, deletion uses QualificationAuditDuration + deletedLast UTCTime Maybe -- last deletion request sent to LMS UniqueLmsOrphan qualification ident -- unlike other tables, LMS Idents must only be unique within qualification, allowing orphans to be handled independently deriving Generic Show \ No newline at end of file diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 968153879..ee9c165a1 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -91,9 +91,9 @@ postLmsAllR = do , formSubmit = FormNoSubmit } - LmsConf{lmsDeletionDays} <- getsYesod $ view _appLmsConf + lmsTable <- runDB $ do - view _2 <$> mkLmsAllTable isAdmin lmsDeletionDays + view _2 <$> mkLmsAllTable isAdmin siteLayoutMsg MsgMenuLms $ do setTitleI MsgMenuLms $(i18nWidgetFile "lms-all") @@ -112,9 +112,9 @@ resultAllQualificationOrphans :: Lens' AllQualificationTableData Word64 resultAllQualificationOrphans = _dbrOutput . _4 . _unValue -mkLmsAllTable :: Bool -> Int -> DB (Any, Widget) -mkLmsAllTable isAdmin lmsDeletionDays = do - svs <- getSupervisees +mkLmsAllTable :: Bool -> DB (Any, Widget) +mkLmsAllTable isAdmin = do + svs <- getSupervisees True let resultDBTable = DBTable{..} where @@ -157,8 +157,8 @@ mkLmsAllTable isAdmin lmsDeletionDays = do in tickmarkCell $ elearnstart && isJust reminder , sortable Nothing (i18nCell MsgQualificationRefreshReminder & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $ foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder) - , sortable Nothing (i18nCell MsgQualificationAuditDuration & cellTooltips [SomeMessage (MsgQualificationAuditDurationTooltip lmsDeletionDays), SomeMessage MsgTableDiffDaysTooltip]) $ - foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationAuditDuration) + , sortable Nothing (i18nCell MsgQualificationAuditDuration & cellTooltips [SomeMessage MsgQualificationAuditDurationTooltip, SomeMessage MsgTableDiffDaysTooltip]) $ + (textCell . formatCalendarDiffDays . fromDays ) . view (resultAllQualification . _qualificationAuditDuration) , sortable (Just "qel-renew") (i18nCell MsgTableLmsElearningRenews & cellTooltip MsgQualificationElearningRenew) $ tickmarkCell . view (resultAllQualification . _qualificationElearningRenews) , sortable (Just "qel-limit") (i18nCell MsgTableLmsElearningLimit & cellTooltip MsgQualificationElearningLimitExplain) @@ -774,7 +774,6 @@ postLmsR sid qsh = do let heading = citext2widget $ "LMS " <> qualificationName quali siteLayout heading $ do setTitle $ toHtml $ "LMS " <> unSchoolKey sid <> "-" <> qsh - LmsConf{lmsDeletionDays} <- getsYesod $ view _appLmsConf $(widgetFile "lms") -- redirect to a specific lms user diff --git a/src/Handler/LMS/Fake.hs b/src/Handler/LMS/Fake.hs index d1b876db6..4383f6e00 100644 --- a/src/Handler/LMS/Fake.hs +++ b/src/Handler/LMS/Fake.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost +-- SPDX-FileCopyrightText: 2022-25 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -22,7 +22,7 @@ import Control.Applicative (ZipList(..), getZipList) getLmsFakeR, postLmsFakeR :: SchoolId -> QualificationShorthand -> Handler Html getLmsFakeR = postLmsFakeR -postLmsFakeR sid qsh = do +postLmsFakeR sid qsh = do qent <- runDB $ getBy404 $ SchoolQualificationShort sid qsh now <- liftIO getCurrentTime let qName :: Text = CI.original $ unSchoolKey sid <> "-" <> qsh @@ -39,13 +39,13 @@ postLmsFakeR sid qsh = do setTitle $ toHtml $ "Testnutzer generieren " <> qName toWidget [whamlet| Hier können zufällige Testbenutzer mit ablaufenden Qualifikationen generiert werden, - welche dann im angegebenen Zeitraum fällig werden. + welche dann im angegebenen Zeitraum fällig werden. ^{fakeForm} -

Hinweise: +

Hinweise:
    -
  • Emails der generierten Teilnehmer enden auf @example.com +
  • Emails der generierten Teilnehmer enden auf @example.com und die Matrikelnummer lautet TESTUSER.
  • Bereits vorhandene Teilnehmer mit gleicher Ident werden nicht neu generiert.
  • Vorhandene Qualifikationen solcher Teilnehmer werden einfach überschrieben. @@ -69,8 +69,8 @@ fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (u pwHash <- liftIO $ PWStore.makePasswordWith pwHashAlgorithm pw pwHashStrength return $ AuthPWHash $ TEnc.decodeUtf8 pwHash theSupervisor <- selectKeysList [UserSurname ==. "Jost", UserFirstName ==. "Steffen"] [Asc UserCreated, LimitTo 1] - let addSupervisor = case theSupervisor of - [s] -> \suid k -> case k of + let addSupervisor = case theSupervisor of + [s] -> \suid k -> case k of 1 -> void $ insertBy $ UserSupervisor s suid True Nothing Nothing 2 -> do void $ insertBy $ UserSupervisor s suid True Nothing (Just "Test") @@ -122,16 +122,16 @@ fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (u if | (Left (Entity _ User{userMatrikelnummer})) <- euid , userMatrikelnummer /= Just "TESTUSER" -> return 0 - | otherwise -> do + | otherwise -> do let uid = either entityKey id euid qualificationUserUser = uid qualificationUserQualification = qid qualificationUserValidUntil = addDays expOffset expiryNotifyDay - qualificationUserFirstHeld = addGregorianMonthsClip (-24) qualificationUserValidUntil - qualificationUserLastRefresh = qualificationUserFirstHeld + qualificationUserFirstHeld = computeNewValidDate (-24) qualificationUserValidUntil + qualificationUserLastRefresh = qualificationUserFirstHeld qualificationUserScheduleRenewal = True qualificationUserLastNotified = now - _ <- upsert QualificationUser{..} + _ <- upsert QualificationUser{..} [ QualificationUserValidUntil =. qualificationUserValidUntil , QualificationUserLastRefresh =. qualificationUserLastRefresh ] diff --git a/src/Handler/LMS/Learners.hs b/src/Handler/LMS/Learners.hs index 0ec864144..2dbfe33b9 100644 --- a/src/Handler/LMS/Learners.hs +++ b/src/Handler/LMS/Learners.hs @@ -21,7 +21,7 @@ import qualified Data.Map as Map import qualified Data.Csv as Csv import qualified Data.Text as Text import qualified Data.Conduit.List as C --- import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma +import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E @@ -168,7 +168,8 @@ mkUserTable _sid qsh qid cutoff = do getQidCutoff :: SchoolId -> QualificationShorthand -> DB (QualificationId, UTCTime) getQidCutoff sid qsh = do Entity{entityKey = qid, entityVal = Qualification{qualificationAuditDuration=auditDur}} <- getBy404 $ SchoolQualificationShort sid qsh - cutoff <- liftHandler $ lmsDeletionDate auditDur + now <- liftIO getCurrentTime + let cutoff = lmsDeletionDate now auditDur return (qid, cutoff) getLmsLearnersR :: SchoolId -> QualificationShorthand -> Handler Html @@ -185,7 +186,13 @@ getLmsLearnersR sid qsh = do getLmsLearnersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent getLmsLearnersDirectR sid qsh = do - $logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid + -- $logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid + lmsConf <- getsYesod $ view _appLmsConf + now <- liftIO getCurrentTime + let cutoff_seen_first = addLocalDays (negate $ lmsConf ^. _lmsOrphanDeletionDays) now + cutoff_deleted_last = addHours (negate $ lmsConf ^. _lmsOrphanRepeatHours) now + cutoff_seen_last = cutoff_deleted_last + orphan_max_batch = lmsConf ^. _lmsOrphanDeletionBatch (lms_users, orphans, cutoff, qshs) <- runDB $ do (qid, cutoff) <- getQidCutoff sid qsh qidsReuse <- selectList [QualificationLmsReuses ==. Just qid] [] @@ -208,8 +215,20 @@ getLmsLearnersDirectR sid qsh = do , csvLUTstaff = LmsBool False } -} - now <- liftIO getCurrentTime - orphans <- selectList [LmsOrphanQualification ==. qid, LmsOrphanSeenFirst >. addWeeks (-1) now] [] + orphans <- Ex.select $ do + orv <- Ex.from $ Ex.table @LmsOrphan + Ex.where_ $ Ex.val qid Ex.==. orv Ex.^. LmsOrphanQualification + Ex.&&. Ex.val cutoff_seen_first Ex.>=. orv Ex.^. LmsOrphanSeenFirst -- has been seen for while + Ex.&&. Ex.val cutoff_seen_last Ex.<=. orv Ex.^. LmsOrphanSeenLast -- was still seen recently + Ex.&&. Ex.val cutoff_deleted_last E.<~. orv Ex.^. LmsOrphanDeletedLast -- not already recently deleted + Ex.&&. Ex.notExists (do -- not currently used anywhere (LmsIdent share the namespace) + lusr <- Ex.from $ Ex.table @LmsUser + Ex.where_ $ lusr Ex.^. LmsUserIdent Ex.==. orv Ex.^.LmsOrphanIdent + ) + Ex.orderBy [Ex.desc $ orv Ex.^. LmsOrphanDeletedLast, Ex.asc $ orv Ex.^. LmsOrphanSeenLast] -- Note for PostgreSQL: DESC == DESC NULLS FIRST + Ex.limit orphan_max_batch + return orv + updateWhere [LmsOrphanId <-. fmap entityKey orphans] [LmsOrphanDeletedLast =. Just now] return (lms_users, orphans, cutoff, qshs) LmsConf{..} <- getsYesod $ view _appLmsConf @@ -226,7 +245,7 @@ getLmsLearnersDirectR sid qsh = do csvSheetName <- csvFilenameLmsUser qsh let nr = length lms_users orv_nr = length orphans - msg0 = "Success. LMS user learners download file " <> csvSheetName <> " containing " <> tshow nr <> " rows for Qualifications " <> Text.intercalate ", " (ciOriginal <$> qshs) + msg0 = "Success. LMS learners direct download file " <> csvSheetName <> " containing " <> tshow nr <> " rows for Qualifications " <> Text.intercalate ", " (ciOriginal <$> qshs) msg1 = ". Orphaned LMS idents marked for deletion: " <> tshow orv_nr msg = if orv_nr > 0 then msg0 <> msg1 else msg1 $logInfoS "LMS" msg @@ -234,4 +253,4 @@ getLmsLearnersDirectR sid qsh = do csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered <* runDB (logInterface "LMS" (ciOriginal qsh) True (Just nr) "") -- direct Download see: --- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod \ No newline at end of file +-- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod diff --git a/src/Handler/LMS/Users.hs b/src/Handler/LMS/Users.hs index e4b2eb990..a3caa5ac5 100644 --- a/src/Handler/LMS/Users.hs +++ b/src/Handler/LMS/Users.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Steffen Jost +-- SPDX-FileCopyrightText: 2022-25 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -77,11 +77,13 @@ instance CsvColumnsExplained LmsUserTableCsv where ] -mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) -mkUserTable _sid qsh qid = do - cutoff <- liftHandler $ lmsDeletionDate Nothing +mkUserTable :: SchoolId -> Entity Qualification -> DB (Any, Widget) +mkUserTable _sid Entity{entityKey=qid, entityVal=quali} = do + let qsh = qualificationShorthand quali dbtCsvName <- csvFilenameLmsUser qsh + now <- liftIO getCurrentTime let dbtCsvSheetName = dbtCsvName + cutoff = lmsDeletionDate now $ qualificationAuditDuration quali let userDBTable = DBTable{..} where @@ -96,7 +98,7 @@ mkUserTable _sid qsh qid = do , sortable (Just csvLmsPin) (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)] ) $ \(view $ _dbrOutput . _entityVal . _lmsUserPin -> pin ) -> textCell pin , sortable (Just csvLmsResetPin) (i18nCell MsgTableLmsResetPin) $ \(view $ _dbrOutput . _entityVal . _lmsUserResetPin -> reset) -> ifIconCell reset IconReset - , sortable (Just csvLmsDelete) (i18nCell MsgTableLmsDelete) $ \(view $ _dbrOutput . _entityVal . _lmsUserToDelete cutoff -> del ) -> ifIconCell del IconRemoveUser + , sortable (Just csvLmsDelete) (i18nCell MsgTableLmsDelete) $ \(view $ _dbrOutput . _entityVal . _lmsUserToDelete cutoff -> del ) -> ifIconCell del IconRemoveUser , sortable Nothing (i18nCell MsgTableLmsStaff) $ const mempty ] dbtSorting = Map.fromList @@ -141,8 +143,8 @@ mkUserTable _sid qsh qid = do getLmsUsersR :: SchoolId -> QualificationShorthand -> Handler Html getLmsUsersR sid qsh = do lmsTable <- runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - view _2 <$> mkUserTable sid qsh qid + qent <- getBy404 $ SchoolQualificationShort sid qsh + view _2 <$> mkUserTable sid qent siteLayoutMsg MsgMenuLmsUsers $ do setTitleI MsgMenuLmsUsers lmsTable @@ -150,13 +152,14 @@ getLmsUsersR sid qsh = do getLmsUsersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent getLmsUsersDirectR sid qsh = do $logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid - cutoff <- lmsDeletionDate Nothing - lms_users <- runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - selectList [ LmsUserQualification ==. qid - , LmsUserEnded ==. Nothing - -- , LmsUserReceived ==. Nothing ||. LmsUserResetPin ==. True ||. LmsUserStatus !=. Nothing -- send delta only NOTE: know-how no longer expects delta - ] [Asc LmsUserStarted, Asc LmsUserIdent] + now <- liftIO getCurrentTime + (cutoff, lms_users) <- runDB $ do + Entity{entityKey=qid, entityVal=quali} <- getBy404 $ SchoolQualificationShort sid qsh + (lmsDeletionDate now (qualificationAuditDuration quali),) <$> + selectList [ LmsUserQualification ==. qid + , LmsUserEnded ==. Nothing + -- , LmsUserReceived ==. Nothing ||. LmsUserResetPin ==. True ||. LmsUserStatus !=. Nothing -- send delta only NOTE: know-how no longer expects delta + ] [Asc LmsUserStarted, Asc LmsUserIdent] {- To avoid exporting unneeded columns, we would need an SqlSelect instance for LmsUserTableCsv; probably not worth it Ex.select $ do diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 007ef6812..1971b2bfa 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -516,7 +516,7 @@ postQualificationR sid qsh = do qent@Entity{ entityKey=qid , entityVal=Qualification{ - qualificationAuditDuration=auditMonths + qualificationAuditDuration=lmsAuditDays , qualificationValidDuration=validMonths , qualificationLmsReuses =reuseQuali }} <- getBy404 $ SchoolQualificationShort sid qsh @@ -536,7 +536,7 @@ postQualificationR sid qsh = do suggestionsBlock :: HandlerFor UniWorX (OptionList Text) suggestionsBlock = mkOptionListText <$> runDB (getBlockReasons Ex.not_) suggestionsUnblock = mkOptionListText <$> runDB (getBlockReasons id) - dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> validMonths + dayExpiry = flip computeNewValidDate nowaday <$> validMonths acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData) acts = mconcat $ [ singletonMap QualificationActExpire $ pure QualificationActExpireData @@ -578,7 +578,7 @@ postQualificationR sid qsh = do qualificationValidReasonCell' (Just $ LmsUserR sid qsh) isAdmin nowaday (row ^? resultQualBlock) row , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification - , sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths)) + , sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin lmsAuditDays)) $ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap (lmsStatusCell isAdmin linkLmsUser) lu -- QualificationUserLastNotified is about notification on actual validity changes. If a user's licence is about to expire and renewed before expiry via e-learning, this value does not change. -- NOTE: If this column is reinstatiated, header and tooltip were already updated to avoid any confusion! diff --git a/src/Handler/Qualification/Edit.hs b/src/Handler/Qualification/Edit.hs index f90c2cb43..3ad537260 100644 --- a/src/Handler/Qualification/Edit.hs +++ b/src/Handler/Qualification/Edit.hs @@ -47,7 +47,7 @@ mkQualificationForm ssh templ = identifyForm FIDQualificationEdit . validateForm <*> aopt calendarDiffDaysField (fslI MsgQualificationRefreshReminder & setTooltip MsgQualificationRefreshReminderTooltip) (qualificationRefreshReminder <$> templ) -- 8 -> 8 <*> areq checkBoxField (fslI MsgQualificationExpiryNotification) (qualificationExpiryNotification <$> templ) -- 9 -> 13 - <*> aopt_natFieldI MsgQualificationAuditDuration (qualificationAuditDuration <$> templ) -- 10 -> 6 + <*> areq_natFieldI MsgQualificationAuditDuration (qualificationAuditDuration <$> templ) -- 10 -> 6 <*> areq checkBoxField (fslI MsgQualificationElearningRenew) (qualificationElearningRenews <$> templ) -- 11 -> 10 <*> aopt_natFieldI MsgQualificationElearningLimit (qualificationElearningLimit <$> templ) -- 12 -> 11 <*> aopt qualificationField (fslI MsgTableQualificationLmsReuses & @@ -60,9 +60,11 @@ mkQualificationForm ssh templ = identifyForm FIDQualificationEdit . validateForm avsLicenceField :: Field Handler AvsLicence avsLicenceField = selectFieldList [ (Text.singleton $ licence2char lic, lic) | lic <- universeF, lic /= AvsNoLicence ] - aopt_natFieldI msg = aopt (natFieldI $ UniWorXMessages [SomeMessage msg, text2message " ", SomeMessage MsgMustBePositive]) (fslI msg) + aopt_natFieldI msg = aopt (natFieldI $ SomeMessages " " [SomeMessage msg, SomeMessage MsgMustBePositive]) (fslI msg) + areq_natFieldI msg = areq (natFieldI $ SomeMessages " " [SomeMessage msg, SomeMessage MsgMustBePositive]) (fslI msg) -- [ 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15] reorderedQualification = $(permuteFun [ 1, 2, 3, 4, 5,10, 6, 8, 7,11,12,13, 9,14,15]) Qualification -- == inversePermutation [1,2,3,4,5,7,9,8,13,6,10,11,12,14,15] + validateQualificationEdit :: SchoolId -> FormValidator Qualification Handler () validateQualificationEdit ssh = do canonise @@ -70,7 +72,8 @@ validateQualificationEdit ssh = do guardValidation MsgQualFormErrorSshMismatch $ qualificationSchool == ssh guardValidation MsgLmsErrorNoRefreshElearning $ not qualificationElearningStart || isJust qualificationRefreshWithin guardValidation MsgLmsErrorNoRenewElearning $ not qualificationElearningStart || isJust qualificationValidDuration - guardValidation MsgQualificationAuditDurationReuseError $ isNothing qualificationAuditDuration || isNothing qualificationLmsReuses + when (isJust qualificationLmsReuses) $ + liftHandler $ addMessageI Info MsgQualificationAuditDurationReuseInfo where canonise = do -- i.e. map Just 0 to Nothing Qualification{..} <- State.get @@ -78,7 +81,6 @@ validateQualificationEdit ssh = do when (qualificationRefreshWithin == Just mempty) $ State.modify $ set _qualificationRefreshWithin Nothing when (qualificationRefreshReminder == Just mempty) $ State.modify $ set _qualificationRefreshReminder Nothing when (qualificationValidDuration == Just 0) $ State.modify $ set _qualificationValidDuration Nothing - when (qualificationAuditDuration == Just 0) $ State.modify $ set _qualificationAuditDuration Nothing when (qualificationElearningLimit == Just 0) $ State.modify $ set _qualificationElearningLimit Nothing diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 17337dcc9..deddc1de9 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -122,7 +122,7 @@ postTUsersR tid ssh csh tutn = do qualifications <- getCourseQualifications cid let nowaday = utctDay now minDur :: Maybe Int = minimumMaybe $ mapMaybe (view _qualificationValidDuration) qualifications -- no instance Ord CalendarDiffDays - dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> minDur + dayExpiry = flip computeNewValidDate nowaday <$> minDur colChoices = mconcat $ catMaybes [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) , pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index 06fd53a7b..895708d83 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Steffen Jost +-- SPDX-FileCopyrightText: 2022-25 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -121,16 +121,10 @@ makeLmsFilename ftag (citext2lower -> qsh) = do getYMTH :: MonadHandler m => m Text getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime --- | Given the QualificationAuditDuration, determines the time to signal the deletion of an LMS User to the e-learning server. Note that the e-learning server ought to delete LMS users on its own -lmsDeletionDate :: Maybe Int -> Handler UTCTime -lmsDeletionDate mbMaxAuditMonths = do - now <- liftIO getCurrentTime - LmsConf{lmsDeletionDays} <- getsYesod $ view _appLmsConf - let ldd = addDiffDaysRollOver (fromDays $ negate lmsDeletionDays) now - return $ case mbMaxAuditMonths of - Nothing -> ldd - (Just maxAuditMonths) -> - max ldd (addDiffDaysRollOver (fromMonths $ negate maxAuditMonths) now) +-- | Given QualificationAuditDuration and current time, determine time to signal the deletion of an LMS User to the e-learning server. Note that the e-learning server ought to delete LMS users on its own now. +lmsDeletionDate :: UTCTime -> Int -> UTCTime +lmsDeletionDate now qualiAuditDuration = + addDiffDaysRollOver (fromDays $ negate qualiAuditDuration) now -- | Decide whether LMS platform should delete an identifier lmsUserToDeleteExpr :: UTCTime -> E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool) @@ -141,7 +135,7 @@ lmsUserToDeleteExpr cutoff lmslist = E.isNothing (lmslist E.^. LmsUserEnded) -- | Is everything since cutoff day or before? lmsUserToDelete :: UTCTime -> LmsUser -> Bool -lmsUserToDelete cutoff LmsUser{lmsUserEnded=Nothing, lmsUserStatusDay=Just lstat} = lstat < cutoff +lmsUserToDelete cutoff LmsUser{lmsUserEnded=Nothing, lmsUserStatusDay=Just lstat} = lstat <= cutoff lmsUserToDelete _ _ = False _lmsUserToDelete :: UTCTime -> Getter LmsUser Bool @@ -192,7 +186,7 @@ maxLmsUserIdentRetries = 27 randomText :: MonadIO m => String -> Int -> m Text randomText extra n = fmap pack . evalRandTIO . replicateM n $ uniform range where - num_letters = ['2'..'9'] ++ ['a'..'h'] ++ 'k' : ['m'..'z'] -- users have trouble distinguishing 1/l and 0/O so we eliminate these; apc has trouble distinguishing i/j and read "ji", "jf" as ligatures "ij", "fj" so we eliminate j as well + num_letters = ['2'..'9'] ++ ['a'..'h'] ++ 'k' : ['m'..'z'] -- users have trouble distinguishing 1/l and 0/O so we eliminate these; apc has trouble distinguishing i/j and read "ji", "jf" as ligatures "ij", "fj" so we eliminate j as well range = extra ++ num_letters --TODO: consider using package elocrypt for user-friendly passwords here, licence requires mentioning of author, etc. though @@ -218,11 +212,11 @@ randomLMSpw = randomText extra lengthPassword where extra = "+=!?" -- you cannot distinguish ;: and ., in printed letters -lmsStatusInfoCell :: Bool -> Maybe Int -> Widget -lmsStatusInfoCell extendedInfo auditMonths = +lmsStatusInfoCell :: Bool -> Int -> Widget +lmsStatusInfoCell extendedInfo lmsAuditDays = [whamlet|$newline never

    - _{MsgTableLmsStatusTooltip auditMonths} + _{MsgTableLmsStatusTooltip lmsAuditDays}

    $if extendedInfo @@ -279,7 +273,7 @@ lmsUserStatusWidget adminInfo mbLink luser = case luser of $if adminInfo \ ^{resetIcon} |] -- would always display Iconlocked - + _ -> mempty where @@ -295,7 +289,7 @@ lmsUserStatusWidget adminInfo mbLink luser = case luser of dateWgt :: Maybe UTCTime -> Widget dateWgt = let mkDayWgt = maybe (text2widget "--.--.----") (formatTimeW SelFormatDateTime) - in case mbLink of + in case mbLink of Nothing -> mkDayWgt (Just mkLink) -> \mbDay -> do uuid <- liftHandler $ encrypt $ luser ^. _lmsUserUser diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index 01489838a..0ed25fedd 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Steffen Jost +-- SPDX-FileCopyrightText: 2022-25 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -54,7 +54,12 @@ retrieveQualification' qid = liftHandler $ memcachedBy (Just . Right $ 7 * diffH -- | Compute new valid date from old one and from validDuration in months -- Mainly to document which add months functions to use computeNewValidDate :: Integral a => a -> Day -> Day -computeNewValidDate = addGregorianMonthsRollOver . toInteger +computeNewValidDate = addGregorianMonthsClip . toInteger + +computeNewValidDate' :: CalendarDiffDays -> Day -> Day +computeNewValidDate' = addGregorianDurationClip + + statusQualificationBlock :: Bool -> Html statusQualificationBlock s = statusHtml (bool Error Success s) $ iconQualificationBlock s @@ -241,7 +246,7 @@ renewValidQualificationUsers qid reason renewalTime uids = cutoff <- maybe (liftIO getCurrentTime) return renewalTime quEntsAll <- selectValidQualifications qid uids cutoff let cutoffday = utctDay cutoff - maxValidTo = addGregorianMonthsRollOver (toInteger $ renewalMonths `div` 2) cutoffday + maxValidTo = computeNewValidDate (renewalMonths `div` 2) cutoffday -- earliest renewal: only if less than half the valid duration remains! quEnts = filter (\q -> maxValidTo >= (q ^. _entityVal . _qualificationUserValidUntil)) quEntsAll forM_ quEnts $ \(Entity quId QualificationUser{..}) -> do let newValidTo = computeNewValidDate renewalMonths qualificationUserValidUntil diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index d2ec622ea..da1f80cfa 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -27,8 +27,8 @@ import qualified Data.Set as Set -- import qualified Data.Map as Map -- import qualified Data.Time.Zones as TZ -import Handler.Utils.DateTime -import Handler.Utils.LMS (randomLMSIdentBut, randomLMSpw, maxLmsUserIdentRetries) +-- import Handler.Utils.DateTime +import Handler.Utils.LMS (randomLMSIdentBut, randomLMSpw, maxLmsUserIdentRetries, lmsDeletionDate) import Handler.Utils.Qualification import qualified Data.CaseInsensitive as CI @@ -93,7 +93,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act _ -> return () -- send initial reminders whenIsJust (qualificationRefreshWithin quali) $ \renewalPeriod -> do -- no refreshWithin, no first reminders - let renewalDate = addGregorianDurationClip renewalPeriod nowaday + let renewalDate = computeNewValidDate' renewalPeriod nowaday renewalUsers <- E.select $ do quser <- E.from $ E.table @QualificationUser E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid @@ -112,7 +112,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act let uid = quser ^. _entityVal . _qualificationUserUser uex = quser ^. _entityVal . _qualificationUserValidUntil unf = quser ^. _entityVal . _qualificationUserLastNotified - nfy_cutoff = addGregorianDurationClip renewalPeriod $ utctDay unf + nfy_cutoff = computeNewValidDate' renewalPeriod $ utctDay unf do_notify = uex > nfy_cutoff || (uex == nfy_cutoff && utctDayTime now >= utctDayTime unf) in if | qualificationElearningStart quali -- repetition avoided since LmsUser does not exist @@ -244,30 +244,27 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act } -- purge outdated LmsUsers - case qualificationAuditDuration quali of - Nothing -> return () -- no automatic removal - (Just auditDuration) -> do - let auditCutoff = addDiffDaysRollOver (fromMonths $ negate auditDuration) now - $logInfoS "LMS" $ "Audit Cuttoff at " <> tshow auditCutoff <> " for Audit Duration " <> tshow auditDuration <> " for qualification " <> qshort - delusersVals <- E.select $ do - luser <- E.from $ E.table @LmsUser - E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid - E.&&. luser E.^. LmsUserEnded E.<. E.justVal auditCutoff - E.&&. E.isJust (luser E.^. LmsUserEnded) - -- E.&&. E.notExists (do - -- laudit <- E.from $ E.table @LmsAudit - -- E.where_ $ laudit E.^. LmsAuditQualification E.==. E.val qid - -- E.&&. laudit E.^. LmsAuditIdent E.==. luser E.^. LmsUserIdent - -- E.&&. laudit E.^. LmsAuditProcessed E.>=. E.val auditCutoff - -- ) - pure (luser E.^. LmsUserIdent) - let delusers = E.unValue <$> delusersVals - numdel = length delusers - when (numdel > 0) $ do - $logInfoS "LMS" $ "Deleting " <> tshow numdel <> " LmsIdents due to audit duration expiry for qualification " <> qshort - deleteWhere [LmsUserQualification ==. qid, LmsUserIdent <-. delusers] - -- deleteWhere [LmsAuditQualification ==. qid, LmsAuditIdent <-. delusers] - deleteWhere [LmsReportLogQualification ==. qid, LmsReportLogTimestamp <. auditCutoff ] + let auditCutoff = lmsDeletionDate now $ qualificationAuditDuration quali + $logInfoS "LMS" $ "Audit Cuttoff at " <> tshow auditCutoff <> " for Audit Duration " <> tshow (qualificationAuditDuration quali) <> " for qualification " <> qshort + delusersVals <- E.select $ do + luser <- E.from $ E.table @LmsUser + E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid + E.&&. luser E.^. LmsUserEnded E.<. E.justVal auditCutoff + E.&&. E.isJust (luser E.^. LmsUserEnded) + -- E.&&. E.notExists (do + -- laudit <- E.from $ E.table @LmsAudit + -- E.where_ $ laudit E.^. LmsAuditQualification E.==. E.val qid + -- E.&&. laudit E.^. LmsAuditIdent E.==. luser E.^. LmsUserIdent + -- E.&&. laudit E.^. LmsAuditProcessed E.>=. E.val auditCutoff + -- ) + pure (luser E.^. LmsUserIdent) + let delusers = E.unValue <$> delusersVals + numdel = length delusers + when (numdel > 0) $ do + $logInfoS "LMS" $ "Deleting " <> tshow numdel <> " LmsIdents due to audit duration expiry for qualification " <> qshort + deleteWhere [LmsUserQualification ==. qid, LmsUserIdent <-. delusers] + -- deleteWhere [LmsAuditQualification ==. qid, LmsAuditIdent <-. delusers] + deleteWhere [LmsReportLogQualification ==. qid, LmsReportLogTimestamp <. auditCutoff ] logInterface "LMS" (qshort <> "-deq") True (Just nrBlocked) (tshow nrExpired <> " expired") @@ -412,16 +409,17 @@ dispatchJobLmsReports qid = JobHandlerAtomic act E.<&> (lreport E.^. LmsReportIdent) E.<&> E.val now E.<&> E.val now + E.<&> E.nothing ) (\_old _new -> [ LmsOrphanSeenLast E.=. E.val now ] ) when (orv_upd > 0) ( $logInfoS "LMS" [st|Orphans upserted for #{qshort}: #{tshow orv_upd} |] ) - whenIsJust (qualificationAuditDuration quali) $ \auditDuration -> do - let auditCutoff = addDiffDaysRollOver (fromMonths $ negate auditDuration) now - orv_del <- deleteWhereCount [LmsOrphanQualification ==. qid, LmsOrphanSeenLast <. auditCutoff] - when (orv_del > 0) ( $logInfoS "LMS" [st|Orphans removed for #{qshort}: #{tshow orv_del} |] ) + -- delete old orphans + let auditCutoff = lmsDeletionDate now $ qualificationAuditDuration quali + orv_del <- deleteWhereCount [LmsOrphanQualification ==. qid, LmsOrphanSeenLast <. auditCutoff] + when (orv_del > 0) ( $logInfoS "LMS" [st|Orphans removed for #{qshort}: #{tshow orv_del} |] ) -- H) Truncate LmsReport for qid, after updating log E.insertSelect $ do diff --git a/src/Settings.hs b/src/Settings.hs index a16fbdbf4..8296eda61 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel ,-24 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-2025 Sarah Vaupel , Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -316,12 +316,14 @@ data LdapConf = LdapConf } deriving (Show) data LmsConf = LmsConf - { lmsUploadHeader :: Bool - , lmsUploadDelimiter :: Maybe Char - , lmsDownloadHeader :: Bool - , lmsDownloadDelimiter :: Char - , lmsDownloadCrLf :: Bool - , lmsDeletionDays :: Int + { lmsUploadHeader :: Bool + , lmsUploadDelimiter :: Maybe Char + , lmsDownloadHeader :: Bool + , lmsDownloadDelimiter :: Char + , lmsDownloadCrLf :: Bool + , lmsOrphanDeletionDays :: Integer + , lmsOrphanDeletionBatch :: Int64 + , lmsOrphanRepeatHours :: Int } deriving (Show) data AvsConf = AvsConf @@ -511,12 +513,14 @@ deriveFromJSON instance FromJSON LmsConf where parseJSON = withObject "LmsConf" $ \o -> do - lmsUploadHeader <- o .: "upload-header" - lmsUploadDelimiter <- o .:? "upload-delimiter" - lmsDownloadHeader <- o .: "download-header" - lmsDownloadDelimiter <- o .: "download-delimiter" - lmsDownloadCrLf <- o .: "download-cr-lf" - lmsDeletionDays <- o .: "deletion-days" + lmsUploadHeader <- o .: "upload-header" + lmsUploadDelimiter <- o .:? "upload-delimiter" + lmsDownloadHeader <- o .: "download-header" + lmsDownloadDelimiter <- o .: "download-delimiter" + lmsDownloadCrLf <- o .: "download-cr-lf" + lmsOrphanDeletionDays <- o .: "orphan-deletion-days" + lmsOrphanDeletionBatch <- o .: "orphan-deletion-batch" + lmsOrphanRepeatHours <- o .: "orphan-deletion-repeat-hours" return LmsConf{..} makeLenses_ ''LmsConf diff --git a/templates/lms.hamlet b/templates/lms.hamlet index 877ed34c2..c8ffb0596 100644 --- a/templates/lms.hamlet +++ b/templates/lms.hamlet @@ -14,19 +14,12 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
    _{MsgQualificationValidDuration}
    _{MsgMonths (fromIntegral dvalid)} - $maybe daudit <- qualificationAuditDuration quali -
    _{MsgQualificationAuditDuration} ^{iconTooltip (msg2widget (MsgQualificationAuditDurationTooltip lmsDeletionDays)) Nothing True} -
    - $maybe lqre <- lmsQualiReused - $maybe daudit <- qualificationAuditDuration lqre - _{MsgMonths (fromIntegral daudit)} - $nothing - _{MsgMonths (fromIntegral daudit)} - $nothing +
    _{MsgQualificationAuditDuration} ^{iconTooltip (msg2widget MsgQualificationAuditDurationTooltip) Nothing True} +
    $maybe lqre <- lmsQualiReused - $maybe daudit <- qualificationAuditDuration lqre -
    _{MsgQualificationAuditDuration} ^{iconTooltip (msg2widget (MsgQualificationAuditDurationTooltip lmsDeletionDays)) Nothing True} -
    _{MsgMonths (fromIntegral daudit)} + _{MsgDays (fromIntegral (qualificationAuditDuration lqre))} + $nothing + _{MsgDays (fromIntegral (qualificationAuditDuration quali))} $maybe drefresh <- qualificationRefreshWithin quali
    _{MsgQualificationRefreshWithin} ^{iconTooltip (msg2widget MsgQualificationRefreshWithinTooltip) Nothing True} diff --git a/templates/qualification.hamlet b/templates/qualification.hamlet index 36a01e246..29b9ce84f 100644 --- a/templates/qualification.hamlet +++ b/templates/qualification.hamlet @@ -15,21 +15,12 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
    _{MsgQualificationValidDuration}
    _{MsgMonths (fromIntegral dvalid)} - $maybe daudit <- qualificationAuditDuration quali -
    _{MsgQualificationAuditDuration} -
    - $maybe lqre <- lmsQualiReused - $maybe daudit <- qualificationAuditDuration lqre - _{MsgMonths (fromIntegral daudit)} - $nothing - _{MsgQualificationAuditDurationReuseNoTime} - $nothing - _{MsgMonths (fromIntegral daudit)} - $nothing +
    _{MsgQualificationAuditDuration} +
    $maybe lqre <- lmsQualiReused - $maybe daudit <- qualificationAuditDuration lqre -
    _{MsgQualificationAuditDuration} -
    _{MsgMonths (fromIntegral daudit)} + _{MsgDays (fromIntegral (qualificationAuditDuration lqre))} + $nothing + _{MsgDays (fromIntegral (qualificationAuditDuration quali))} $maybe drefresh <- qualificationRefreshWithin quali
    _{MsgQualificationRefreshWithin} ^{iconTooltip (msg2widget MsgQualificationRefreshWithinTooltip) Nothing True} diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index cd621e641..9fcbcd980 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -754,10 +754,10 @@ fillDb = do let r_descr = Just $ htmlToStoredMarkup [shamlet|

    Berechtigung zum Führen eines Fahrzeuges auf dem gesamten Rollfeld.|] let l_descr = Just $ htmlToStoredMarkup [shamlet|

    für unhabilitierte|] - qid_f <- insert' $ Qualification avn "F" "Vorfeldführerschein" f_descr (Just 24) (Just 8) (Just $ CalendarDiffDays 0 60) (Just $ CalendarDiffDays 0 14) True True (Just 5) Nothing True (Just AvsLicenceVorfeld) $ Just "F4466" - qid_r <- insert' $ Qualification avn "R" "Rollfeldführerschein" r_descr (Just 12) (Just 6) (Just $ CalendarDiffDays 2 3) Nothing False False Nothing Nothing False (Just AvsLicenceRollfeld) $ Just "R2801" - qid_rp <- insert' $ Qualification avn "R+" "Rollfeldführerschein-Plus" r_descr (Just 12) (Just 4) (Just $ CalendarDiffDays 2 3) Nothing False False Nothing (Just qid_r) False (Just AvsLicenceRollfeld) $ Just "R2802" - qid_l <- insert' $ Qualification ifi "L" "Lehrbefähigung" l_descr Nothing (Just 6) Nothing Nothing True False Nothing Nothing True Nothing Nothing + qid_f <- insert' $ Qualification avn "F" "Vorfeldführerschein" f_descr (Just 24) 31 (Just $ CalendarDiffDays 0 60) (Just $ CalendarDiffDays 0 14) True True (Just 5) Nothing True (Just AvsLicenceVorfeld) $ Just "F4466" + qid_r <- insert' $ Qualification avn "R" "Rollfeldführerschein" r_descr (Just 12) 64 (Just $ CalendarDiffDays 2 3) Nothing False False Nothing Nothing False (Just AvsLicenceRollfeld) $ Just "R2801" + qid_rp <- insert' $ Qualification avn "R+" "Rollfeldführerschein-Plus" r_descr (Just 12) 12 (Just $ CalendarDiffDays 2 3) Nothing False False Nothing (Just qid_r) False (Just AvsLicenceRollfeld) $ Just "R2802" + qid_l <- insert' $ Qualification ifi "L" "Lehrbefähigung" l_descr Nothing 6 Nothing Nothing True False Nothing Nothing True Nothing Nothing qfjost <- insert' $ QualificationUser jost qid_f (n_day 11) (n_day $ -1) (n_day $ -22) True (n_day' $ -9) -- TODO: better dates! void . insert $ QualificationUserBlock qfjost False (n_day' $ -6) "First block" (Just svaupel) void . insert $ QualificationUserBlock qfjost True (n_day' $ -5) "Second unblock" (Just gkleen)