diff --git a/models/lms.model b/models/lms.model index db9dc54e7..66d0ee24d 100644 --- a/models/lms.model +++ b/models/lms.model @@ -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 diff --git a/routes b/routes index 795f54292..f9bdd053b 100644 --- a/routes +++ b/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 diff --git a/src/Handler/LMS/Report.hs b/src/Handler/LMS/Report.hs index 2536fa794..0eb96d185 100644 --- a/src/Handler/LMS/Report.hs +++ b/src/Handler/LMS/Report.hs @@ -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 diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index 9fd19c74f..d31a4a9d6 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -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 ) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 8264fdba0..225e0573c 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -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 diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 60eee0b4c..c6bdd8ee1 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -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