refactor(lms): ensure days/months in qualification settings are always used correctly and implement settings for orphans

- extensive refactoring for qualification lms settings
- qualificationAuditDuration changed from months to days
- qualificationAuditDuration no longer optional
- qualificationAuditDuration is only used for LMS; clarified
- three new settings:
    + orphan-deletion-days:
    + orphan-deletion-batch:
    + orphan-deletion-repeat-hours:

config/settings.yml

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>
+# SPDX-FileCopyrightText: 2022-2025 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
 #
 # 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-header:                "_env:LMSUPLOADHEADER:true"
-  upload-delimiter:     "_env:LMSUPLOADDELIMITER:"
+  upload-delimiter:             "_env:LMSUPLOADDELIMITER:"
-  download-header:      "_env:LMSDOWNLOADHEADER:true"
+  download-header:              "_env:LMSDOWNLOADHEADER:true"
-  download-delimiter:   "_env:LMSDOWNLOADDELIMITER:,"
+  download-delimiter:           "_env:LMSDOWNLOADDELIMITER:,"
-  download-cr-lf:       "_env:LMSDOWNLOADCRLF:true"
+  download-cr-lf:               "_env:LMSDOWNLOADCRLF:true"
-  deletion-days:        "_env:LMSDELETIONDAYS:7"
+  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"

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.
+QualificationAuditDurationTooltip: Anzahl Tage zur Löschung von E‑Learning Daten. Hinweis: Der E‑Learning Server kann seine anonymisierten Daten schon früher löschen.
-QualificationAuditDurationReuseNoTime: Diese Qualifikation nutzt das E‑Learning einer anderen Qualifikation, für die derzeit keinen Löschzeitraum konfiguriert wurde.
+QualificationAuditDurationReuseInfo: Aufbewahrungszeitraum E‑Learning Log wird ignoriert, da das E‑Learning einer anderen Qualifikation mitbenutzt wird.
-QualificationAuditDurationReuseError: Fehler: Aufbewahrungszeitraum E‑Learning Log kann nicht individuell konfiguriert werden, wenn 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

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.
+QualificationAuditDurationTooltip: Days for deletion of e‑learning data. Note that the e‑learning server may delete its anonymised data earlier.
-QualificationAuditDurationReuseNoTime: This qualification reuses the e‑learning from another qualification, which has no audit duration configured.
+QualificationAuditDurationReuseInfo: E‑learning audit log retention period ignore, since the e‑learning from another qualification is reused.
-QualificationAuditDurationReuseError: Error: Audit log retention period may not be configure when reusing the e‑learning from another qualification.
 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

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

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 :: Bool -> DB (Any, Widget)
-mkLmsAllTable isAdmin lmsDeletionDays = do
+mkLmsAllTable isAdmin = do
-  svs <- getSupervisees
+  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]) $
+          , sortable Nothing (i18nCell MsgQualificationAuditDuration    & cellTooltips [SomeMessage MsgQualificationAuditDurationTooltip, SomeMessage MsgTableDiffDaysTooltip]) $
-              foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationAuditDuration)
+                      (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

src/Handler/LMS/Fake.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-25 Steffen Jost <s.jost@fraport.de>
 --
 -- 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}
 
-        <h2>Hinweise: 
+        <h2>Hinweise:
         <ul>
-          <li> Emails der generierten Teilnehmer enden auf <tt>@example.com</tt> 
+          <li> Emails der generierten Teilnehmer enden auf <tt>@example.com</tt>
                und die Matrikelnummer lautet <tt>TESTUSER</tt>.
           <li> Bereits vorhandene Teilnehmer mit gleicher Ident werden nicht neu generiert.
           <li> 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 
+    let addSupervisor = case theSupervisor of
-          [s] -> \suid k -> case k 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
+                  qualificationUserFirstHeld        = computeNewValidDate (-24) qualificationUserValidUntil
-                  qualificationUserLastRefresh      = qualificationUserFirstHeld                  
+                  qualificationUserLastRefresh      = qualificationUserFirstHeld
                   qualificationUserScheduleRenewal  = True
                   qualificationUserLastNotified     = now
