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

chore(lms): WIP implement report dispatch job, PART 2

Browse Source
This commit is contained in:
Steffen Jost 2023-08-24 15:45:54 +00:00
parent 9c156f1b58
commit 12f4bcfa1b
3 changed files with 93 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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

2
src/Handler/Utils/Qualification.hs
View File

@ -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?

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

@ -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