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:
This commit is contained in:
parent
0ffd594a04
commit
e9fefa75bd
@ -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-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"
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
[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
|
||||
]
|
||||
|
||||
@ -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
|
||||
-- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod
|
||||
|
||||
@ -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 _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
|
||||
|
||||
@ -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!
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
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
|
||||
<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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
, 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
|
||||
|
||||
@ -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 lmsDeletionDays)) Nothing True}
|
||||
<dd .deflist__dd>
|
||||
$maybe lqre <- lmsQualiReused
|
||||
$maybe daudit <- qualificationAuditDuration lqre
|
||||
_{MsgMonths (fromIntegral daudit)}
|
||||
$nothing
|
||||
_{MsgMonths (fromIntegral daudit)}
|
||||
$nothing
|
||||
<dt .deflist__dt>_{MsgQualificationAuditDuration} ^{iconTooltip (msg2widget MsgQualificationAuditDurationTooltip) Nothing True}
|
||||
<dd .deflist__dd>
|
||||
$maybe lqre <- lmsQualiReused
|
||||
$maybe daudit <- qualificationAuditDuration lqre
|
||||
<dt .deflist__dt>_{MsgQualificationAuditDuration} ^{iconTooltip (msg2widget (MsgQualificationAuditDurationTooltip lmsDeletionDays)) Nothing True}
|
||||
<dd .deflist__dd>_{MsgMonths (fromIntegral daudit)}
|
||||
_{MsgDays (fromIntegral (qualificationAuditDuration lqre))}
|
||||
$nothing
|
||||
_{MsgDays (fromIntegral (qualificationAuditDuration quali))}
|
||||
|
||||
$maybe drefresh <- qualificationRefreshWithin quali
|
||||
<dt .deflist__dt>_{MsgQualificationRefreshWithin} ^{iconTooltip (msg2widget MsgQualificationRefreshWithinTooltip) Nothing True}
|
||||
|
||||
@ -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}
|
||||
<dd .deflist__dd>
|
||||
$maybe lqre <- lmsQualiReused
|
||||
$maybe daudit <- qualificationAuditDuration lqre
|
||||
_{MsgMonths (fromIntegral daudit)}
|
||||
$nothing
|
||||
_{MsgQualificationAuditDurationReuseNoTime}
|
||||
$nothing
|
||||
_{MsgMonths (fromIntegral daudit)}
|
||||
$nothing
|
||||
<dt .deflist__dt>_{MsgQualificationAuditDuration}
|
||||
<dd .deflist__dd>
|
||||
$maybe lqre <- lmsQualiReused
|
||||
$maybe daudit <- qualificationAuditDuration lqre
|
||||
<dt .deflist__dt>_{MsgQualificationAuditDuration}
|
||||
<dd .deflist__dd>_{MsgMonths (fromIntegral daudit)}
|
||||
_{MsgDays (fromIntegral (qualificationAuditDuration lqre))}
|
||||
$nothing
|
||||
_{MsgDays (fromIntegral (qualificationAuditDuration quali))}
|
||||
|
||||
$maybe drefresh <- qualificationRefreshWithin quali
|
||||
<dt .deflist__dt>_{MsgQualificationRefreshWithin} ^{iconTooltip (msg2widget MsgQualificationRefreshWithinTooltip) Nothing True}
|
||||
|
||||
@ -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_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)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user