-              _ <- upsert QualificationUser{..} 
+              _ <- upsert QualificationUser{..}
                           [ QualificationUserValidUntil  =. qualificationUserValidUntil
                           , QualificationUserLastRefresh =. qualificationUserLastRefresh
                           ]

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 <- Ex.select $ do
-    orphans <- selectList [LmsOrphanQualification ==. qid, LmsOrphanSeenFirst >. addWeeks (-1) now] []
+        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
+-- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod

src/Handler/LMS/Users.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-23 Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-25 Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -77,11 +77,13 @@ instance CsvColumnsExplained LmsUserTableCsv where
     ]
 
 
-mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
+mkUserTable :: SchoolId -> Entity Qualification -> DB (Any, Widget)
-mkUserTable _sid qsh qid = do
+mkUserTable _sid Entity{entityKey=qid, entityVal=quali} = do
-  cutoff <- liftHandler $ lmsDeletionDate Nothing
+  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
+    qent <- getBy404 $ SchoolQualificationShort sid qsh
-    view _2 <$> mkUserTable sid qsh qid
+    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
+  now <- liftIO getCurrentTime
-  lms_users <- runDB $ do
+  (cutoff, lms_users) <- runDB $ do
-    qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
+    Entity{entityKey=qid, entityVal=quali} <- getBy404 $ SchoolQualificationShort sid qsh
-    selectList [ LmsUserQualification ==. qid
+    (lmsDeletionDate now (qualificationAuditDuration quali),) <$>
-               , LmsUserEnded ==. Nothing
+      selectList  [ LmsUserQualification ==. qid
-               -- , LmsUserReceived ==. Nothing ||. LmsUserResetPin ==. True ||. LmsUserStatus !=. Nothing -- send delta only NOTE: know-how no longer expects delta
+                  , LmsUserEnded ==. Nothing
-               ] [Asc LmsUserStarted, Asc LmsUserIdent]
+                  -- , 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

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!

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
 
 

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

src/Handler/Utils/LMS.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-23 Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-25 Steffen Jost <s.jost@fraport.de>
 --
 -- 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
+-- | 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 :: Maybe Int -> Handler UTCTime
+lmsDeletionDate :: UTCTime -> Int -> UTCTime
-lmsDeletionDate mbMaxAuditMonths = do
+lmsDeletionDate now qualiAuditDuration =
-  now <- liftIO getCurrentTime
+  addDiffDaysRollOver (fromDays $ negate qualiAuditDuration) now
-  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)
 
 -- | 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 :: Bool -> Int -> Widget
