From 0ffd594a04cd359d905a950398630d7963b3bd2d Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 31 Jan 2025 17:31:21 +0100 Subject: [PATCH] chore(lms): register and display orphaned LMS idents towards #2605 --- .../categories/qualification/de-de-formal.msg | 5 +- .../categories/qualification/en-eu.msg | 5 +- models/lms.model | 11 ++++- src/Handler/LMS.hs | 15 ++++-- src/Handler/LMS/Learners.hs | 37 ++++++++++---- src/Jobs/Handler/LMS.hs | 48 +++++++++++++++---- 6 files changed, 96 insertions(+), 25 deletions(-) diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 3696a51e4..e0781c09d 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -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. \ No newline at end of file +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. \ No newline at end of file diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 10d5d47db..821d5fee7 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -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. \ No newline at end of file +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. \ No newline at end of file diff --git a/models/lms.model b/models/lms.model index d47a7f0f2..20811ea22 100644 --- a/models/lms.model +++ b/models/lms.model @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-25 Sarah Vaupel ,Steffen Jost -- -- 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 \ No newline at end of file diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index a46896064..968153879 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-25 Sarah Vaupel ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-25 Sarah Vaupel ,Steffen Jost -- -- 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 [ diff --git a/src/Handler/LMS/Learners.hs b/src/Handler/LMS/Learners.hs index 239b5d061..0ec864144 100644 --- a/src/Handler/LMS/Learners.hs +++ b/src/Handler/LMS/Learners.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2023 Steffen Jost +-- SPDX-FileCopyrightText: 2023-25 Steffen Jost -- -- 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 diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 9f506ccaf..d2ec622ea 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-24 Steffen Jost +-- SPDX-FileCopyrightText: 2022-2025 Steffen Jost -- -- 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}.|]