diff --git a/src/Handler/LMS/Report.hs b/src/Handler/LMS/Report.hs index 83e1c68c3..060859d5b 100644 --- a/src/Handler/LMS/Report.hs +++ b/src/Handler/LMS/Report.hs @@ -201,7 +201,7 @@ mkReportTable sid qsh qid = do , LmsReportTimestamp =. now ] -- audit $ Transaction.. (add to Audit.Types) - lift . queueDBJob $ JobLmsReports qid -- TODO: V2 + lift . queueDBJob $ JobLmsReports qid return $ LmsReportR sid qsh , dbtCsvRenderKey = const $ \case LmsReportInsertData{..} -> do -- TODO: i18n @@ -277,15 +277,16 @@ postLmsReportUploadR sid qsh = do FormSuccess file -> do -- content <- fileSourceByteString file -- return $ Just (fileName file, content) - nr <- runDBJobs $ do + (nr, qid) <- runDBJobs $ do qid <- getKeyBy404 $ SchoolQualificationShort sid qsh nr <- runConduit $ fileSource file .| decodeCsv - .| foldMC (saveReportCsv now qid) 0 - queueDBJob $ JobLmsReports qid - return nr + .| foldMC (saveReportCsv now qid) 0 + return (nr, qid) addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen") - redirect $ LmsReportR sid qsh + -- redirect $ LmsReportR sid qsh + getLmsReportR sid qsh <* queueJob' (JobLmsReports qid) -- show uploaded data before processing + FormFailure errs -> do forM_ errs $ addMessage Error . toHtml redirect $ LmsReportUploadR sid qsh diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index d80c76ad1..de8fbcaaa 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -11,14 +11,14 @@ module Jobs.Handler.LMS , dispatchJobLmsDequeue , dispatchJobLmsReports , dispatchJobLmsResults - , dispatchJobLmsUserlist + , dispatchJobLmsUserlist ) where import Import import Jobs.Queue -- import Jobs.Handler.Intervals.Utils -import Database.Persist.Sql (deleteWhereCount) +import Database.Persist.Sql -- (deleteWhereCount, updateWhereCount) import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E --import qualified Database.Esqueleto.Legacy as E @@ -65,13 +65,13 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act $logInfoS "LMS" $ "Notifying about exipiring qualification " <> qshort now <- liftIO getCurrentTime case qualificationRefreshWithin quali of - Nothing -> return () -- TODO: no renewal period, no reminders currenty + Nothing -> return () -- TODO: no renewal period, no reminders currently (Just renewalPeriod) -> do let nowaday = utctDay now renewalDate = addGregorianDurationClip renewalPeriod nowaday - sendReminders remindPeriod = do - let remindDate = addGregorianDurationClip remindPeriod nowaday - reminders <- E.select $ do -- TODO: refactor to remove some redundancies with later query + sendReminders remindPeriod = do + let remindDate = addGregorianDurationClip remindPeriod nowaday + reminders <- E.select $ do -- TODO: refactor to remove some redundancies with later query (luser :& quser) <- E.from $ E.table @LmsUser `E.innerJoin` E.table @QualificationUser `E.on` (\(luser :& quser) -> luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser @@ -99,7 +99,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act renewalUsers <- E.select $ do quser <- E.from $ E.table @QualificationUser E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid - E.&&. quser E.^. QualificationUserScheduleRenewal + E.&&. quser E.^. QualificationUserScheduleRenewal E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate E.&&. (quser `qualificationValid` now) E.&&. E.notExists (do @@ -127,7 +127,7 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act act = do identsInUseVs <- E.select $ do lui <- E.from $ - ( (E.^. LmsUserlistIdent) <$> E.from (E.table @LmsUserlist) ) -- no filter by Qid, since LmsIdents must be unique across all + ( (E.^. LmsUserlistIdent) <$> E.from (E.table @LmsUserlist) ) -- no filter by Qid, since LmsIdents must be unique across all `E.union_` ( (E.^. LmsResultIdent) <$> E.from (E.table @LmsResult ) ) `E.union_` @@ -173,9 +173,9 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act let qshort = CI.original $ qualificationShorthand quali $logInfoS "LMS" $ "Processing e-learning results for qualification " <> qshort now <- liftIO getCurrentTime - let nowaday = utctDay now + let nowaday = utctDay now -- end users that expired by doing nothing - expiredLearners <- E.select $ do + expiredLearners <- E.select $ do (quser :& luser) <- E.from $ E.table @QualificationUser `E.innerJoin` E.table @LmsUser @@ -187,7 +187,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) + pure (luser E.^. LmsUserId) nrExpired <- E.updateCount $ \luser -> do E.set luser [LmsUserStatus E.=. E.justVal LmsExpired, LmsUserStatusDay E.=. E.justVal nowaday] E.where_ $ (luser E.^. LmsUserId) `E.in_` E.valList (E.unValue <$> expiredLearners) @@ -195,13 +195,13 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act $logInfoS "LMS" $ "Expired lms users " <> tshow nrExpired <> " for qualification " <> qshort when (quali ^. _qualificationExpiryNotification) $ do - notifyInvalidDrivers <- E.select $ do - quser <- E.from $ E.table @QualificationUser + notifyInvalidDrivers <- E.select $ do + quser <- E.from $ E.table @QualificationUser E.where_ $ E.not_ (quser `qualificationValid` now) -- currently invalid E.&&. quser E.^. QualificationUserQualification E.==. E.val qid -- correct qualification E.&&. quser `quserToNotify` now -- recently became invalid or blocked - pure (quser E.^. QualificationUserUser) - + pure (quser E.^. QualificationUserUser) + forM_ notifyInvalidDrivers $ \(E.Value uid) -> queueDBJob JobUserNotification { jRecipient = uid @@ -227,7 +227,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act -- ) pure (luser E.^. LmsUserIdent) let delusers = E.unValue <$> delusersVals - numdel = length delusers + numdel = length delusers when (numdel > 0) $ do $logInfoS "LMS" $ "Deleting " <> tshow numdel <> " LmsIdents due to audit duration expiry for qualification " <> qshort deleteWhere [LmsUserQualification ==. qid, LmsUserIdent <-. delusers] @@ -241,7 +241,10 @@ dispatchJobLmsReports qid = JobHandlerAtomic act where -- act :: YesodJobDB UniWorX () 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 + now <- liftIO getCurrentTime + -- DEBUG 2rows; remove later + totalrows <- count [LmsReportQualification ==. qid] + $logInfoS "LMS" $ "Report processing " <> tshow totalrows <> " rows for qualification " <> tshow qid let today = utctDay now -- locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now -- no longer necessary, since LMS reports dates only -- DB query for LmsUserUser, provided a matching LmsReport exists @@ -250,7 +253,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act 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 + 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 @@ -270,19 +273,35 @@ dispatchJobLmsReports qid = JobHandlerAtomic act -- 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 + -- 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 - -- B) block qualifications for failed learners by calling qualificationUserBlocking [uids] (includes audit) + -- 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 - 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)] + in lrepQry lrFltrBlock >>= (\toBlock -> + void $ flip Map.traverseWithKey (grpRepByDay toBlock) $ \repDay (lids,uids) -> do + ok_block <- qualificationUserBlocking qid uids False (toMidnight <$> repDay) (Right QualificationBlockFailedELearning) True -- only valid qualifications are blocked; transcribes to audit log + ok_status <- updateWhereCount [LmsUserQualification ==. qid, LmsUserId <-. lids] [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. (repDay <|> Just today)] + $logInfoS "LMS" $ "Report processing for " <> tshow repDay <> "(" <> tshow (length lids) <> "): " <> tshow ok_block <> " blocked, " <> tshow ok_status <> " status set to blocked for qualification " <> tshow qid -- debug, remove later ) - -- 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 + -- D) renew qualifications for all successfull learners + let lrFltrSuccess luser lreport = (E.isNothing (luser E.^. LmsUserStatus) E.||. 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 @@ -291,65 +310,49 @@ dispatchJobLmsReports qid = JobHandlerAtomic act 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)] + ok_renew <- renewValidQualificationUsers qid repTime uids -- only valid qualifications are truly renewed; transcribes to audit log + ok_status <- updateWhereCount [LmsUserQualification ==. qid, LmsUserId <-. lids] [LmsUserStatus =. Just LmsSuccess, LmsUserStatusDay =. (repDay <|> Just today)] + $logInfoS "LMS" $ "Report processing for " <> tshow repDay <> "(" <> tshow (length lids) <> "): " <> tshow ok_unblock <> " unblocked, " <> tshow ok_renew <> " renewed, " <> tshow ok_status <> " status set to success for qualification " <> tshow qid -- debug, remove later ) - -- D) mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected) + -- 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.where_ $ E.val qid E.==. luser E.^. LmsUserQualification E.&&. E.isNothing (luser E.^. LmsUserEnded ) E.&&. E.isJust (luser E.^. LmsUserReceived) -- seen before, for otherwise it might not have been started yet - E.&&. E.notExists (do + 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 ) - - -- E) 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 ) - 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 - ) - -- F) lock expired learneds: happens during JobLmsDequeue only + + -- F) lock expired learners: happens during JobLmsDequeue only -- G) update lock and received - let updateReceivedLocked lockstatus = E.update $ \luser -> do -- due to the absence of UPDATE..FROM in esqueleto, we call update twice + 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 + 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) ) - -- TODO: implement tries-reset here: - -- if | LmsUserResetTries && LmsReportStatus = LmsOpen => LmsUserStatus =. Nothing - -- | LmsUserResetTries && LmsUserStatus == Nothing && not LmsReportLock => LmsUserResetTries =. False - - -- TODO: check whether this works too: - -- let updateReceivedLocked' lockstatus = E.update $ \luser -> do -- attempt to use 'from'-clause in update as per PostgreSQL + -- 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 ] + -- , 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) + -- 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}.|] @@ -383,7 +386,7 @@ dispatchJobLmsResults qid = JobHandlerAtomic act -- three separate DB operations per result is not so nice. All within one transaction though. let lmsUserStartedDay = localDay $ TZ.utcToLocalTimeTZ appTZ lmsUserStarted saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil locDay) - -- && qualificationUserLastRefresh <= utctDay lmsUserStarted NOTE: not always true due to manual intervention; also renewValidQualificationUsers prevents double renewals anyway + -- && 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 @@ -395,11 +398,11 @@ dispatchJobLmsResults qid = JobHandlerAtomic act _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 + 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}|] @@ -424,7 +427,7 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act where act :: YesodJobDB UniWorX () act = whenM (exists [LmsUserlistQualification ==. qid]) $ do -- safeguard against multiple calls, which would close all learners due to first case below - now <- liftIO getCurrentTime + now <- liftIO getCurrentTime -- result :: [(Entity LmsUser, Entity LmsUserlist)] results <- E.select $ do (luser :& lulist) <- E.from $ @@ -444,23 +447,23 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act (Entity luid luser, Just (Entity _lulid lulist)) -> do let lReceived = lmsUserlistTimestamp lulist lmsMsgDay = utctDay lReceived - update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotified is only updated upon sending notifications + update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotified is only updated upon sending notifications when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available queueDBJob JobUserNotification { jRecipient = lmsUserUser luser , jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False } } - + let isBlocked = lmsUserlistFailed lulist oldStatus = lmsUserStatus luser updateStatus = isBlocked && oldStatus /= Just LmsSuccess - when updateStatus $ do - update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. Just lmsMsgDay] + when updateStatus $ do + update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. Just lmsMsgDay] ok <- qualificationUserBlocking qid [lmsUserUser luser] False Nothing (Right QualificationBlockFailedELearning) True - when (ok /= 1) $ do + 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}] + $logWarnS "LmsUserlist" [st|Blocking by failed E-learning failed for learner #{tshow uuid} and qualification #{tshow qid}] audit TransactionLmsBlocked { transactionQualification = qid , transactionLmsIdent = lmsUserIdent luser