-lmsStatusInfoCell extendedInfo auditMonths =
+lmsStatusInfoCell extendedInfo lmsAuditDays =
   [whamlet|$newline never
     <p>
-      _{MsgTableLmsStatusTooltip auditMonths}
+      _{MsgTableLmsStatusTooltip lmsAuditDays}
     <p>
       <dl .glossary>
         $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

src/Handler/Utils/Qualification.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-23 Steffen Jost <s.jost@fraport.de>
+-- SPDX-FileCopyrightText: 2022-25 Steffen Jost <s.jost@fraport.de>
 --
 -- 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

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.DateTime
-import Handler.Utils.LMS (randomLMSIdentBut, randomLMSpw, maxLmsUserIdentRetries)
+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
+      let auditCutoff = lmsDeletionDate now $ qualificationAuditDuration quali
-        Nothing -> return () -- no automatic removal
+      $logInfoS "LMS" $ "Audit Cuttoff at " <> tshow auditCutoff <> " for Audit Duration " <> tshow (qualificationAuditDuration quali) <> " for qualification " <> qshort
-        (Just auditDuration) -> do
+      delusersVals <- E.select $ do
-          let auditCutoff = addDiffDaysRollOver (fromMonths $ negate auditDuration) now
+        luser <- E.from $ E.table @LmsUser
-          $logInfoS "LMS" $ "Audit Cuttoff at " <> tshow auditCutoff <> " for Audit Duration " <> tshow auditDuration <> " for qualification " <> qshort
+        E.where_ $  luser E.^. LmsUserQualification E.==. E.val qid
-          delusersVals <- E.select $ do
+              E.&&. luser E.^. LmsUserEnded         E.<.  E.justVal auditCutoff
-            luser <- E.from $ E.table @LmsUser
+              E.&&. E.isJust (luser E.^. LmsUserEnded)
-            E.where_ $  luser E.^. LmsUserQualification E.==. E.val qid
+              -- E.&&. E.notExists (do
-                  E.&&. luser E.^. LmsUserEnded         E.<.  E.justVal auditCutoff
+              --         laudit <- E.from $ E.table @LmsAudit
-                  E.&&. E.isJust (luser E.^. LmsUserEnded)
+              --         E.where_ $  laudit E.^. LmsAuditQualification E.==. E.val qid
-                  -- E.&&. E.notExists (do
+              --             E.&&.   laudit E.^. LmsAuditIdent         E.==. luser E.^. LmsUserIdent
-                  --         laudit <- E.from $ E.table @LmsAudit
+              --             E.&&.   laudit E.^. LmsAuditProcessed     E.>=. E.val auditCutoff
-                  --         E.where_ $  laudit E.^. LmsAuditQualification E.==. E.val qid
+              --       )
-                  --             E.&&.   laudit E.^. LmsAuditIdent         E.==. luser E.^. LmsUserIdent
+        pure (luser E.^. LmsUserIdent)
-                  --             E.&&.   laudit E.^. LmsAuditProcessed     E.>=. E.val auditCutoff
+      let delusers = E.unValue <$> delusersVals
-                  --       )
+          numdel = length delusers
-            pure (luser E.^. LmsUserIdent)
+      when (numdel > 0) $ do
-          let delusers = E.unValue <$> delusersVals
+        $logInfoS "LMS" $ "Deleting " <> tshow numdel <> " LmsIdents due to audit duration expiry for qualification " <> qshort
-              numdel = length delusers
+        deleteWhere [LmsUserQualification     ==. qid, LmsUserIdent     <-. delusers]
-          when (numdel > 0) $ do
+        -- deleteWhere [LmsAuditQualification    ==. qid, LmsAuditIdent    <-. delusers]
-            $logInfoS "LMS" $ "Deleting " <> tshow numdel <> " LmsIdents due to audit duration expiry for qualification " <> qshort
+      deleteWhere [LmsReportLogQualification ==. qid, LmsReportLogTimestamp <. auditCutoff ]
-            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
+        -- delete old orphans
-          let auditCutoff = addDiffDaysRollOver (fromMonths $ negate auditDuration) now
+        let auditCutoff = lmsDeletionDate now $ qualificationAuditDuration quali
-          orv_del <- deleteWhereCount [LmsOrphanQualification ==. qid, LmsOrphanSeenLast <. auditCutoff]
+        orv_del <- deleteWhereCount [LmsOrphanQualification ==. qid, LmsOrphanSeenLast <. auditCutoff]
-          when (orv_del > 0) ( $logInfoS "LMS" [st|Orphans removed for #{qshort}: #{tshow orv_del} |] )
+        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

src/Settings.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>,-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
+-- SPDX-FileCopyrightText: 2022-2025 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -316,12 +316,14 @@ data LdapConf = LdapConf
   } deriving (Show)
 
 data LmsConf = LmsConf
-  { lmsUploadHeader       :: Bool
+  { lmsUploadHeader         :: Bool
-  , lmsUploadDelimiter    :: Maybe Char
+  , lmsUploadDelimiter      :: Maybe Char
-  , lmsDownloadHeader     :: Bool
+  , lmsDownloadHeader       :: Bool
-  , lmsDownloadDelimiter  :: Char
+  , lmsDownloadDelimiter    :: Char
-  , lmsDownloadCrLf       :: Bool
+  , lmsDownloadCrLf         :: Bool
-  , lmsDeletionDays       :: Int
+  , 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"
+    lmsUploadHeader         <- o .:  "upload-header"
-    lmsUploadDelimiter    <- o .:? "upload-delimiter"
+    lmsUploadDelimiter      <- o .:? "upload-delimiter"
-    lmsDownloadHeader     <- o .:  "download-header"
+    lmsDownloadHeader       <- o .:  "download-header"
-    lmsDownloadDelimiter  <- o .:  "download-delimiter"
+    lmsDownloadDelimiter    <- o .:  "download-delimiter"
-    lmsDownloadCrLf       <- o .:  "download-cr-lf"
+    lmsDownloadCrLf         <- o .:  "download-cr-lf"
-    lmsDeletionDays       <- o .:  "deletion-days"
+    lmsOrphanDeletionDays   <- o .:  "orphan-deletion-days"
+    lmsOrphanDeletionBatch  <- o .:  "orphan-deletion-batch"
+    lmsOrphanRepeatHours    <- o .:  "orphan-deletion-repeat-hours"
     return LmsConf{..}
 
 makeLenses_ ''LmsConf

templates/lms.hamlet

@@ -14,19 +14,12 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
     <dt .deflist__dt>_{MsgQualificationValidDuration}
     <dd .deflist__dd>_{MsgMonths (fromIntegral dvalid)}
 
-  $maybe daudit <- qualificationAuditDuration quali
+  <dt .deflist__dt>_{MsgQualificationAuditDuration} ^{iconTooltip (msg2widget MsgQualificationAuditDurationTooltip) Nothing True}
-    <dt .deflist__dt>_{MsgQualificationAuditDuration} ^{iconTooltip (msg2widget (MsgQualificationAuditDurationTooltip lmsDeletionDays)) Nothing True}
+  <dd .deflist__dd>
-    <dd .deflist__dd>
-      $maybe lqre <- lmsQualiReused
-        $maybe daudit <- qualificationAuditDuration lqre
-          _{MsgMonths (fromIntegral daudit)}
-      $nothing
-        _{MsgMonths (fromIntegral daudit)}
-  $nothing
     $maybe lqre <- lmsQualiReused
-      $maybe daudit <- qualificationAuditDuration lqre
+        _{MsgDays (fromIntegral (qualificationAuditDuration lqre))}
-        <dt .deflist__dt>_{MsgQualificationAuditDuration} ^{iconTooltip (msg2widget (MsgQualificationAuditDurationTooltip lmsDeletionDays)) Nothing True}
+    $nothing
-        <dd .deflist__dd>_{MsgMonths (fromIntegral daudit)}
+        _{MsgDays (fromIntegral (qualificationAuditDuration quali))}
 
   $maybe drefresh <- qualificationRefreshWithin quali
     <dt .deflist__dt>_{MsgQualificationRefreshWithin} ^{iconTooltip (msg2widget  MsgQualificationRefreshWithinTooltip) Nothing True}

templates/qualification.hamlet

@@ -15,21 +15,12 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
       <dt .deflist__dt>_{MsgQualificationValidDuration}
       <dd .deflist__dd>_{MsgMonths (fromIntegral dvalid)}
 
-    $maybe daudit <- qualificationAuditDuration quali
+    <dt .deflist__dt>_{MsgQualificationAuditDuration}
-      <dt .deflist__dt>_{MsgQualificationAuditDuration}
+    <dd .deflist__dd>
-      <dd .deflist__dd>
-        $maybe lqre <- lmsQualiReused
-          $maybe daudit <- qualificationAuditDuration lqre
-            _{MsgMonths (fromIntegral daudit)}
-          $nothing
-            _{MsgQualificationAuditDurationReuseNoTime}
-        $nothing
-          _{MsgMonths (fromIntegral daudit)}
-    $nothing
       $maybe lqre <- lmsQualiReused
-        $maybe daudit <- qualificationAuditDuration lqre
+        _{MsgDays (fromIntegral (qualificationAuditDuration lqre))}
-          <dt .deflist__dt>_{MsgQualificationAuditDuration}
+      $nothing
-          <dd .deflist__dd>_{MsgMonths (fromIntegral daudit)}
+        _{MsgDays (fromIntegral (qualificationAuditDuration quali))}
 
     $maybe drefresh <- qualificationRefreshWithin quali
       <dt .deflist__dt>_{MsgQualificationRefreshWithin} ^{iconTooltip (msg2widget MsgQualificationRefreshWithinTooltip) Nothing True}

test/Database/Fill.hs

@@ -754,10 +754,10 @@ fillDb = do
   let r_descr = Just $ htmlToStoredMarkup [shamlet|<p>Berechtigung zum Führen eines Fahrzeuges auf dem gesamten Rollfeld.|]
   let l_descr = Just $ htmlToStoredMarkup [shamlet|<p>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_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) (Just 6) (Just $ CalendarDiffDays 2 3)  Nothing False False Nothing Nothing False (Just AvsLicenceRollfeld) $ Just "R2801"
+  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) (Just 4) (Just $ CalendarDiffDays 2 3)  Nothing False False Nothing (Just qid_r) False (Just AvsLicenceRollfeld) $ Just "R2802"
+  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   (Just 6) Nothing Nothing True False Nothing Nothing True Nothing Nothing
+  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)