refactor(lms): show deletion days parameter and ensure audit log period is accounted for

messages/uniworx/categories/qualification/de-de-formal.msg

@@ -8,7 +8,7 @@ QualificationDescription: Beschreibung
 QualificationValidIndicator: Gültigkeit
 QualificationValidDuration: Gültigkeitsdauer
 QualificationAuditDuration: Aufbewahrung Audit Log
-QualificationAuditDurationTooltip: Optionaler Zeitraum zur Löschung von E‑Learning Daten. Hiweis: Der E‑Learning Server kann seine anonymisierten Daten schon früher löschen.
+QualificationAuditDurationTooltip n@Int: Optionaler Zeitraum zur Löschung von E‑Learning Daten. Hinweis: Der E‑Learning Server kann seine anonymisierten Daten schon früher löschen, aber spätestens #{n} Tage nach Abschluss.
 QualificationRefreshWithin: Erneurerungszeitraum
 QualificationRefreshWithinTooltip: Optionaler Zeitraum vor Ablauf für automatischen Start des E‑Learnings und Versand einer Benachrichtigung per Brief oder Email.
 QualificationRefreshReminder: 2. Erinnerung

messages/uniworx/categories/qualification/en-eu.msg

@@ -8,7 +8,7 @@ QualificationDescription: Description
 QualificationValidIndicator: Validity
 QualificationValidDuration: Validity period
 QualificationAuditDuration: Audit log keept
-QualificationAuditDurationTooltip: Optional period for deletion of e‑learning data. Note that the e‑learning server may delete its anonymised data earlier.
+QualificationAuditDurationTooltip n@Int: Optional period for deletion of e‑learning data. Note that the e‑learning server may delete its anonymised data earlier, at most #{n} days after closing.
 QualificationRefreshWithin: Refresh within
 QualificationRefreshWithinTooltip: Optional period before expiry to start e‑learning and send a notification by post or email.
 QualificationRefreshReminder: 2. Reminder

src/Handler/LMS.hs

@@ -104,9 +104,10 @@ postLmsAllR = do
               , formEncoding = btnEnctype
               , formSubmit   = FormNoSubmit
               }
-  
+
+  LmsConf{lmsDeletionDays} <- getsYesod $ view _appLmsConf
   lmsTable <- runDB $ do
-    view _2 <$> mkLmsAllTable isAdmin
+    view _2 <$> mkLmsAllTable isAdmin lmsDeletionDays
   siteLayoutMsg MsgMenuLms $ do
     setTitleI   MsgMenuLms
     $(widgetFile "lms-all")
@@ -122,8 +123,8 @@ resultAllQualificationTotal  :: Lens' AllQualificationTableData Word64
 resultAllQualificationTotal  = _dbrOutput . _3 . _unValue
 
   
-mkLmsAllTable :: Bool -> DB (Any, Widget)
-mkLmsAllTable isAdmin = do
+mkLmsAllTable :: Bool -> Int -> DB (Any, Widget)
+mkLmsAllTable isAdmin lmsDeletionDays = do
   svs <- getSupervisees   
   let
     resultDBTable = DBTable{..}
@@ -160,7 +161,7 @@ mkLmsAllTable isAdmin = do
           -- , sortable Nothing (i18nCell MsgQualificationRefreshWithin)   $ foldMap textCell . view (resultAllQualification . _qualificationRefreshWithin . to formatCalendarDiffDays) -- does not work, since there is a maybe in between
           , sortable Nothing (i18nCell MsgQualificationRefreshReminder  & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $
               foldMap (textCell . formatCalendarDiffDays             ) . view (resultAllQualification . _qualificationRefreshReminder)
-          , sortable Nothing (i18nCell MsgQualificationAuditDuration    & cellTooltips [SomeMessage MsgQualificationAuditDurationTooltip, SomeMessage MsgTableDiffDaysTooltip]) $
+          , sortable Nothing (i18nCell MsgQualificationAuditDuration    & cellTooltips [SomeMessage (MsgQualificationAuditDurationTooltip lmsDeletionDays), SomeMessage MsgTableDiffDaysTooltip]) $
               foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationAuditDuration)
           , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart)
                                                                         $ tickmarkCell . view (resultAllQualification . _qualificationElearningStart)
@@ -790,6 +791,7 @@ postLmsR sid qsh = do
   let heading = citext2widget $ "LMS " <> qualificationName quali
   siteLayout heading $ do
     setTitle $ toHtml $ "LMS " <> unSchoolKey sid <> "-" <> qsh
+    LmsConf{lmsDeletionDays} <- getsYesod $ view _appLmsConf
     $(widgetFile "lms")
 
 -- redirect to a specific lms user

src/Handler/LMS/Learners.hs

@@ -90,9 +90,8 @@ instance CsvColumnsExplained LmsUserTableCsv where
 
 
 
-mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
-mkUserTable _sid qsh qid = do
-  cutoff <- liftHandler lmsDeletionDate
+mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> UTCTime -> DB (Any, Widget)
+mkUserTable _sid qsh qid cutoff = do
   dbtCsvName <- csvFilenameLmsUser qsh  
   let dbtCsvSheetName = dbtCsvName
   let
@@ -158,25 +157,31 @@ mkUserTable _sid qsh qid = do
       & defaultSorting [SortAscBy csvLmsIdent]
   dbTable userDBTableValidator userDBTable
 
