From cdb23115effe3d1015094530b64aa959de008062 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 27 Sep 2023 15:36:05 +0000 Subject: [PATCH] refactor(lms): clean lms handling code --- src/Handler/LMS.hs | 4 +- src/Handler/LMS/Learners.hs | 2 +- src/Handler/Utils/Qualification.hs | 2 +- src/Jobs/Handler/LMS.hs | 222 +++++++++++++++-------------- 4 files changed, 116 insertions(+), 114 deletions(-) diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index c15a5ebaf..ed1b829b3 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -741,7 +741,7 @@ postLmsR sid qsh = do forM_ shortUsers $ upsertQualificationUser qid nowaday cutoff Nothing fromIntegral <$> (if isReset - then updateWhereCount ([LmsUserQualification ==. qid, LmsUserUser <-. usersList, LmsUserResetTries ==. False] -- , LmsUserLocked ==. True] -- needs to be locked for reset, but this is counter-intuitive for users; should be harmles, but delays reset until lock is effective + then updateWhereCount ([LmsUserQualification ==. qid, LmsUserUser <-. usersList, LmsUserResetTries ==. False, LmsUserEnded ==. Nothing] -- , LmsUserLocked ==. True] -- needs to be locked for reset, but this is counter-intuitive for users; should be harmles, but delays reset until lock is effective ++ ([LmsUserStatus ==. Just LmsBlocked] ||. [LmsUserStatus ==. Just LmsExpired])) [LmsUserResetTries =. True] else deleteWhereCount [LmsUserQualification ==. qid, LmsUserUser <-. usersList] ) @@ -768,7 +768,7 @@ postLmsR sid qsh = do numExaminees <- runDB $ do okUsers <- selectList [ LmsUserQualification ==. qid -- matching qualification , LmsUserEnded ==. Nothing -- not yet deleted - , LmsUserStatus ==. Nothing -- not yet decided + -- , LmsUserStatus ==. Nothing -- not yet decided , LmsUserUser <-. Set.toList selectedUsers -- selected ] [] forM_ okUsers $ \(Entity lid LmsUser {lmsUserUser = uid, lmsUserQualification = qid'}) -> do diff --git a/src/Handler/LMS/Learners.hs b/src/Handler/LMS/Learners.hs index 3f8cdf2ab..31f9ce8bd 100644 --- a/src/Handler/LMS/Learners.hs +++ b/src/Handler/LMS/Learners.hs @@ -204,7 +204,7 @@ getLmsLearnersDirectR sid qsh = do csvOpts = def { csvFormat = fmtOpts } csvSheetName <- csvFilenameLmsUser qsh let nr = length lms_users - msg = "Success. LMS Users download file " <> csvSheetName <> " containing " <> tshow nr <> " rows" + msg = "Success. LMS user learners download file " <> csvSheetName <> " containing " <> tshow nr <> " rows" $logInfoS "LMS" msg addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\"" csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index f94aa67b2..9c877906a 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -263,7 +263,7 @@ qualificationUserBlocking qid uids unblock mbBlockTime (qualificationBlockReason , qualificationUserBlockBlocker = authUsr })) toChange E.insertMany_ (snd <$> newBlocks) - unless notify $ updateWhere [QualificationUserId <-. (qualificationUserBlockQualificationUser . snd <$> newBlocks)] [QualificationUserLastNotified =. now] + unless notify $ updateWhere [QualificationUserId <-. (qualificationUserBlockQualificationUser . snd <$> newBlocks)] [QualificationUserLastNotified =. addUTCTime 1 blockTime] forM_ newBlocks $ \(uid, qub) -> audit TransactionQualificationUserBlocking { transactionQualification = qid , transactionUser = uid diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 7899cbf3e..5550e0706 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -196,7 +196,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid E.&&. luser E.^. LmsUserQualification E.==. E.val qid E.&&. E.isNothing (luser E.^. LmsUserStatus) - E.&&. E.isNothing (luser E.^. LmsUserEnded) + -- E.&&. E.isNothing (luser E.^. LmsUserEnded) E.&&. E.not_ (validQualification now quser) pure (luser E.^. LmsUserId) nrExpired <- E.updateCount $ \luser -> do @@ -205,7 +205,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act E.&&. luser E.^. LmsUserQualification E.==. E.val qid $logInfoS "LMS" $ "Expired lms users " <> tshow nrExpired <> " for qualification " <> qshort - when (quali ^. _qualificationExpiryNotification) $ do + when (quali ^. _qualificationExpiryNotification) $ do -- notifies expired and previously lms-failed drivers notifyInvalidDrivers <- E.select $ do quser <- E.from $ E.table @QualificationUser E.where_ $ E.not_ (validQualification now quser) -- currently invalid @@ -254,119 +254,121 @@ dispatchJobLmsReports qid = JobHandlerAtomic act act = whenM (exists [LmsReportQualification ==. qid]) $ do -- executing twice must be prohibited due to assertion that ALL learners are always sent (D fails otherwise) now <- liftIO getCurrentTime -- DEBUG 2rows; remove later - totalrows <- count [LmsReportQualification ==. qid] + totalrows <- count [LmsReportQualification ==. qid] $logInfoS "LMS" $ "Report processing " <> tshow totalrows <> " rows for qualification " <> tshow qid - let -- 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 - E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification - E.&&. E.isNothing (luser E.^. LmsUserEnded) -- ignore all closed learners - E.&&. luFltr luser - E.&&. E.exists (do + when (totalrows > 0) $ do + let -- 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 + E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification + E.&&. E.isNothing (luser E.^. LmsUserEnded) -- ignore all closed learners + E.&&. luFltr luser + E.&&. E.exists (do + lreport <- E.from $ E.table @LmsReport + E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent + E.&&. lreport E.^. LmsReportQualification E.==. E.val qid + E.&&. repFltr luser lreport + ) + return $ luser E.^. LmsUserUser + -- DB query for LmsUser innerJoin LmsReport + lrepQry lrFltr = E.select $ do + (luser :& lreport) <- E.from $ E.table @LmsUser`E.innerJoin` E.table @LmsReport + `E.on` (\(luser :& lreport) -> luser E.^. LmsUserIdent E.==. lreport E.^. LmsReportIdent + E.&&. luser E.^. LmsUserQualification E.==. lreport E.^. LmsReportQualification) + E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid + E.&&. lreport E.^. LmsReportQualification E.==. E.val qid + E.&&. E.isNothing (luser E.^. LmsUserEnded) -- ignore all closed learners + E.&&. lrFltr luser lreport + return (luser, lreport) + -- A) reset status for learners that had their tries just resetted as indicated by LmsOpen + E.update $ \luser -> do + E.set luser [ LmsUserStatus E.=. E.nothing + , LmsUserStatusDay E.=. E.nothing + , LmsUserResetTries E.=. E.false ] + E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification + E.&&. E.isNothing (luser E.^. LmsUserEnded ) -- must still exist at server + E.&&. E.isJust (luser E.^. LmsUserReceived) -- seen before, for otherwise it might not have been started yet + E.&&. luser E.^. LmsUserResetTries + E.&&. E.exists (do lreport <- E.from $ E.table @LmsReport E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent E.&&. lreport E.^. LmsReportQualification E.==. E.val qid - E.&&. repFltr luser lreport - ) - return $ luser E.^. LmsUserUser - -- DB query for LmsUser innerJoin LmsReport - lrepQry lrFltr = E.select $ do - (luser :& lreport) <- E.from $ E.table @LmsUser`E.innerJoin` E.table @LmsReport - `E.on` (\(luser :& lreport) -> luser E.^. LmsUserIdent E.==. lreport E.^. LmsReportIdent - E.&&. luser E.^. LmsUserQualification E.==. lreport E.^. LmsReportQualification) - E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid - E.&&. lreport E.^. LmsReportQualification E.==. E.val qid - E.&&. E.isNothing (luser E.^. LmsUserEnded) -- ignore all closed learners - E.&&. lrFltr luser lreport - return (luser, lreport) - -- A) reset status for learners that had their tries just resetted as indicated by LmsOpen - E.update $ \luser -> do - E.set luser [ LmsUserStatus E.=. E.nothing - , LmsUserResetTries E.=. E.false ] - E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification - E.&&. E.isNothing (luser E.^. LmsUserEnded ) -- must still exist at server - E.&&. E.isJust (luser E.^. LmsUserReceived) -- seen before, for otherwise it might not have been started yet - E.&&. luser E.^. LmsUserResetTries - E.&&. E.exists (do - lreport <- E.from $ E.table @LmsReport - E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent - E.&&. lreport E.^. LmsReportQualification E.==. E.val qid - E.&&. lreport E.^. LmsReportResult E.==. E.val LmsOpen - E.&&. lreport E.^. LmsReportLock E.==. E.true - ) - -- B) notify all newly reported users that lms is available - let luserFltrNew luser = E.isNothing $ luser E.^. LmsUserReceived -- not seen before, just starting - notifyNewLearner (E.Value uid) = queueDBJob JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False } } - in luserQry luserFltrNew (const $ const E.true) >>= mapM_ notifyNewLearner - -- C) block qualifications for failed learners by calling qualificationUserBlocking [uids] (includes audit) - let lrFltrBlock luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsFailed - procBlock (Entity luid luser, Entity _ lreport) = do - let repDay = lmsReportDate lreport <|> Just now - ok_block <- qualificationUserBlocking qid [lmsUserUser luser] False (lmsReportDate lreport) (Right QualificationBlockFailedELearning) True -- only valid qualifications are blocked; transcribes to audit log - update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. repDay] - 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 - -- 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 - let repDay = lmsReportDate lreport <|> Just now - -- LMS WORKAROUND 2: [supposedly fixed now] sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning - -- let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning - -- ok_unblock <- qualificationUserUnblockByReason qid [lmsUserUser luser] repTime (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log - -- when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid} having success reported after initially failed e-learning|]) - -- END LMS WORKAROUND 2 - ok_renew <- renewValidQualificationUsers qid repDay [lmsUserUser luser]-- only valid qualifications are truly renewed; transcribes to audit log - update luid [LmsUserStatus =. Just LmsSuccess, LmsUserStatusDay =. repDay] - 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 - -- 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 ] - E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification - E.&&. E.isNothing (luser E.^. LmsUserEnded ) - E.&&. E.isJust (luser E.^. LmsUserStatus ) -- status is decided - E.&&. E.isJust (luser E.^. LmsUserReceived) -- seen before, for otherwise it might not have been started yet - E.&&. E.notExists (do - lreport <- E.from $ E.table @LmsReport - E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent - E.&&. lreport E.^. LmsReportQualification E.==. E.val qid - ) - - -- F) lock expired learners: happens during JobLmsDequeue only - -- G) update lock and received - let updateReceivedLocked lockstatus = E.updateCount $ \luser -> do -- due to the absence of UPDATE..FROM in esqueleto, we call update twice - E.set luser [ LmsUserReceived E.=. E.justVal now - , LmsUserLocked E.=. E.val lockstatus ] - E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification - E.&&. E.isNothing (luser E.^. LmsUserEnded) - E.&&. E.exists (do - lreport <- E.from $ E.table @LmsReport - E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent - E.&&. lreport E.^. LmsReportQualification E.==. E.val qid - E.&&. lreport E.^. LmsReportLock E.==. E.val lockstatus -- Maybe more efficient, but less readable: bool E.not_ id lockstatus (lreport E.^. LmsReport Lock) + E.&&. lreport E.^. LmsReportResult E.==. E.val LmsOpen + E.&&. lreport E.^. LmsReportLock E.==. E.true ) - -- NOTE: this code leads to a runtime errror; apparently from-clauses are not allowed in updates yet - -- let updateReceivedLocked lockstatus = E.update $ \luser -> do -- attempt to use 'from'-clause in update as per PostgreSQL - -- E.set luser [ LmsUserReceived E.=. E.justVal now - -- , LmsUserLocked E.=. E.val lockstatus ] - -- lreport <- E.from $ E.table @LmsReport - -- E.where_ $ E.isNothing (luser E.^. LmsUserEnded) - -- E.&&. luser E.^. LmsUserQualification E.==. E.val qid - -- E.&&. lreport E.^. LmsReportQualification E.==. E.val qid - -- 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 - 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 and log - repProc <- deleteWhereCount [LmsReportQualification ==. qid] - $logInfoS "LMS" [st|Processed #{tshow repProc} e-learning status reports for qualification #{tshow qid}.|] + -- B) notify all newly reported users that lms is available + let luserFltrNew luser = E.isNothing $ luser E.^. LmsUserReceived -- not seen before, just starting + notifyNewLearner (E.Value uid) = queueDBJob JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False } } + in luserQry luserFltrNew (const $ const E.true) >>= mapM_ notifyNewLearner + -- C) block qualifications for failed learners by calling qualificationUserBlocking [uids] (includes audit), notified during expiry + let lrFltrBlock luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsFailed + procBlock (Entity luid luser, Entity _ lreport) = do + let repDay = lmsReportDate lreport <|> Just now + ok_block <- qualificationUserBlocking qid [lmsUserUser luser] False (lmsReportDate lreport) (Right QualificationBlockFailedELearning) True -- only valid qualifications are blocked; transcribes to audit log + update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. repDay] + 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 + -- 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 + let repDay = lmsReportDate lreport <|> Just now + -- LMS WORKAROUND 2: [supposedly fixed now] sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning + -- let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning + -- ok_unblock <- qualificationUserUnblockByReason qid [lmsUserUser luser] repTime (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log + -- when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid} having success reported after initially failed e-learning|]) + -- END LMS WORKAROUND 2 + ok_renew <- renewValidQualificationUsers qid repDay [lmsUserUser luser]-- only valid qualifications are truly renewed; transcribes to audit log + update luid [LmsUserStatus =. Just LmsSuccess, LmsUserStatusDay =. repDay] + 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 + -- 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 ] + E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification + E.&&. E.isNothing (luser E.^. LmsUserEnded ) + E.&&. E.isJust (luser E.^. LmsUserStatus ) -- status is decided + E.&&. E.isJust (luser E.^. LmsUserReceived) -- seen before, for otherwise it might not have been started yet + E.&&. E.notExists (do + lreport <- E.from $ E.table @LmsReport + E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent + E.&&. lreport E.^. LmsReportQualification E.==. E.val qid + ) + + -- F) lock expired learners: happens during JobLmsDequeue only + -- G) update lock and received + let updateReceivedLocked lockstatus = E.updateCount $ \luser -> do -- due to the absence of UPDATE..FROM in esqueleto, we call update twice + E.set luser [ LmsUserReceived E.=. E.justVal now + , LmsUserLocked E.=. E.val lockstatus ] + E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification + -- E.&&. E.isNothing (luser E.^. LmsUserEnded) -- should always be true, but maybe there is a bug? + E.&&. E.exists (do + lreport <- E.from $ E.table @LmsReport + E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent + E.&&. lreport E.^. LmsReportQualification E.==. E.val qid + E.&&. lreport E.^. LmsReportLock E.==. E.val lockstatus -- Maybe more efficient, but less readable: bool E.not_ id lockstatus (lreport E.^. LmsReport Lock) + ) + -- NOTE: this code leads to a runtime errror; apparently from-clauses are not allowed in updates yet + -- let updateReceivedLocked lockstatus = E.update $ \luser -> do -- attempt to use 'from'-clause in update as per PostgreSQL + -- E.set luser [ LmsUserReceived E.=. E.justVal now + -- , LmsUserLocked E.=. E.val lockstatus ] + -- lreport <- E.from $ E.table @LmsReport + -- E.where_ $ E.isNothing (luser E.^. LmsUserEnded) + -- E.&&. luser E.^. LmsUserQualification E.==. E.val qid + -- E.&&. lreport E.^. LmsReportQualification E.==. E.val qid + -- 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 + 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 and log + repProc <- deleteWhereCount [LmsReportQualification ==. qid] + $logInfoS "LMS" [st|Processed #{tshow repProc} e-learning status reports for qualification #{tshow qid}.|] -- DEPRECATED processes received results and lengthen qualifications, if applicable