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

chore(lms): register and display orphaned LMS idents

Browse Source 
towards #2605
This commit is contained in:
Steffen Jost 2025-01-31 17:31:21 +01:00 committed by Sarah Vaupel
parent ab340aa715
commit 0ffd594a04
6 changed files with 96 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -157,4 +157,7 @@ QualificationCreated qsh@Text: Qualifikation #{qsh} wurde angelegt.
QualificationEdit qsh@Text: Qualifikation #{qsh} wurde geändert.
QualFormErrorDuplShort qsh@Text: Es gibt bereits eine Qualifikation mit Kürzel #{qsh}!
QualFormErrorDuplName qname@Text: Es gibt bereits eine Qualifikation mit Namen #{qname}!
QualFormErrorSshMismatch: Qualifikationänderungsformular enthält unglültige Bereichsangabe. Bitte versuchen Sie erneut, nachdem Sie Seite neu geladen haben.
QualFormErrorSshMismatch: Qualifikationänderungsformular enthält unglültige Bereichsangabe. Bitte versuchen Sie erneut, nachdem Sie Seite neu geladen haben.
TableLmsOrphanNr: Verwaiste Logins
LmsOrphanNr n@Int: #{n} verwaiste E‑Learning Logins für diese Qualifikation erkannt.

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

@ -157,4 +157,7 @@ QualificationCreated qsh@Text: Qualification #{qsh} created.
QualificationEdit qsh@Text: Qualification #{qsh} edited.
QualFormErrorDuplShort qsh@Text: There already exists a qualification with shorthand #{qsh}!
QualFormErrorDuplName qname@Text: There already exists a qualification with name #{qname}!
QualFormErrorSshMismatch: Qualification edit form department mismatch. Please try again after reloading the page.
QualFormErrorSshMismatch: Qualification edit form department mismatch. Please try again after reloading the page.
TableLmsOrphanNr: Orphaned logins
LmsOrphanNr n@Int: #{n} orphaned e‑learning login detected for this qualification.

11
models/lms.model
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022-23 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-25 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -163,4 +163,13 @@ LmsReportLog
lock Bool -- (0|1)
timestamp UTCTime default=now()
missing Bool default=false
deriving Generic Show
-- Table to manage unknown or orphaned lms identifiers
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
UniqueLmsOrphan qualification ident -- unlike other tables, LMS Idents must only be unique within qualification, allowing orphans to be handled independently
deriving Generic Show

