diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 6c903c496..ce59e03ed 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/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 diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 7851b5c84..6e949fc4f 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/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 diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index c06cd68f6..66ccf51a6 100644 --- a/src/Handler/LMS.hs +++ b/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 diff --git a/src/Handler/LMS/Learners.hs b/src/Handler/LMS/Learners.hs index 31f9ce8bd..ff329166e 100644 --- a/src/Handler/LMS/Learners.hs +++ b/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 diff --git a/src/Handler/LMS/Users.hs b/src/Handler/LMS/Users.hs index 389ad16f6..b5f534b5a 100644 --- a/src/Handler/LMS/Users.hs +++ b/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 diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 754110bdb..49cc6a7ba 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index e67fc4e05..29667b1ec 100644 --- a/src/Handler/Utils/LMS.hs +++ b/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) diff --git a/templates/lms.hamlet b/templates/lms.hamlet index acfccaccf..fb38e8e07 100644 --- a/templates/lms.hamlet +++ b/templates/lms.hamlet @@ -1,6 +1,6 @@ $newline never -$# SPDX-FileCopyrightText: 2022 Sarah Vaupel ,Steffen Jost +$# SPDX-FileCopyrightText: 2022-23 Sarah Vaupel ,Steffen Jost $# $# SPDX-License-Identifier: AGPL-3.0-or-later @@ -15,11 +15,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
_{MsgMonths (fromIntegral dvalid)} $maybe daudit <- qualificationAuditDuration quali -
_{MsgQualificationAuditDuration} ^{iconTooltip (msg2widget MsgQualificationAuditDurationTooltip) Nothing True} +
_{MsgQualificationAuditDuration} ^{iconTooltip (msg2widget (MsgQualificationAuditDurationTooltip lmsDeletionDays)) Nothing True}
_{MsgMonths (fromIntegral daudit)} $maybe drefresh <- qualificationRefreshWithin quali -
_{MsgQualificationRefreshWithin} ^{iconTooltip (msg2widget MsgQualificationRefreshWithinTooltip) Nothing True} +
_{MsgQualificationRefreshWithin} ^{iconTooltip (msg2widget MsgQualificationRefreshWithinTooltip) Nothing True}
$with drm <- cdMonths drefresh $with drd <- cdDays drefresh