From 3085b8d91dcec999d8281aa3950bd3ebf29894ea Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 25 Aug 2023 12:35:21 +0000 Subject: [PATCH] chore(lms): implement report dispatch job DONE --- models/lms.model | 4 +- src/Handler/Admin/Avs.hs | 4 +- src/Handler/LMS.hs | 2 +- src/Handler/LMS/Learners.hs | 2 +- src/Handler/LMS/Report.hs | 2 +- src/Handler/Qualification.hs | 4 +- src/Handler/Tutorial/Users.hs | 2 +- src/Handler/Utils/Qualification.hs | 88 ++++++++++------ src/Jobs/Handler/LMS.hs | 164 ++++++++--------------------- 9 files changed, 105 insertions(+), 167 deletions(-) diff --git a/models/lms.model b/models/lms.model index 66d0ee24d..4b0469d31 100644 --- a/models/lms.model +++ b/models/lms.model @@ -115,7 +115,7 @@ LmsUser pin Text resetPin Bool default=false -- should pin be reset? datePin UTCTime default=now() -- time pin was created - status LmsStatus Maybe -- open, success or failure; status should never change unless isNothing; isJust indicates lms is finished and user shall be deleted from LMS + status LmsStatus Maybe -- Nothing=open, LmsSuccess, LmsBlocked or LmsExpired; status should never change unless isNothing; isJust indicates lms is finished and user shall be deleted from LMS --toDelete encoded by Handler.Utils.LMS.lmsUserToDelete statusDay Day Maybe -- date of status change; should be isJust iff isJust status; modelling as a separate table too bothersome, unlike qualification block started UTCTime default=now() @@ -158,7 +158,7 @@ LmsReport qualification QualificationId OnDeleteCascade OnUpdateCascade ident LmsIdent date Day Maybe -- BEWARE: timezone is local as submitted by LMS - result LmsState -- (0|1|2) 0=too many tries, 1=open, 2=success + result LmsState -- (0|1|2) 0=LmsFailed[too many tries], 1=LmsOpen, 2=LmsPassed[success] lock Bool -- (0|1) timestamp UTCTime default=now() UniqueLmsReport qualification ident -- required by DBTable diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 6c6bba259..7a94d1ec5 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -446,7 +446,7 @@ getProblemAvsSynchR = do then return (-1) else do uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] [] - qualificationUserBlocking licenceTableChangeFDriveQId uids False (Left licenceTableChangeFDriveReason) licenceTableChangeFDriveNotify + qualificationUserBlocking licenceTableChangeFDriveQId uids False Nothing (Left licenceTableChangeFDriveReason) licenceTableChangeFDriveNotify if | oks < 0 -> addMessageI Error $ MsgRevokeFraDriveLicencesError alic | oks > 0, oks == length apids -> addMessageI Success $ MsgRevokeFraDriveLicences alic oks | otherwise -> addMessageI Warning $ MsgRevokeFraDriveLicences alic oks @@ -456,7 +456,7 @@ getProblemAvsSynchR = do (n, Qualification{qualificationShorthand}) <- runDB $ do uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] [] -- addMessage Info $ text2Html $ "UIDs: " <> tshow uids -- DEBUG - void $ qualificationUserBlocking licenceTableChangeFDriveQId uids True (Left licenceTableChangeFDriveReason) False + void $ qualificationUserBlocking licenceTableChangeFDriveQId uids True Nothing (Left licenceTableChangeFDriveReason) False forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId nowaday licenceTableChangeFDriveEnd licenceTableChangeFDriveRenew (length uids,) <$> get404 licenceTableChangeFDriveQId addMessageI (bool Success Warning $ null apids) $ MsgSetFraDriveLicences (citext2string qualificationShorthand) n diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 2c1ac9739..11cc8af9a 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -686,7 +686,7 @@ postLmsR sid qsh = do numUsers = Set.size selectedUsers delUsers <- runDB $ do when (lmsActRestartUnblock == Just True) $ do - oks <- qualificationUserBlocking qid usersList True (Left "Manueller LMS Neustart") (fromMaybe True lmsActRestartNotify) + oks <- qualificationUserBlocking qid usersList True Nothing (Left "Manueller LMS Neustart") (fromMaybe True lmsActRestartNotify) addMessageI Success $ MsgQualificationStatusUnblock qsh oks numUsers whenIsJust lmsActRestartExtend $ \extDays -> do diff --git a/src/Handler/LMS/Learners.hs b/src/Handler/LMS/Learners.hs index e27f8fde5..0741a408d 100644 --- a/src/Handler/LMS/Learners.hs +++ b/src/Handler/LMS/Learners.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later diff --git a/src/Handler/LMS/Report.hs b/src/Handler/LMS/Report.hs index 75456e38b..9422fe119 100644 --- a/src/Handler/LMS/Report.hs +++ b/src/Handler/LMS/Report.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2023 Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 095a2b027..cb551dfda 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -610,7 +610,7 @@ postQualificationR sid qsh = do formResult lmsRes $ \case (QualificationActRenewData, selectedUsers) | isAdmin -> do - noks <- runDB $ renewValidQualificationUsers qid $ Set.toList selectedUsers + noks <- runDB $ renewValidQualificationUsers qid Nothing $ Set.toList selectedUsers addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks reloadKeepGetParams $ QualificationR sid qsh (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do @@ -639,7 +639,7 @@ postQualificationR sid qsh = do oks <- runDB $ do when (blockActRemoveSupervisors action) $ deleteWhere [UserSupervisorUser <-. selUserIds] - qualificationUserBlocking qid selUserIds unblock reason notify + qualificationUserBlocking qid selUserIds unblock Nothing reason notify let nrq = length selectedUsers warnLevel = if | oks < 0 -> Error diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 7b76714de..f9be59482 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -145,7 +145,7 @@ postTUsersR tid ssh csh tutn = do redirect $ CTutorialR tid ssh csh tutn TUsersR (TutorialUserRenewQualificationData{..}, selectedUsers) | tuQualification `Set.member` courseQids -> do - noks <- runDB $ renewValidQualificationUsers tuQualification $ Set.toList selectedUsers + noks <- runDB $ renewValidQualificationUsers tuQualification Nothing $ Set.toList selectedUsers addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks redirect $ CTutorialR tid ssh csh tutn TUsersR (TutorialUserSendMailData{}, selectedUsers) -> do diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index 18e1b36d0..60016e1ec 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -118,7 +118,13 @@ validQualification' cutoff qualUser = ,qualUser E.?. QualificationUserValidUntil)) -- currently valid E.&&. quserBlock' False cutoff qualUser -selectValidQualifications :: QualificationId -> Maybe [UserId] -> UTCTime -> DB [Entity QualificationUser] +-- selectValidQualifications :: QualificationId -> Maybe [UserId] -> UTCTime -> DB [Entity QualificationUser] +selectValidQualifications :: + ( MonadIO m + , BackendCompatible SqlBackend backend + , PersistQueryRead backend + , PersistUniqueRead backend + ) => QualificationId -> Maybe [UserId] -> UTCTime -> ReaderT backend m [Entity QualificationUser] selectValidQualifications qid mbUids cutoff = -- cutoff <- utctDay <$> liftIO getCurrentTime E.select $ do @@ -164,8 +170,21 @@ upsertQualificationUser qualificationUserQualification qualificationUserLastRef } -- | Renew an existing valid qualification, ignoring all blocks otherwise -renewValidQualificationUsers :: QualificationId -> [UserId] -> DB Int -renewValidQualificationUsers qid uids = +-- renewValidQualificationUsers :: QualificationId -> Maybe UTCTime -> [UserId] -> DB Int -- not general enough for use in YesodJobDB +renewValidQualificationUsers :: + ( AuthId (HandlerSite m) ~ Key User + , IsPersistBackend (YesodPersistBackend (HandlerSite m)) + , BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend + , BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m)) + , PersistQueryWrite (YesodPersistBackend (HandlerSite m)) + , PersistUniqueWrite (YesodPersistBackend (HandlerSite m)) + , HasInstanceID (HandlerSite m) InstanceId + , YesodAuthPersist (HandlerSite m) + , HasAppSettings (HandlerSite m) + , MonadHandler m + , MonadCatch m + ) => QualificationId -> Maybe UTCTime -> [UserId] -> ReaderT (YesodPersistBackend (HandlerSite m)) m Int +renewValidQualificationUsers qid renewalTime uids = -- The following short code snippet suffices in principle, but would not allow audit log entries. Are these still needed? -- E.update $ \qu -> do -- E.set qu [ QualificationUserValidUntil E.+=. E.interval (CalendarDiffDays 2 0) ] -- TODO: for Testing only @@ -173,7 +192,7 @@ renewValidQualificationUsers qid uids = -- E.&&. (qu E.^. QualificationUserUser `E.in_` E.valList uids) get qid >>= \case Just Qualification{qualificationValidDuration=Just renewalMonths} -> do - now <- liftIO getCurrentTime + now <- maybe (liftIO getCurrentTime) return renewalTime quEntsAll <- selectValidQualifications qid (Just uids) now let nowaday = utctDay now maxValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) nowaday @@ -207,47 +226,46 @@ qualificationUserBlocking :: , MonadHandler m , MonadCatch m , Num n - ) => QualificationId -> [UserId] -> Bool -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n -qualificationUserBlocking qid uids unblock (qualificationBlockReasonText -> reason) notify = do + ) => QualificationId -> [UserId] -> Bool -> Maybe UTCTime -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n +qualificationUserBlocking qid uids unblock mbBlockTime (qualificationBlockReasonText -> reason) notify = do authUsr <- liftHandler maybeAuthId - now <- liftIO getCurrentTime + now <- liftIO getCurrentTime + let blockTime = fromMaybe now mbBlockTime -- -- Code would work, but problematic -- oks <- E.insertSelectCount . E.from $ \qualificationUser -> do -- E.where_ $ qualificationUser E.^. QualificationUserQualification E.==. E.val qid -- E.&&. qualificationUser E.^. QualificationUserUser E.in_ E.valList uid - -- E.&&. quserBlock (not unblock) nowaday qualificationUser -- only unblock blocked qualification and vice versa + -- E.&&. quserBlock (not unblock) blockTime qualificationUser -- only unblock blocked qualification and vice versa -- return $ QualificationUserBlock -- E.<# qualificationUser E.^. QualificationUserId -- E.<&> E.val unblock - -- E.<&> E.val nowaday + -- E.<&> E.val blockTime -- E.<&> E.val reason -- E.<&> E.val authUsr - toChange' <- E.select $ do + toChange <- E.select $ do qualUser <- E.from $ E.table @QualificationUser E.where_ $ qualUser E.^. QualificationUserQualification E.==. E.val qid E.&&. qualUser E.^. QualificationUserUser `E.in_` E.valList uids - E.&&. quserBlock (not unblock) now qualUser -- only unblock blocked qualification and vice versa + E.&&. quserBlock (not unblock) blockTime qualUser -- only unblock blocked qualification and vice versa return (qualUser E.^. QualificationUserId, qualUser E.^. QualificationUserUser) - let toChange = E.unValue . fst <$> toChange' - E.insertMany_ $ map (\quid -> QualificationUserBlock - { qualificationUserBlockQualificationUser = quid - , qualificationUserBlockUnblock = unblock - , qualificationUserBlockFrom = now - , qualificationUserBlockReason = reason - , qualificationUserBlockBlocker = authUsr - }) toChange - - unless notify $ updateWhere [QualificationUserId <-. toChange] [QualificationUserLastNotified =. now] - - forM_ toChange' $ \(_, E.Value uid) -> do - audit TransactionQualificationUserBlocking - { -- transactionQualificationUser = quid - transactionQualification = qid - , transactionUser = uid - , transactionQualificationBlock = error "TODO" -- CONTINUE HERE - } - return $ fromIntegral $ length toChange - + let newBlocks = [ (quid, uid, qub) + | (E.Value quid, E.Value uid) <- toChange + , let qub = QualificationUserBlock + { qualificationUserBlockQualificationUser = quid + , qualificationUserBlockUnblock = unblock + , qualificationUserBlockFrom = blockTime + , qualificationUserBlockReason = reason + , qualificationUserBlockBlocker = authUsr + } + ] + E.insertMany_ (trd3 <$> newBlocks) + unless notify $ updateWhere [QualificationUserId <-. (fst3 <$> newBlocks)] [QualificationUserLastNotified =. now] + forM_ newBlocks $ \(_, uid, qub) -> audit TransactionQualificationUserBlocking + { transactionQualification = qid + , transactionUser = uid + , transactionQualificationBlock = qub + } + return $ fromIntegral $ length newBlocks qualificationUserUnblockByReason :: ( AuthId (HandlerSite m) ~ Key User @@ -262,13 +280,13 @@ qualificationUserUnblockByReason :: , MonadHandler m , MonadCatch m , Num n - ) => QualificationId -> [UserId] -> QualificationBlockReason -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n -qualificationUserUnblockByReason qid uids (qualificationBlockReasonText -> reason) undo_reason notify = do - now <- liftIO getCurrentTime + ) => QualificationId -> [UserId] -> Maybe UTCTime -> QualificationBlockReason -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n +qualificationUserUnblockByReason qid uids mbUnblockTime (qualificationBlockReasonText -> reason) undo_reason notify = do + now <- maybe (liftIO getCurrentTime) return mbUnblockTime toUnblock <- E.select $ do quser <- E.from $ E.table @QualificationUser E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid E.&&. quser E.^. QualificationUserUser `E.in_` E.valList uids E.&&. quserBlockAux True (E.val now) (E.==. (quser E.^. QualificationUserId)) (Just (\qblock -> (qblock E.^. QualificationUserBlockReason) E.==. E.val reason)) return $ quser E.^. QualificationUserUser - qualificationUserBlocking qid (E.unValue <$> toUnblock) True undo_reason notify + qualificationUserBlocking qid (E.unValue <$> toUnblock) True mbUnblockTime undo_reason notify diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 45629105e..eeb6d15ab 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -18,6 +18,7 @@ import Import import Jobs.Queue -- import Jobs.Handler.Intervals.Utils +import Database.Persist.Sql (deleteWhereCount) import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E --import qualified Database.Esqueleto.Legacy as E @@ -25,6 +26,7 @@ import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.Utils as E import qualified Data.Set as Set +import qualified Data.Map as Map import qualified Data.Time.Zones as TZ import Handler.Utils.DateTime @@ -238,10 +240,11 @@ dispatchJobLmsReports :: QualificationId -> JobHandler UniWorX dispatchJobLmsReports qid = JobHandlerAtomic act where -- act :: YesodJobDB UniWorX () - act = hoist lift $ do + 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 let today = utctDay now - locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now + -- locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now + -- 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 @@ -249,11 +252,12 @@ dispatchJobLmsReports qid = JobHandlerAtomic act E.&&. luFltr luser E.&&. E.exists (do lreport <- E.from $ E.table @LmsReport - E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsReportIdent + 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 @@ -262,52 +266,34 @@ 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) - - -- 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 } } + return (luser, lreport) + -- group results by LmsReportDate + grpRepByDay :: [(Entity LmsUser, Entity LmsReport)] -> Map.Map (Maybe Day) ([LmsUserId],[UserId]) + grpRepByDay reps = Map.fromListWith (<>) [(lmsReportDate lreport, ([luid],[lmsUserUser luser])) | (Entity luid luser, Entity _ lreport) <- reps] + -- A) 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 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 + in luserQry luserFltrNew (const $ const E.true) >>= mapM_ notifyNewLearner + -- B) 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 + in lrepQry lrFltrBlock >>= (\toBlock -> + void $ flip Map.traverseWithKey (grpRepByDay toBlock) $ \repDay (lids,uids) -> do + void $ qualificationUserBlocking qid uids False (toMidnight <$> repDay) (Right QualificationBlockFailedELearning) True -- only valid qualifications are blocked; transcribes to audit log + updateWhere [LmsUserQualification ==. qid, LmsUserId <-. lids] [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. (repDay <|> Just today)] + ) + -- C) renew qualifications for all successfull learners + let lrFltrSuccess luser lreport = luser E.^. LmsUserStatus E.!=. E.justVal LmsSuccess E.&&. lreport E.^. LmsReportResult E.==. E.val LmsPassed -- LMS WORKAROUND 1: LmsPassed replaces any other status + in lrepQry lrFltrSuccess >>= (\toRenew -> + void $ flip Map.traverseWithKey (grpRepByDay toRenew) $ \repDay (lids,uids) -> do + -- 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 + repTime = toMidnight <$> repDay + ok_unblock <- qualificationUserUnblockByReason qid uids 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 + void $ renewValidQualificationUsers qid repTime uids -- only valid qualifications are truly renewed; transcribes to audit log + updateWhere [LmsUserQualification ==. qid, LmsUserId <-. lids] [LmsUserStatus =. Just LmsSuccess, LmsUserStatusDay =. (repDay <|> Just today)] ) - 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 ] @@ -316,19 +302,19 @@ dispatchJobLmsReports qid = JobHandlerAtomic act 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.^. LmsReportIdent + E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent E.&&. lreport E.^. LmsReportQualification E.==. E.val qid ) - -- E) lock expired learned? -- maybe move to dequeue? + -- E) lock expired learneds: happens during JobLmsDequeue only -- 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 ] + , 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.^. LmsReportIdent + 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) ) @@ -344,76 +330,10 @@ dispatchJobLmsReports qid = JobHandlerAtomic act -- 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 + -- 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}.|] - {- CASE ANALYSIS: - 1. LmsReportResult = LmsFailed && LmsUserStatus /= Just LmsBlocked -> Set to blocked - 2. LmsReportResult = LmsOpen && LmsUserStatus /= Nothing -> What to do? - 3. LmsReportResult = LmsPassed && LmsUserStatus /= Just LmsSuccess -> Always accept success?! - - -} - results <- E.select $ do - (quser :& luser :& lreport) <- E.from $ - E.table @QualificationUser -- table not needed if renewal from lms completion day is used TODO: decide! - `E.innerJoin` E.table @LmsUser - `E.on` (\(quser :& luser) -> - luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser - E.&&. luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification) - `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_ $ quser E.^. QualificationUserQualification E.==. E.val qid - E.&&. luser E.^. LmsUserQualification E.==. E.val qid - E.&&. E.isNothing (luser E.^. LmsUserEnded) -- ignore all closed learners - E.&&. (E.justVal LmsSuccess E.!=. luser E.^. LmsUserStatus E.||. E.val LmsPassed E.!=. lreport E.^. LmsReportResult) - E.&&. (E.justVal LmsSuccess E.!=. luser E.^. LmsUserStatus E.||. E.val LmsPassed E.!=. lreport E.^. LmsReportResult) - - -- E.&&. E.isNothing (luser E.^. LmsUserStatus) -- do not process learners already having a result -- workaround - - return (quser, luser, lreport) - - forM_ results $ \(Entity quid QualificationUser{..}, Entity luid LmsUser{..}, Entity lrid LmsReport{..}) -> if - - -- - - -- three separate DB operations per result is not so nice. All within one transaction though. - let lmsUserStartedDay = localDay $ TZ.utcToLocalTimeTZ appTZ lmsUserStarted - saneDate = lmsReportDate `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil locDay) - -- && qualificationUserLastRefresh <= utctDay lmsUserStarted NOTE: not always true due to manual intervention; also renewValidQualificationUsers prevents double renewals anyway - -- newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards - note <- if saneDate && (lmsUserStatus /= Just LmsSuccess) - then do - -- WORKAROUND LMS-Bug [supposedly fixed now, but isnt]: 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 [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 - -- 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 - [ LmsUserStatus =. Just LmsSuccess - , LmsUserStatusDay =. Just lmsResultSuccess - , LmsUserReceived =. Just lmsResultTimestamp - ] - return Nothing - else do - let errmsg = [st|LMS Result: success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent} for #{tshow qid}|] - $logErrorS "LMS" errmsg - return $ Just errmsg - - audit TransactionLmsSuccess -- always log success, since this is only transmitted once - { transactionQualification = qid - , transactionLmsIdent = lmsUserIdent - , transactionLmsDay = lmsResultSuccess - , transactionLmsUser = Just lmsUserUser - , transactionNote = note - , transactionReceived = lmsResultTimestamp - } - delete lrid - $logInfoS "LMS" [st|Processed #{tshow (length results)} LMS results|] -- DEPRECATED processes received results and lengthen qualifications, if applicable dispatchJobLmsResults :: QualificationId -> JobHandler UniWorX @@ -449,10 +369,10 @@ dispatchJobLmsResults qid = JobHandlerAtomic act then do -- WORKAROUND LMS-Bug [supposedly fixed now, but isnt]: 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 [qualificationUserUser] (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log + ok_unblock <- qualificationUserUnblockByReason qid [qualificationUserUser] Nothing (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] -- only unblocked are renewed + _ok_renew <- renewValidQualificationUsers qid Nothing [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 @@ -517,7 +437,7 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act updateStatus = isBlocked && oldStatus /= Just LmsSuccess when updateStatus $ do update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. Just lmsMsgDay] - ok <- qualificationUserBlocking qid [lmsUserUser luser] False (Right QualificationBlockFailedELearning) True + ok <- qualificationUserBlocking qid [lmsUserUser luser] False Nothing (Right QualificationBlockFailedELearning) True when (ok /= 1) $ do uuid :: CryptoUUIDUser <- encrypt $ lmsUserUser luser $logWarnS "LmsUserlist" [st|Blocking by failed E-learning failed for learner #{tshow uuid} and qualification #{tshow qid}]