+getQidCutoff ::  SchoolId -> QualificationShorthand -> DB (QualificationId, UTCTime)
+getQidCutoff sid qsh = do
+  Entity{entityKey = qid, entityVal = Qualification{qualificationAuditDuration=auditDur}} <- getBy404 $ SchoolQualificationShort sid qsh
+  cutoff <- liftHandler $ lmsDeletionDate auditDur
+  return (qid, cutoff)
+
 getLmsLearnersR :: SchoolId -> QualificationShorthand -> Handler Html
 getLmsLearnersR sid qsh = do
   lmsTable <- runDB $ do
-    qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
-    view _2 <$> mkUserTable sid qsh qid
+    (qid, cutoff) <- getQidCutoff sid qsh    
+    view _2 <$> mkUserTable sid qsh qid cutoff
   siteLayoutMsg MsgMenuLmsLearners $ do
     setTitleI MsgMenuLmsLearners
     lmsTable
 
 getLmsLearnersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent
 getLmsLearnersDirectR sid qsh = do
-  $logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid
-  cutoff <- lmsDeletionDate
-  lms_users <- runDB $ do
-    qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
-    selectList [ LmsUserQualification ==. qid
-               , LmsUserEnded ==. Nothing
-               -- , LmsUserReceived ==. Nothing ||. LmsUserResetPin ==. True ||. LmsUserStatus !=. Nothing -- send delta only NOTE: know-how no longer expects delta
-               ] [Asc LmsUserStarted, Asc LmsUserIdent]    
+  $logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid  
+  (lms_users,cutoff) <- runDB $ do
+    (qid, cutoff) <- getQidCutoff sid qsh    
+    lms_users <- selectList [ LmsUserQualification ==. qid
+                            , LmsUserEnded ==. Nothing
+                            -- , LmsUserReceived ==. Nothing ||. LmsUserResetPin ==. True ||. LmsUserStatus !=. Nothing -- send delta only NOTE: know-how no longer expects delta
+                            ] [Asc LmsUserStarted, Asc LmsUserIdent]    
+    return (lms_users, cutoff)
 
     {- To avoid exporting unneeded columns, we would need an SqlSelect instance for LmsUserTableCsv; probably not worth it
       Ex.select $ do

src/Handler/LMS/Users.hs

@@ -83,7 +83,7 @@ instance CsvColumnsExplained LmsUserTableCsv where
 
 mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
 mkUserTable _sid qsh qid = do
-  cutoff <- liftHandler lmsDeletionDate
+  cutoff <- liftHandler $ lmsDeletionDate Nothing
   dbtCsvName <- csvFilenameLmsUser qsh  
   let dbtCsvSheetName = dbtCsvName
   let
@@ -154,7 +154,7 @@ getLmsUsersR sid qsh = do
 getLmsUsersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent
 getLmsUsersDirectR sid qsh = do
   $logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid
-  cutoff <- lmsDeletionDate
+  cutoff <- lmsDeletionDate Nothing
   lms_users <- runDB $ do
     qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
     selectList [ LmsUserQualification ==. qid

src/Handler/Utils/DateTime.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 

src/Handler/Utils/LMS.hs

@@ -130,11 +130,16 @@ makeLmsFilename ftag (citext2lower -> qsh) = do
 getYMTH :: MonadHandler m => m Text
 getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime
 
---
-lmsDeletionDate :: Handler UTCTime
-lmsDeletionDate = do
+-- | Given the QualificationAuditDuration, determines the time to signal the deletion of an LMS User to the e-learning server. Note that the e-learning server ought to delete LMS users on its own
+lmsDeletionDate :: Maybe Int -> Handler UTCTime
+lmsDeletionDate mbMaxAuditMonths = do
+  now <- liftIO getCurrentTime
   LmsConf{lmsDeletionDays} <- getsYesod $ view _appLmsConf
-  addLocalDays (fromIntegral $ negate lmsDeletionDays) <$> liftIO getCurrentTime
+  let ldd = addDiffDaysRollOver (fromDays $ negate lmsDeletionDays) now
+  return $ case mbMaxAuditMonths of
+    Nothing -> ldd
+    (Just maxAuditMonths) -> 
+      max ldd (addDiffDaysRollOver (fromMonths $ negate maxAuditMonths) now)
 
 -- | Decide whether LMS platform should delete an identifier
 lmsUserToDeleteExpr :: UTCTime -> E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool)

templates/lms.hamlet

@@ -1,6 +1,6 @@
 $newline never
 
-$# SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+$# SPDX-FileCopyrightText: 2022-23 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
 $#
 $# SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -15,11 +15,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
     <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>_{MsgMonths (fromIntegral daudit)}      
 
   $maybe drefresh <- qualificationRefreshWithin quali
-    <dt .deflist__dt>_{MsgQualificationRefreshWithin} ^{iconTooltip (msg2widget MsgQualificationRefreshWithinTooltip) Nothing True}
+    <dt .deflist__dt>_{MsgQualificationRefreshWithin} ^{iconTooltip (msg2widget  MsgQualificationRefreshWithinTooltip) Nothing True}
     <dd .deflist__dd>
       $with drm <- cdMonths drefresh
         $with drd <- cdDays drefresh