15
src/Handler/LMS.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022-25 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-25 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -98,7 +98,7 @@ postLmsAllR = do
setTitleI MsgMenuLms
$(i18nWidgetFile "lms-all")
type AllQualificationTableData = DBRow (Entity Qualification, Ex.Value Word64, Ex.Value Word64)
type AllQualificationTableData = DBRow (Entity Qualification, Ex.Value Word64, Ex.Value Word64, Ex.Value Word64)
resultAllQualification :: Lens' AllQualificationTableData Qualification
resultAllQualification = _dbrOutput . _1 . _entityVal
@ -108,6 +108,9 @@ resultAllQualificationActive = _dbrOutput . _2 . _unValue
resultAllQualificationTotal :: Lens' AllQualificationTableData Word64
resultAllQualificationTotal = _dbrOutput . _3 . _unValue
resultAllQualificationOrphans :: Lens' AllQualificationTableData Word64
resultAllQualificationOrphans = _dbrOutput . _4 . _unValue
mkLmsAllTable :: Bool -> Int -> DB (Any, Widget)
mkLmsAllTable isAdmin lmsDeletionDays = do
@ -123,9 +126,12 @@ mkLmsAllTable isAdmin lmsDeletionDays = do
Ex.where_ $ filterSvs luser
cactive = Ex.subSelectCount $ do
luser <- Ex.from $ Ex.table @LmsUser
Ex.where_ $ filterSvs luser Ex.&&. E.isNothing (luser E.^. LmsUserStatus)
Ex.where_ $ filterSvs luser Ex.&&. E.isNothing (luser Ex.^. LmsUserStatus)
corphans = Ex.subSelectCount $ do
lorphan <- Ex.from $ Ex.table @LmsOrphan
Ex.where_ $ lorphan Ex.^. LmsOrphanQualification Ex.==. quali Ex.^. QualificationId
-- Failed attempt using Join/GroupBy instead of subselect: see branch csv-osis-demo-groupby-problem
return (quali, cactive, cusers)
return (quali, cactive, cusers, corphans)
dbtRowKey = (Ex.^. QualificationId)
dbtProj = dbtProjId
adminable = if isAdmin then sortable else \_ _ _ -> mempty
@ -172,6 +178,7 @@ mkLmsAllTable isAdmin lmsDeletionDays = do
$ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n
, adminable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal
-- \(view resultAllQualificationTotal -> n) -> wgtCell $ word2widget n
, adminable Nothing (i18nCell MsgTableLmsOrphanNr) $ wgtCell . word2widget . view resultAllQualificationOrphans
]
dbtSorting = mconcat
[

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

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2023 Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2023-25 Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -34,6 +34,17 @@ data LmsUserTableCsv = LmsUserTableCsv -- for csv export only
deriving Generic
makeLenses_ ''LmsUserTableCsv
lmsUserDelete2csv :: LmsIdent -> LmsUserTableCsv
lmsUserDelete2csv lid = LmsUserTableCsv
{ csvLUTident = lid
, csvLUTpin = "12345678"
, csvLUTresetPin = LmsBool False
, csvLUTdelete = LmsBool True
, csvLUTstaff = LmsBool False
, csvLUTresetTries= LmsBool False
, csvLUTlock = LmsBool True
}
-- | Mundane conversion needed for direct download without dbTable only
lmsUser2csv :: UTCTime -> LmsUser -> LmsUserTableCsv
lmsUser2csv cutoff lu@LmsUser{..} = LmsUserTableCsv
@ -162,9 +173,12 @@ getQidCutoff sid qsh = do
getLmsLearnersR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsLearnersR sid qsh = do
lmsTable <- runDB $ do
(lmsTable, nr_orphans) <- runDB $ do
(qid, cutoff) <- getQidCutoff sid qsh
view _2 <$> mkUserTable sid qsh qid cutoff
lmsTable <- view _2 <$> mkUserTable sid qsh qid cutoff
nr_orphans <- count [LmsOrphanQualification ==. qid]
return (lmsTable, nr_orphans)
when (nr_orphans > 0) $ addMessageI Warning $ MsgLmsOrphanNr nr_orphans
siteLayoutMsg MsgMenuLmsLearners $ do
setTitleI MsgMenuLmsLearners
lmsTable
@ -172,7 +186,7 @@ getLmsLearnersR sid qsh = do
getLmsLearnersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent
getLmsLearnersDirectR sid qsh = do
$logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid
(lms_users,cutoff,qshs) <- runDB $ do
(lms_users, orphans, cutoff, qshs) <- runDB $ do
(qid, cutoff) <- getQidCutoff sid qsh
qidsReuse <- selectList [QualificationLmsReuses ==. Just qid] []
let qids = qid : (entityKey <$> qidsReuse)
@ -181,8 +195,6 @@ getLmsLearnersDirectR sid qsh = do
, 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, qshs)
{- To avoid exporting unneeded columns, we would need an SqlSelect instance for LmsUserTableCsv; probably not worth it
Ex.select $ do
lmsuser <- Ex.from $ Ex.table @LmsUser
@ -196,11 +208,15 @@ getLmsLearnersDirectR sid qsh = do
, csvLUTstaff = LmsBool False
}
-}
now <- liftIO getCurrentTime
orphans <- selectList [LmsOrphanQualification ==. qid, LmsOrphanSeenFirst >. addWeeks (-1) 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
csvRendered = toCsvRendered lmsUserTableCsvHeader $ (lmsUser2csv cutoff . entityVal <$> lms_users) <> (lmsUserDelete2csv . lmsOrphanIdent . entityVal <$> orphans)
fmtOpts = (review csvPreset CsvPresetRFC)
{ csvIncludeHeader = lmsDownloadHeader
, csvDelimiter = lmsDownloadDelimiter
@ -208,8 +224,11 @@ getLmsLearnersDirectR sid qsh = do
}
csvOpts = def { csvFormat = fmtOpts }
csvSheetName <- csvFilenameLmsUser qsh
let nr = length lms_users
msg = "Success. LMS user learners download file " <> csvSheetName <> " containing " <> tshow nr <> " rows for Qualifications " <> Text.intercalate ", " (ciOriginal <$> qshs)
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)
msg1 = ". Orphaned LMS idents marked for deletion: " <> tshow orv_nr
msg = if orv_nr > 0 then msg0 <> msg1 else msg1
$logInfoS "LMS" msg
addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered

