From 12f4bcfa1b0d68f0a7cc45e7cb93e68693276a3f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 24 Aug 2023 15:45:54 +0000 Subject: [PATCH] chore(lms): WIP implement report dispatch job, PART 2 --- src/Handler/LMS/Report.hs | 14 ++--- src/Handler/Utils/Qualification.hs | 2 +- src/Jobs/Handler/LMS.hs | 92 +++++++++++++++++++++++++++--- 3 files changed, 93 insertions(+), 15 deletions(-) diff --git a/src/Handler/LMS/Report.hs b/src/Handler/LMS/Report.hs index 0eb96d185..75456e38b 100644 --- a/src/Handler/LMS/Report.hs +++ b/src/Handler/LMS/Report.hs @@ -121,7 +121,7 @@ mkReportTable sid qsh qid = do ] dbtFilter = Map.fromList [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsReportIdent)) - , (csvLmsDate , FilterColumn $ E.mkExactFilter (E.?. LmsReportDate)) + , (csvLmsDate , FilterColumn $ E.mkExactFilter (E.^. LmsReportDate)) ] dbtFilterUI = \mPrev -> mconcat [ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) @@ -141,11 +141,11 @@ mkReportTable sid qsh qid = do , dbtCsvExampleData = Just [ LmsReportTableCsv { csvLRident = LmsIdent lid - , csvLRdate = Just $ LmsDay $ addDays (-dos) now_day + , csvLRdate = Just $ LmsDay $ addDays (fromIntegral $ -dos) now_day , csvLRresult = toEnum $ dos `mod` succ (fromEnum (maxBound :: LmsState)) , csvLRlock = LmsBool $ even dos } - | (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch", "x2!y3-z4"] [1::Int..] + | (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch", "x2!y3-z4"] [(1::Int)..] ] } where @@ -163,7 +163,7 @@ mkReportTable sid qsh qid = do { lmsReportCsvIdent = csvLRident , lmsReportCsvDate = csvLRdate <&> lms2day , lmsReportCsvResult = csvLRresult - , lmsReportCsvLock = csvLRlock <&> LmsBool + , lmsReportCsvLock = csvLRlock & lms2bool } DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _} -> error "UniqueLmsReport was found, but the key no longer exists." -- TODO: how can this ever happen? Check Pagination-Code DBCsvDiffExisting{dbCsvNew = LmsReportTableCsv{..}, dbCsvOld} -> do @@ -173,7 +173,7 @@ mkReportTable sid qsh qid = do { lmsReportCsvIdent = csvLRident , lmsReportCsvDate = resultDay , lmsReportCsvResult = csvLRresult - , lmsReportCsvLock = csvLRlock <&> LmsBool + , lmsReportCsvLock = csvLRlock & lms2bool } DBCsvDiffMissing{} -> return () -- no deletion , dbtCsvClassifyAction = \case @@ -256,12 +256,12 @@ saveReportCsv qid i LmsReportTableCsv{..} = do , lmsReportIdent = csvLRident , lmsReportDate = csvLRdate <&> lms2day , lmsReportResult = csvLRresult - , lmsReportLock = csvLRlock + , lmsReportLock = csvLRlock & lms2bool , lmsReportTimestamp = now } [ LmsReportDate =. (csvLRdate <&> lms2day) , LmsReportResult =. csvLRresult - , LmsReportLock =. csvLRlock + , LmsReportLock =. (csvLRlock & lms2bool) , LmsReportTimestamp =. now ] return $ succ i diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index d31a4a9d6..18e1b36d0 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -163,7 +163,7 @@ upsertQualificationUser qualificationUserQualification qualificationUserLastRef , transactionQualificationScheduleRenewal = mbScheduleRenewal } --- | Renew an existing qualification, ignoring all blocks +-- | Renew an existing valid qualification, ignoring all blocks otherwise renewValidQualificationUsers :: QualificationId -> [UserId] -> DB Int renewValidQualificationUsers qid uids = -- The following short code snippet suffices in principle, but would not allow audit log entries. Are these still needed? diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 225e0573c..45629105e 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -239,9 +239,76 @@ dispatchJobLmsReports qid = JobHandlerAtomic act where -- act :: YesodJobDB UniWorX () act = hoist lift $ do - now <- liftIO getCurrentTime - let locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now - -- mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected) + now <- liftIO getCurrentTime + let today = utctDay now + locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now + 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.^. LmsReportIdent + E.&&. lreport E.^. LmsReportQualification E.==. E.val qid + E.&&. repFltr luser lreport + ) + return $ luser E.^. LmsUserUser + 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) notify all newly reported users that lms is available + -- newLearners <- E.select $ do + -- luser <- E.from $ E.table @LmsUser + -- E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification + -- E.&&. E.isNothing (luser E.^. LmsUserReceived) -- not seen before, just starting + -- E.&&. E.exists (do + -- lreport <- E.from $ E.table @LmsReport + -- E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsReportIdent + -- E.&&. lreport E.^. LmsReportQualification E.==. E.val qid + -- ) + -- return $ luser E.^. LmsUserUser + -- forM newLearners $ \(E.Value uid) -> + -- queueDBJob JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False } } + 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 E.true >>= mapM_ notifyNewLearner + -- B) block qualifications for failed learners by calling qualificationUserBlocking [uids] (includes audit) + let luserFltrBlock luser = + repFltrBlock + in luserQry luserFltrBlock repFltrBlock >>= (\toBlock -> do + let uidToBlock = E.unValue <$> toBlock + void $ qualificationUserBlocking qid uidToBlock False (Right QualificationBlockFailedELearning) True + updateWhere [ LmsUserQualification ==. uid + , LmsUserUser <-. uidToBlock + , + ] + [ LmsUserStatus =. Just LmsBlocked + , LmsUserStatusDay =. Just ??? -- does not work! + ] + ) + -- alternative attempt + let lrFltrBlock luser lreport = E.isNothing (user E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsFailed + in lrepQry lrFltrBlock >>= (\toBlock -> do + let uidToBlock = (^. _1 . _entityVal . _lmsUserUser) <$> toBlock + void $ qualificationUserBlocking qid uidToBlock False (Right QualificationBlockFailedELearning) True + let blockDayGrps = Map.fromListWith (<>) [(lmsReportDate lreport, [luid]) | (Entity luid _, Entity _ lreport) <- toBlock] + blockLmsUsr bld luids = updateWhere [LmsUserQualification ==. uid, LmsUserId <-. luids] [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. bld <|> Just today] + void $ Map.traverseWithKey blockLmsUsr blockDayGrps + ) + let lrFltrSuccess luser lreport = (E.justVal LmsSuccess E.!=. luser E.^. LmsUserStatus E.||. E.val LmsPassed E.!=. lreport E.^. LmsReportResult) + + + -- C) renew qualifications for all successfull learners + + -- D) 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 @@ -251,10 +318,10 @@ dispatchJobLmsReports qid = JobHandlerAtomic act lreport <- E.from $ E.table @LmsReport E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsReportIdent E.&&. lreport E.^. LmsReportQualification E.==. E.val qid - ) - -- update locked and received, due to the absence of UPDATE..FROM in esqueleto, we call update twice - let updateReceivedLocked lockstatus = E.update $ \luser -> do + -- E) lock expired learned? -- maybe move to dequeue? + -- F) update lock and received + let updateReceivedLocked lockstatus = E.update $ \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 @@ -265,8 +332,19 @@ dispatchJobLmsReports qid = JobHandlerAtomic act 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) ) + -- TODO: check whether this works too: + -- 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.^. LmsReportIdent + -- 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 updateReceivedLocked True + -- C) -- load into memory all open learners that need to be processed -- TOO MUCH; SUBDIVIDE ALL CASES BEFORE QUERY {- CASE ANALYSIS: @@ -374,7 +452,7 @@ dispatchJobLmsResults qid = JobHandlerAtomic act ok_unblock <- qualificationUserUnblockByReason qid [qualificationUserUser] (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}|]) - _ok_renew <- renewValidQualificationUsers qid [qualificationUserUser] -- ignores possible blocks + _ok_renew <- renewValidQualificationUsers qid [qualificationUserUser] -- only unblocked are renewed -- when (ok==1) $ update luid -- we end lms regardless of whether or not a regular renewal was successful, since BPol users may simultaneoysly have on-premise renewal courses and E-Learnings update luid