From 390ff317ea3bb4ef8918c9cda858f5f228e4a882 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 8 Nov 2023 15:56:35 +0000 Subject: [PATCH] fix(lms): report log did not match qualification --- src/Jobs/Handler/LMS.hs | 41 +++++++++++++++++++++-------------------- 1 file changed, 21 insertions(+), 20 deletions(-) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 0f510f64c..06451d5a6 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -164,7 +164,7 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser lpw) (randomLMSIdentBut qprefix identsInUse) -- runMaybeT $ do -- lid <- MaybeT $ randomLMSIdentBu qprefix identsInUse - -- MaybeT $ E.insertUniqueEntity $ mkLmsUser lpw lid + -- MaybeT $ E.insertUniqueEntity $ mkLmsUser lpw lid inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser case inserted of Nothing -> do @@ -187,7 +187,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act quali <- getJust qid -- may throw an error, aborting the job let qshort = CI.original $ qualificationShorthand quali $logInfoS "LMS" $ "Processing e-learning results for qualification " <> qshort - now <- liftIO getCurrentTime + now <- liftIO getCurrentTime -- end users that expired by doing nothing expiredUsers <- E.select $ do (quser :& luser) <- E.from $ @@ -201,7 +201,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act -- E.&&. E.isNothing (luser E.^. LmsUserStatus) -- E.&&. E.isNothing (luser E.^. LmsUserEnded) E.&&. E.not_ (validQualification now quser) - pure (luser E.?. LmsUserId, quser E.^. QualificationUserUser) + pure (luser E.?. LmsUserId, quser E.^. QualificationUserUser) nrBlocked <- qualificationUserBlocking qid (E.unValue . snd <$> expiredUsers) False (Just now) (Right QualificationBlockExpired) True -- essential that blocks occur only once let expiredLearners = [ luid | (E.Value (Just luid), _) <- expiredUsers ] -- let expiredLearners = catMaybes (E.unValue . fst <$> expiredUsers) @@ -214,7 +214,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act when (quali ^. _qualificationExpiryNotification) $ do -- notifies expired and previously lms-failed drivers notifyInvalidDrivers <- E.select $ do - (quser :& qblock) <- E.from $ + (quser :& qblock) <- E.from $ E.table @QualificationUser `E.leftJoin` E.table @QualificationUserBlock `E.on` (\(quser :& qblock) -> qblock E.?. QualificationUserBlockQualificationUser E.?=. quser E.^. QualificationUserId @@ -267,7 +267,7 @@ 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 when (totalrows > 0) $ do let -- locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now -- no longer necessary, since LMS reports dates only @@ -293,7 +293,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act 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) + 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 @@ -316,13 +316,13 @@ dispatchJobLmsReports qid = JobHandlerAtomic act 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 + procBlock (Entity luid luser, Entity _ lreport) = do let repDay = lmsReportDate lreport <|> Just now ok_block <- qualificationUserBlocking qid [lmsUserUser luser] False (lmsReportDate lreport) (Right $ QualificationBlockFailedELearningBy $ lmsUserIdent luser) 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 + 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 @@ -330,14 +330,14 @@ dispatchJobLmsReports qid = JobHandlerAtomic act let repDay = lmsReportDate lreport <|> Just now reason = Just $ Right $ QualificationRenewELearningBy $ lmsUserIdent luser -- 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 + -- 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 + -- END LMS WORKAROUND 2 ok_renew <- renewValidQualificationUsers qid reason 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 + 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) @@ -380,8 +380,8 @@ dispatchJobLmsReports qid = JobHandlerAtomic act >>= \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, after updating log - E.insertSelect $ do + -- G) Truncate LmsReport for qid, after updating log + E.insertSelect $ do lreport <- E.from $ E.table @LmsReport let samelog = E.subSelect $ do lrl <- E.from $ E.table @LmsReportLog @@ -389,22 +389,23 @@ dispatchJobLmsReports qid = JobHandlerAtomic act E.&&. lrl E.^. LmsReportLogIdent E.==. lreport E.^. LmsReportIdent E.orderBy [E.desc $ lrl E.^. LmsReportLogTimestamp] return $ lreport E.^. LmsReportResult E.==. lrl E.^. LmsReportLogResult - E.&&. lreport E.^. LmsReportLock E.==. lrl E.^. LmsReportLogLock + E.&&. lreport E.^. LmsReportLock E.==. lrl E.^. LmsReportLogLock E.&&. E.not_ (lrl E.^. LmsReportLogMissing) E.where_ $ lreport E.^. LmsReportQualification E.==. E.val qid E.&&. E.not_ (E.isTrue samelog) return (LmsReportLog E.<# (lreport E.^. LmsReportQualification) E.<&> (lreport E.^. LmsReportIdent ) - E.<&> E.nothing + E.<&> (lreport E.^. LmsReportDate ) E.<&> (lreport E.^. LmsReportResult ) E.<&> (lreport E.^. LmsReportLock ) E.<&> (lreport E.^. LmsReportTimestamp ) E.<&> E.false) - E.insertSelect $ do + E.insertSelect $ do lrl <- E.from $ E.table @LmsReportLog E.where_ $ E.not_ (lrl E.^. LmsReportLogMissing) - E.&&. E.notExists (do + E.&&. lrl E.^. LmsReportLogQualification E.==. E.val qid + E.&&. E.notExists (do lreport <- E.from $ E.table @LmsReport E.where_ $ lreport E.^. LmsReportQualification E.==. E.val qid E.&&. lreport E.^. LmsReportIdent E.==. lrl E.^. LmsReportLogIdent @@ -418,7 +419,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act return (LmsReportLog E.<# (lrl E.^. LmsReportLogQualification) E.<&> (lrl E.^. LmsReportLogIdent ) - E.<&> (lrl E.^. LmsReportLogDate ) + E.<&> E.nothing E.<&> (lrl E.^. LmsReportLogResult ) E.<&> (lrl E.^. LmsReportLogLock ) E.<&> E.val now @@ -514,7 +515,7 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act | otherwise -> return () -- users likely not yet started (Entity luid luser, Just (Entity _lulid lulist)) -> do - let lReceived = lmsUserlistTimestamp lulist + let lReceived = lmsUserlistTimestamp lulist update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotified is only updated upon sending notifications when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available