fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix(lms): accept success for no-status learners and print several more debug messages processing reports

Browse Source
This commit is contained in:
Steffen Jost 2023-09-04 15:52:06 +00:00
parent 0b19705e80
commit a7ed659866
2 changed files with 79 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
src/Handler/LMS/Report.hs
View File

@ -201,7 +201,7 @@ mkReportTable sid qsh qid = do
, LmsReportTimestamp =. now , LmsReportTimestamp =. now
] ]
-- audit $ Transaction.. (add to Audit.Types) -- audit $ Transaction.. (add to Audit.Types)
lift . queueDBJob $ JobLmsReports qid -- TODO: V2 lift . queueDBJob $ JobLmsReports qid
return $ LmsReportR sid qsh return $ LmsReportR sid qsh
, dbtCsvRenderKey = const $ \case , dbtCsvRenderKey = const $ \case
LmsReportInsertData{..} -> do -- TODO: i18n LmsReportInsertData{..} -> do -- TODO: i18n
@ -277,15 +277,16 @@ postLmsReportUploadR sid qsh = do
FormSuccess file -> do FormSuccess file -> do
-- content <- fileSourceByteString file -- content <- fileSourceByteString file
-- return $ Just (fileName file, content) -- return $ Just (fileName file, content)
nr <- runDBJobs $ do (nr, qid) <- runDBJobs $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
nr <- runConduit $ fileSource file nr <- runConduit $ fileSource file
.| decodeCsv .| decodeCsv
.| foldMC (saveReportCsv now qid) 0 .| foldMC (saveReportCsv now qid) 0
queueDBJob $ JobLmsReports qid return (nr, qid)
return nr
addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen") 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 FormFailure errs -> do
forM_ errs $ addMessage Error . toHtml forM_ errs $ addMessage Error . toHtml
redirect $ LmsReportUploadR sid qsh redirect $ LmsReportUploadR sid qsh

75
src/Jobs/Handler/LMS.hs
View File

@ -18,7 +18,7 @@ import Import
import Jobs.Queue import Jobs.Queue
-- import Jobs.Handler.Intervals.Utils -- import Jobs.Handler.Intervals.Utils
import Database.Persist.Sql (deleteWhereCount) import Database.Persist.Sql -- (deleteWhereCount, updateWhereCount)
import Database.Esqueleto.Experimental ((:&)(..)) import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.Experimental as E
--import qualified Database.Esqueleto.Legacy as E --import qualified Database.Esqueleto.Legacy as E
@ -65,7 +65,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
$logInfoS "LMS" $ "Notifying about exipiring qualification " <> qshort $logInfoS "LMS" $ "Notifying about exipiring qualification " <> qshort
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
case qualificationRefreshWithin quali of 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 (Just renewalPeriod) -> do
let nowaday = utctDay now let nowaday = utctDay now
renewalDate = addGregorianDurationClip renewalPeriod nowaday renewalDate = addGregorianDurationClip renewalPeriod nowaday
@ -242,6 +242,9 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
-- act :: YesodJobDB UniWorX () -- 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) 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 let today = utctDay now
-- locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now -- no longer necessary, since LMS reports dates only -- locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now -- no longer necessary, since LMS reports dates only
-- DB query for LmsUserUser, provided a matching LmsReport exists -- DB query for LmsUserUser, provided a matching LmsReport exists
@ -270,19 +273,35 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
-- group results by LmsReportDate -- group results by LmsReportDate
grpRepByDay :: [(Entity LmsUser, Entity LmsReport)] -> Map.Map (Maybe Day) ([LmsUserId],[UserId]) 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] 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 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 } } notifyNewLearner (E.Value uid) = queueDBJob JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False } }
in luserQry luserFltrNew (const $ const E.true) >>= mapM_ notifyNewLearner 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 let lrFltrBlock luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsFailed
in lrepQry lrFltrBlock >>= (\toBlock -> in lrepQry lrFltrBlock >>= (\toBlock ->
void $ flip Map.traverseWithKey (grpRepByDay toBlock) $ \repDay (lids,uids) -> do 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 ok_block <- 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)] 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 -- D) 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 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 -> in lrepQry lrFltrSuccess >>= (\toRenew ->
void $ flip Map.traverseWithKey (grpRepByDay toRenew) $ \repDay (lids,uids) -> do 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 -- 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,10 +310,11 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
ok_unblock <- qualificationUserUnblockByReason qid uids repTime (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log 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|]) 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
void $ renewValidQualificationUsers qid repTime uids -- only valid qualifications are truly renewed; transcribes to audit log ok_renew <- 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_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.update $ \luser -> do
E.set luser [ LmsUserEnded E.=. E.justVal now ] 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
@ -306,24 +326,9 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
E.&&. lreport E.^. LmsReportQualification E.==. E.val qid E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
) )
-- E) reset status for learners that had their tries just resetted as indicated by LmsOpen -- F) lock expired learners: happens during JobLmsDequeue only
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
-- G) update lock and received -- 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 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.where_ $ E.val qid E.==. luser E.^. LmsUserQualification
@ -334,22 +339,20 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
E.&&. lreport E.^. LmsReportQualification E.==. E.val qid 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.^. 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: -- NOTE: this code leads to a runtime errror; apparently from-clauses are not allowed in updates yet
-- if | LmsUserResetTries && LmsReportStatus = LmsOpen => LmsUserStatus =. Nothing -- let updateReceivedLocked lockstatus = E.update $ \luser -> do -- attempt to use 'from'-clause in update as per PostgreSQL
-- | 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
-- E.set luser [ LmsUserReceived E.=. E.justVal now -- E.set luser [ LmsUserReceived E.=. E.justVal now
-- , lmsUserLocked E.=. E.val lockstatus ] -- , LmsUserLocked E.=. E.val lockstatus ]
-- lreport <- E.from $ E.table @LmsReport -- lreport <- E.from $ E.table @LmsReport
-- E.where_ $ E.isNothing (luser E.^. LmsUserEnded) -- E.where_ $ E.isNothing (luser E.^. LmsUserEnded)
-- E.&&. luser E.^. LmsUserQualification E.==. E.val qid -- E.&&. luser E.^. LmsUserQualification E.==. E.val qid
-- E.&&. lreport E.^. LmsReportQualification E.==. E.val qid -- E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
-- E.&&. lreport E.^. LmsReportIdent E.==. luser E.^. LmsReportIdent -- 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) -- 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 False
>>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as unlocked and received for qualification " <> tshow qid -- debug, remove later
updateReceivedLocked True 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 -- G) Truncate LmsReport for qid and log
repProc <- deleteWhereCount [LmsReportQualification ==. qid] repProc <- deleteWhereCount [LmsReportQualification ==. qid]
$logInfoS "LMS" [st|Processed #{tshow repProc} e-learning status reports for qualification #{tshow qid}.|] $logInfoS "LMS" [st|Processed #{tshow repProc} e-learning status reports for qualification #{tshow qid}.|]