48
src/Jobs/Handler/LMS.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022-24 Steffen Jost <s.jost@fraport.de>
-- SPDX-FileCopyrightText: 2022-2025 Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -20,7 +20,7 @@ import Database.Persist.Sql -- (deleteWhereCount, updateWhereCount)
import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E
--import qualified Database.Esqueleto.Legacy as E
-- import qualified Database.Esqueleto.PostgreSQL as E -- for insertSelect variant
import qualified Database.Esqueleto.PostgreSQL as E -- for insertSelectWith variant
import qualified Database.Esqueleto.Utils as E
import qualified Data.Set as Set
@ -139,6 +139,8 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
( (E.^. LmsUserIdent) <$> E.from (E.table @LmsUser ) ) -- no filter by qid, since LmsIdents must be unique across all
`E.union_`
( (E.^. LmsReportIdent) <$> E.from (E.table @LmsReport ) ) -- V2
`E.union_`
( (E.^. LmsOrphanIdent) <$> E.from (E.table @LmsOrphan ) ) -- reported to be in use by lms
E.orderBy [E.asc lui]
pure lui
now <- liftIO getCurrentTime
@ -275,11 +277,13 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
-- act :: YesodJobDB UniWorX ()
act = whenM (exists [LmsReportQualification ==. qid]) $ do -- executing twice must be prohibited due to assertion that ALL learners are always sent (E fails otherwise)
now <- liftIO getCurrentTime
quali <- getJust qid -- may throw an error, aborting the job
-- DEBUG 2rows; remove later
totalrows <- count [LmsReportQualification ==. qid]
$logInfoS "LMS" $ "Report processing " <> tshow totalrows <> " rows for qualification " <> tshow qid
when (totalrows > 0) $ do
let -- locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now -- no longer necessary, since LMS reports dates only
let qshort = qualificationShorthand quali
-- locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now -- no longer necessary, since LMS reports dates only
-- DB query for LmsUserUser, provided a matching LmsReport exists
luserQry luFltr repFltr = E.select $ do
luser <- E.from $ E.table @LmsUser
@ -336,7 +340,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
return $ Sum ok_block
in lrepQry lrFltrBlock
>>= foldMapM procBlock
>>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " status set to blocked for qualification " <> tshow qid -- debug, remove later
>>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " status set to blocked for qualification " <> tshow qshort -- debug, remove later
-- D) renew qualifications for all successfull learners
let lrFltrSuccess luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsPassed
procRenew (Entity luid luser, Entity _ lreport) = do
@ -352,7 +356,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
return $ Sum ok_renew
in lrepQry lrFltrSuccess
>>= foldMapM procRenew
>>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " renewed and status set to success for qualification " <> tshow qid -- debug, remove later
>>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " renewed and status set to success for qualification " <> tshow qshort -- debug, remove later
-- E) mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected)
E.update $ \luser -> do
E.set luser [ LmsUserEnded E.=. E.justVal now ]
@ -390,10 +394,36 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
-- E.&&. lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent
-- E.&&. lreport E.^. LmsReportLock E.==. E.val lockstatus -- Maybe more efficient, but less readable: bool E.not_ id lockstatus (lreport E.^. LmsReport Lock)
updateReceivedLocked False
>>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as unlocked and received for qualification " <> tshow qid -- debug, remove later
>>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as unlocked and received for qualification " <> tshow qshort -- debug, remove later
updateReceivedLocked True
>>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as locked and received for qualification " <> tshow qid -- debug, remove later
-- G) Truncate LmsReport for qid, after updating log
>>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as locked and received for qualification " <> tshow qshort -- debug, remove later
-- G) Upsert/delete orphaned LMS idents
orv_upd <- E.insertSelectWithConflictCount UniqueLmsOrphan
(do
lreport <- E.from $ E.table @LmsReport
E.where_ $ lreport E.^. LmsReportQualification E.==. E.val qid
E.&&. E.notExists (do
luser <- E.from $ E.table @LmsUser
E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent
)
E.distinct $ return $ LmsOrphan
E.<# E.val qid
E.<&> (lreport E.^. LmsReportIdent)
E.<&> E.val now
E.<&> E.val now
)
(\_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} |] )
-- H) Truncate LmsReport for qid, after updating log
E.insertSelect $ do
lreport <- E.from $ E.table @LmsReport
let samelog = E.subSelect $ do
@ -438,4 +468,4 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
E.<&> E.val now
E.<&> E.true)
repProc <- deleteWhereCount [LmsReportQualification ==. qid]
$logInfoS "LMS" [st|Processed #{tshow repProc} e-learning status reports for qualification #{tshow qid}.|]
$logInfoS "LMS" [st|Processed #{tshow repProc} e-learning status reports for qualification #{qshort}.|]