fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(lms): complete view for orphaned lms logins

Browse Source 
towards #2605
This commit is contained in:
Steffen Jost 2025-02-04 13:17:23 +01:00 committed by Sarah Vaupel
parent fbd99f2394
commit d5bbec9fa3
6 changed files with 102 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
messages/uniworx/categories/qualification/de-de-formal.msg
View File

@ -164,4 +164,4 @@ LmsOrphanSeenFirst: Zuerst erkannt
LmsOrphanSeenLast: Zuletzt erhalten
LmsOrphanDeletedLast: Zuletzt Löschung beantragt
LmsOrphanReason: Bemerkung
LmsOrphanPreviewFltr: Vorschau Löschungen bei nächstem Abruf
LmsOrphanPreviewFltr: Löschungen bei nächstem Abruf anfordern?

2
messages/uniworx/categories/qualification/en-eu.msg
View File

@ -164,4 +164,4 @@ LmsOrphanSeenFirst: First seen
LmsOrphanSeenLast: Last seen
LmsOrphanDeletedLast: Deletion requested
LmsOrphanReason: Note
LmsOrphanPreviewFltr: Preview deletions next synch
LmsOrphanPreviewFltr: Deletion request next synch?

88
src/Handler/LMS/Learners.hs
View File

@ -38,7 +38,7 @@ makeLenses_ ''LmsUserTableCsv
lmsUserDelete2csv :: LmsIdent -> LmsUserTableCsv
lmsUserDelete2csv lid = LmsUserTableCsv
{ csvLUTident = lid
, csvLUTpin = "12345678"
, csvLUTpin = "00000000"
, csvLUTresetPin = LmsBool False
, csvLUTdelete = LmsBool True
, csvLUTstaff = LmsBool False
@ -186,31 +186,27 @@ getLmsLearnersR sid qsh = do
lmsTable
data OrphanParams = OrphanParams { cutoff_seen_first, cutoff_deleted_last, cutoff_seen_last :: UTCTime, orphan_max_batch :: Int64 }
deriving (Show, Generic, Binary)
selectOrphans :: QualificationId -> UTCTime -> DB ([Entity LmsOrphan], OrphanParams)
selectOrphans :: QualificationId -> UTCTime -> DB [(LmsOrphanId, LmsIdent)]
selectOrphans qid now = do
lmsConf <- getsYesod $ view _appLmsConf
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
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
return (orphans, OrphanParams{..})
lmsConf <- getsYesod $ view _appLmsConf
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
$(E.unValueN 2) <<$>> ( 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 E.^. LmsOrphanId, orv E.^. LmsOrphanIdent)
)
getLmsLearnersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent
getLmsLearnersDirectR sid qsh = do
@ -238,15 +234,15 @@ getLmsLearnersDirectR sid qsh = do
}
-}
now <- liftIO getCurrentTime
orphans <- fst <$> selectOrphans qid now
updateWhere [LmsOrphanId <-. fmap entityKey orphans] [LmsOrphanDeletedLast =. Just now]
orphans <- selectOrphans qid now
updateWhere [LmsOrphanId <-. map fst orphans] [LmsOrphanDeletedLast =. Just now]
return (lms_users, orphans, cutoff, qshs)
LmsConf{..} <- getsYesod $ view _appLmsConf
let --csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users
--csvRenderedHeader = lmsUserTableCsvHeader
--cvsRendered = CsvRendered {..}
csvRendered = toCsvRendered lmsUserTableCsvHeader $ (lmsUser2csv cutoff . entityVal <$> lms_users) <> (lmsUserDelete2csv . lmsOrphanIdent . entityVal <$> orphans)
csvRendered = toCsvRendered lmsUserTableCsvHeader $ (lmsUser2csv cutoff . entityVal <$> lms_users) <> (lmsUserDelete2csv . snd <$> orphans)
fmtOpts = (review csvPreset CsvPresetRFC)
{ csvIncludeHeader = lmsDownloadHeader
, csvDelimiter = lmsDownloadDelimiter
@ -266,17 +262,15 @@ getLmsLearnersDirectR sid qsh = do
-- direct Download see:
-- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod
-- TODO: show info about orphan handling;
getLmsOrphansR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsOrphansR sid qsh = do
(orvTable,OrphanParams{..}) <-runDB $ do
now <- liftIO getCurrentTime
orvTable <- runDB $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
(next_orphans, ops) <- $(memcachedByHere) (Just . Right $ 1 * diffMinute) [st|next-orphan-preview-#{tshow qid}|] (over _1 (map entityKey) <$> selectOrphans qid now)
let
orvDBTable = DBTable{..}
where
queryOrphan = id
-- resultOrphan = _dbrOutput . _entityVal -- would need explicit type to work
dbtSQLQuery orv = do
E.where_ $ orv E.^. LmsOrphanQualification E.==. E.val qid
@ -288,24 +282,36 @@ getLmsOrphansR sid qsh = do
, sortable (Just "seen-first") (i18nCell MsgLmsOrphanSeenFirst) $ \(view $ _dbrOutput . _entityVal . _lmsOrphanSeenFirst -> d) -> dateTimeCell d
, sortable (Just "seen-last") (i18nCell MsgLmsOrphanSeenLast) $ \(view $ _dbrOutput . _entityVal . _lmsOrphanSeenLast -> d) -> dateTimeCell d
, sortable (Just "deleted-last") (i18nCell MsgLmsOrphanDeletedLast) $ \(view $ _dbrOutput . _entityVal . _lmsOrphanDeletedLast -> d) -> foldMap dateTimeCell d
, sortable (Just "note") (i18nCell MsgLmsOrphanReason) $ \(view $ _dbrOutput . _entityVal . _lmsOrphanReason -> t) -> foldMap textCell t
, sortable (Just "reason") (i18nCell MsgLmsOrphanReason) $ \(view $ _dbrOutput . _entityVal . _lmsOrphanReason -> t) -> foldMap textCell t
]
dbtSorting = Map.fromList
[ ("ident" , SortColumn (E.^. LmsOrphanIdent))
, ("seen-first" , SortColumn (E.^. LmsOrphanSeenFirst))
, ("seen-last" , SortColumn (E.^. LmsOrphanSeenLast))
, ("deleted-last" , SortColumn (E.^. LmsOrphanDeletedLast))
, ("reason" , SortColumn (E.^. LmsOrphanReason))
]
dbtFilter = Map.fromList
[ ("preview" , FilterColumn $ \row (getLast -> criterion) -> case criterion of
Just True -> (row E.^. LmsOrphanId) `E.in_` E.valList next_orphans
_ -> E.true
[ ("preview" , FilterColumnHandler $ \case
(x:_)
| x == tshow True -> do
now <- liftIO getCurrentTime
next_orphans <- runDB $ selectOrphans qid now -- only query next orphans when really needed; not sure how to formulate a proper sub-query here
-- addMessageI Info $ MsgLmsOrphanNr $ length next_orphans -- debug
return $ \row -> (queryOrphan row E.^. LmsOrphanId) `E.in_` E.valList (map fst next_orphans)
| x == tshow False -> do
now <- liftIO getCurrentTime
next_orphans <- runDB $ selectOrphans qid now
return $ \row -> (queryOrphan row E.^. LmsOrphanId) `E.notIn` E.valList (map fst next_orphans)
_ -> return (const E.true)
)
, ("ident" , FilterColumn $ E.mkContainsFilterWithCommaPlus LmsIdent (E.^. LmsOrphanIdent))
]
dbtFilterUI = \mPrev -> mconcat
[ prismAForm (singletonFilter "ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent & setTooltip MsgTableFilterCommaPlus)
, prismAForm (singletonFilter "preview" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgLmsOrphanPreviewFltr)
-- checkBoxTextField = convertField show (\case { t | t == show True -> True; _ -> False }) checkBoxField -- UNNECESSARY hack to use FilterColumnHandler, which only works on [Text] criteria
dbtFilterUI mPrev = mconcat
[ prismAForm (singletonFilter "ident" . maybePrism _PathPiece) mPrev $ aopt textField (fslI MsgTableLmsIdent & setTooltip MsgTableFilterCommaPlus)
-- , prismAForm (singletonFilter "preview" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgLmsOrphanPreviewFltr) -- NOTE: anticipated checkBoxTextField-hack not needed here
, prismAForm (singletonFilter "preview" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgLmsOrphanPreviewFltr)
]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtParams = def
@ -315,9 +321,9 @@ getLmsOrphansR sid qsh = do
dbtCsvDecode = Nothing
dbtExtraReps = []
orvDBTableValidator = def & defaultSorting [SortAscBy "seen-first", SortDescBy "deleted-last"]
tbl <- snd <$> (dbTable orvDBTableValidator orvDBTable :: DB (Any, Widget))
return (tbl,ops)
snd <$> (dbTable orvDBTableValidator orvDBTable :: DB (Any, Widget))
LmsConf{..} <- getsYesod $ view _appLmsConf
siteLayoutMsg MsgLmsOrphans $ do
setTitleI MsgLmsOrphans
$(i18nWidgetFile "lms-orphans")

29
templates/i18n/lms-orphans/de-de-formal.hamlet
View File

@ -5,12 +5,29 @@ $#
$# SPDX-License-Identifier: AGPL-3.0-or-later
<section>
TODO Info about LMS Oprhan handling
<ul>
<li> #{tshow cutoff_seen_first}
<li> #{tshow cutoff_deleted_last}
<li> #{tshow cutoff_seen_last}
<li> #{tshow orphan_max_batch}
<p>
Gezeigt werden E‑Learning Logins, welche für diese Qualifikation an FRADrive zurückgemeldet wurden #
und von FRADrive nicht mehr zugeordnet werden können. #
Normalerweise löscht das LMS beendete E‑Learning Logins selbstständig. #
In manchen Fällen passiert dies aus unbekanntem Grund jedoch nicht. #
Wenn jedoch ein Grund bekannt sein sollte, wie zum Beispiel ein manueller Neustart des E‑Learnings, #
wird dieser in Spalte "_{MsgLmsOrphanReason}" angezeigt. #
<p>
Verwaiste Logins werden beim nächsten Abruf der E‑Learning Logins von FRADrive zur Löschung durch das LMS gemeldet. #
Die Auswahl, ob ein E‑Learning Login zur Löschung gemeldet wird, hängt von folgenden Kriterien ab: #
<ul>
<li>"_{MsgLmsOrphanSeenFirst}" liegt mindestens #{lmsOrphanDeletionDays} Tage zurück
<li>"_{MsgLmsOrphanSeenLast}" liegt höchstens #{lmsOrphanRepeatHours} Stunden zurück
<li>"_{MsgLmsOrphanDeletedLast}", d.h. der letzte Löschantrag für diesen Login ist älter als #{lmsOrphanRepeatHours} Stunden #
oder wurde noch gar nicht gestellt
<li>Der E‑Learning Login ist auch unter keiner anderen Qualifikation in FRADrive bekannt
<p>
Es werden jedoch pro Abruf nur #{lmsOrphanDeletionBatch} E‑Learning Logins zur Löschung an das LMS gemeldet. #
Dabei werden Logins bevorzugt welche noch gar nicht oder vor der längsten Zeit gemeldet wurden ("_{MsgLmsOrphanDeletedLast}"), #
sollte davon es jeweils mehrere Kandidaten geben, dann werden diejenigen ausgewählt, welche kürzlich zurückgemeldet wurden ("_{MsgLmsOrphanSeenLast}").
<section>
<p>
^{orvTable}

31
templates/i18n/lms-orphans/en-eu.hamlet
View File

@ -5,14 +5,29 @@ $#
$# SPDX-License-Identifier: AGPL-3.0-or-later
<section>
TODO
<ul>
<li> #{tshow cutoff_seen_first}
<li> #{tshow cutoff_deleted_last}
<li> #{tshow cutoff_seen_last}
<li> #{tshow orphan_max_batch}
<p>
Displayed are e‑learning logins that have been reported back to FRADrive for this qualification, #
but which are unknown to FRADrive. #
Normally, the LMS automatically deletes completed e‑learning logins. #
In some cases, however, this does not happen for unknown reasons. #
If a reason is known, such as a manual restart of the e‑learning, #
this is shown in the column "_{MsgLmsOrphanReason}". #
<p>
Orphaned logins will be reported for deletion by FRADrive to the LMS during the next retrieval of e‑learning logins. #
The decision whether an e‑learning login is reported for deletion depends on the following criteria: #
<ul>
<li>"_{MsgLmsOrphanSeenFirst}" is at least #{lmsOrphanDeletionDays} days ago
<li>"_{MsgLmsOrphanSeenLast}" is at most #{lmsOrphanRepeatHours} hours ago
<li>"_{MsgLmsOrphanDeletedLast}", i.e., the last deletion request for this login is older than #{lmsOrphanRepeatHours} hours #
or has not been made yet
<li>The e‑learning login is not associated with any other qualification within FRADrive
<p>
However, only #{lmsOrphanDeletionBatch} e‑learning logins are reported for deletion to the LMS per request. #
Logins that have not yet been reported for deletion at all or were reported the longest time ago ("_{MsgLmsOrphanDeletedLast}") are preferred, #
if there are multiple candidates, those that were most recently reported back ("_{MsgLmsOrphanSeenLast}") will be selected.
<section>
<p>
^{orvTable}
^{orvTable}

7
test/Database/Fill.hs
View File

@ -796,6 +796,13 @@ fillDb = do
void . insert' $ LmsUser qid_f maxMuster (LmsIdent "xyz") "a1b2c3" False now (Just LmsBlocked) (Just $ n_day' (-11)) (n_day' (-4)) (Just $ n_day' (-2)) (Just $ n_day' (-2)) Nothing True True
void . insert' $ LmsUser qid_f fhamann (LmsIdent "123") "456" False now Nothing Nothing now Nothing Nothing Nothing False False
void . insert' $ LmsOrphan qid_f (LmsIdent "no-del-1") now now Nothing (Just "should show, no transmit")
void . insert' $ LmsOrphan qid_f (LmsIdent "do-del-2") (n_day' (-128)) now Nothing (Just "should show, do transmit")
void . insert' $ LmsOrphan qid_f (LmsIdent "no-del-3") (n_day' (-128)) (n_day' (-100)) Nothing (Just "should show, no transmit")
void . insert' $ LmsOrphan qid_f (LmsIdent "no-del-4") (n_day' (-128)) now (Just now) (Just "should show, no transmit")
void . insert' $ LmsOrphan qid_f (LmsIdent "do-del-5") (n_day' (-128)) now (Just (n_day' (-100))) (Just "should show, do transmit")
void . insert' $ LmsOrphan qid_f (LmsIdent "no-del-6") (n_day' ( -5)) now (Just (n_day' ( -3))) (Just "should show, no transmit")
void . insert $ PrintJob "TestJob1" "AckTestJob1" "job1" "No Text herein." (n_day' (-1)) Nothing Nothing Nothing (Just svaupel) Nothing (Just qid_f) Nothing
void . insert $ PrintJob "TestJob2" "AckTestJob2" "job2" "No Text herein." (n_day' (-3)) (Just $ n_day' (-1)) (Just jost) (Just svaupel) Nothing Nothing (Just qid_f) (Just $ LmsIdent "ijk")
void . insert $ PrintJob "TestJob3" "AckTestJob3" "job3" "No Text herein." (n_day' (-2)) Nothing Nothing Nothing Nothing Nothing Nothing Nothing