chore(lms): WIP implement report dispatch job
This commit is contained in:
parent
20b3a39bc3
commit
9c156f1b58
@ -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 ties, 1=open, 2=success
|
||||
result LmsState -- (0|1|2) 0=too many tries, 1=open, 2=success
|
||||
lock Bool -- (0|1)
|
||||
timestamp UTCTime default=now()
|
||||
UniqueLmsReport qualification ident -- required by DBTable
|
||||
|
||||
4
routes
4
routes
@ -278,10 +278,10 @@
|
||||
/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET !token -- LMS
|
||||
/lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST
|
||||
/lms/#SchoolId/#QualificationShorthand/userlist/upload LmsUserlistUploadR GET POST !development
|
||||
/lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST !token -- LMS
|
||||
/lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST !token -- LMS, also remove JobLmsUserlist constructor
|
||||
/lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST
|
||||
/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST !development
|
||||
/lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST !token -- LMS
|
||||
/lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST !token -- LMS, also remove JobLmsResults constructor
|
||||
-- new V2 LMS Interface
|
||||
/lms/#SchoolId/#QualificationShorthand/learners LmsLearnersR GET
|
||||
/lms/#SchoolId/#QualificationShorthand/learners/direct LmsLearnersDirectR GET !token -- LMS
|
||||
|
||||
@ -141,11 +141,11 @@ mkReportTable sid qsh qid = do
|
||||
, dbtCsvExampleData = Just
|
||||
[ LmsReportTableCsv
|
||||
{ csvLRident = LmsIdent lid
|
||||
, csvLRdate = LmsDay $ addDays (-dos) now_day
|
||||
, csvLRdate = Just $ LmsDay $ addDays (-dos) now_day
|
||||
, csvLRresult = toEnum $ dos `mod` succ (fromEnum (maxBound :: LmsState))
|
||||
, csvLRlock = LmsBool $ even dos
|
||||
, csvLRlock = LmsBool $ even dos
|
||||
}
|
||||
| (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch", "x2!y3-z4"] [1..]
|
||||
| (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
|
||||
, lmsReportCsvLock = csvLRlock <&> LmsBool
|
||||
}
|
||||
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
|
||||
, lmsReportCsvLock = csvLRlock <&> LmsBool
|
||||
}
|
||||
DBCsvDiffMissing{} -> return () -- no deletion
|
||||
, dbtCsvClassifyAction = \case
|
||||
|
||||
@ -166,7 +166,7 @@ upsertQualificationUser qualificationUserQualification qualificationUserLastRef
|
||||
-- | Renew an existing qualification, ignoring all blocks
|
||||
renewValidQualificationUsers :: QualificationId -> [UserId] -> DB Int
|
||||
renewValidQualificationUsers qid uids =
|
||||
-- This code works in principle, but it does not allow audit log entries.
|
||||
-- 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
|
||||
-- E.where_ $ (qu E.^. QualificationUserQualification E.==. E.val qid )
|
||||
|
||||
@ -9,8 +9,9 @@ module Jobs.Handler.LMS
|
||||
, dispatchJobLmsQualificationsDequeue
|
||||
, dispatchJobLmsEnqueue, dispatchJobLmsEnqueueUser
|
||||
, dispatchJobLmsDequeue
|
||||
, dispatchJobLmsReports
|
||||
, dispatchJobLmsResults
|
||||
, dispatchJobLmsUserlist
|
||||
, dispatchJobLmsUserlist
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -232,7 +233,111 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
|
||||
deleteWhere [LmsResultQualification ==. qid, LmsResultIdent <-. delusers]
|
||||
-- deleteWhere [LmsAuditQualification ==. qid, LmsAuditIdent <-. delusers]
|
||||
|
||||
-- processes received results and lengthen qualifications, if applicable
|
||||
|
||||
dispatchJobLmsReports :: QualificationId -> JobHandler UniWorX
|
||||
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)
|
||||
E.update $ \luser -> do
|
||||
E.set luser [ LmsUserEnded E.=. E.justVal now ]
|
||||
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
|
||||
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.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
|
||||
lreport <- E.from $ E.table @LmsReport
|
||||
E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsReportIdent
|
||||
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)
|
||||
)
|
||||
updateReceivedLocked False
|
||||
updateReceivedLocked True
|
||||
-- load into memory all open learners that need to be processed -- TOO MUCH; SUBDIVIDE ALL CASES BEFORE QUERY
|
||||
|
||||
{- 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
|
||||
dispatchJobLmsResults qid = JobHandlerAtomic act
|
||||
where
|
||||
@ -295,7 +400,7 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
|
||||
$logInfoS "LMS" [st|Processed #{tshow (length results)} LMS results|]
|
||||
|
||||
|
||||
-- processes received input and block qualifications, if applicable
|
||||
-- DEPRECATED processes received input and block qualifications, if applicable
|
||||
dispatchJobLmsUserlist :: QualificationId -> JobHandler UniWorX
|
||||
dispatchJobLmsUserlist qid = JobHandlerAtomic act
|
||||
where
|
||||
|
||||
@ -128,8 +128,10 @@ data Job
|
||||
| JobLmsEnqueueUser { jQualification :: QualificationId, jUser :: UserId }
|
||||
| JobLmsQualificationsDequeue
|
||||
| JobLmsDequeue { jQualification :: QualificationId }
|
||||
| JobLmsUserlist { jQualification :: QualificationId }
|
||||
| JobLmsResults { jQualification :: QualificationId }
|
||||
| JobLmsUserlist { jQualification :: QualificationId } -- Deprecated, remove together with routes
|
||||
| JobLmsResults { jQualification :: QualificationId } -- Deprecated, remove together with routes
|
||||
| JobLmsReports { jQualification :: QualificationId }
|
||||
|
||||
deriving (Eq, Ord, Show, Read, Generic)
|
||||
data Notification
|
||||
= NotificationSubmissionRated { nSubmission :: SubmissionId }
|
||||
@ -359,7 +361,8 @@ jobNoQueueSame = \case
|
||||
JobLmsQualificationsDequeue -> Just JobNoQueueSame
|
||||
JobLmsDequeue {} -> Just JobNoQueueSame
|
||||
JobLmsUserlist {} -> Just JobNoQueueSame
|
||||
JobLmsResults {} -> Just JobNoQueueSame
|
||||
JobLmsResults {} -> Just JobNoQueueSame
|
||||
JobLmsReports {} -> Just JobNoQueueSame
|
||||
_ -> Nothing
|
||||
|
||||
notifyNoQueueSame :: Notification -> Maybe JobNoQueueSame
|
||||
|
||||
Loading…
Reference in New Issue
Block a user