-- SPDX-FileCopyrightText: 2022-23 Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# LANGUAGE TypeApplications #-} module Jobs.Handler.LMS ( dispatchJobLmsQualificationsEnqueue , dispatchJobLmsQualificationsDequeue , dispatchJobLmsEnqueue, dispatchJobLmsEnqueueUser , dispatchJobLmsDequeue , dispatchJobLmsResults , dispatchJobLmsUserlist ) where import Import import Jobs.Queue -- import Jobs.Handler.Intervals.Utils import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E --import qualified Database.Esqueleto.Legacy as E -- import qualified Database.Esqueleto.PostgreSQL as E -- for insertSelect variant import qualified Database.Esqueleto.Utils as E import qualified Data.Set as Set import qualified Data.Time.Zones as TZ import Handler.Utils.DateTime import Handler.Utils.LMS (randomLMSIdentBut, randomLMSpw, maxLmsUserIdentRetries) import Handler.Utils.Qualification import qualified Data.CaseInsensitive as CI dispatchJobLmsQualificationsEnqueue :: JobHandler UniWorX dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsEnqueue dispatchJobLmsQualificationsDequeue :: JobHandler UniWorX dispatchJobLmsQualificationsDequeue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsDequeue -- execute given job for all qualifications that allow refreshs fetchRefreshQualifications :: (QualificationId -> Job) -> YesodJobDB UniWorX () fetchRefreshQualifications qidJob = do qids <- E.select $ do q <- E.from $ E.table @Qualification E.where_ $ E.isJust (q E.^. QualificationRefreshWithin) pure $ q E.^. QualificationId forM_ qids $ \(E.unValue -> qid) -> queueDBJob $ qidJob qid -- | enlist expiring qualification holders to e-learning -- NOTE: getting rid of QualificationId parameter and using a DB-join fails, since addGregorianDurationClip cannot be performed within DB dispatchJobLmsEnqueue :: QualificationId -> JobHandler UniWorX dispatchJobLmsEnqueue qid = JobHandlerAtomic act where -- act :: YesodJobDB UniWorX () act = do quali <- getJust qid -- may throw an error, aborting the job let qshort = CI.original $ qualificationShorthand quali $logInfoS "LMS" $ "Notifying about exipiring qualification " <> qshort now <- liftIO getCurrentTime case qualificationRefreshWithin quali of Nothing -> return () -- TODO: no renewal period, no reminders currenty (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 (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 ) E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid E.&&. quser E.^. QualificationUserScheduleRenewal E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val remindDate E.&&. validQualification now quser E.&&. E.isNothing (luser E.^. LmsUserEnded) E.&&. E.isNothing (luser E.^. LmsUserStatus) E.&&. E.isJust (luser E.^. LmsUserNotified) -- E.&&. ((day_ (luser E.^. LmsUserNotified) E.+. E.interval remindPeriod) E.<. quser E.^. QualificationUserValidUntil) -- not sure whether may throw runtime errors, so we check in Haskell-Land instead return (luser, quser E.^. QualificationUserValidUntil) forM_ reminders $ \case (Entity _ LmsUser{lmsUserUser=luser, lmsUserNotified=Just lnotified}, E.Value quValidUntil) | addGregorianDurationClip remindPeriod (utctDay lnotified) < quValidUntil -> queueDBJob JobUserNotification { jRecipient = luser , jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = True } } _ -> return () -- send second reminders first, before enqueing even more ifMaybeM (qualificationRefreshReminder quali) () sendReminders 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.^. QualificationUserValidUntil E.<=. E.val renewalDate E.&&. (quser `qualificationValid` now) E.&&. E.notExists (do luser <- E.from $ E.table @LmsUser E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser E.&&. E.isNothing (luser E.^. LmsUserEnded) ) pure quser let usr_job :: Entity QualificationUser -> Job usr_job quser = let uid = quser ^. _entityVal . _qualificationUserUser uex = quser ^. _entityVal . _qualificationUserValidUntil in if qualificationElearningStart quali then JobLmsEnqueueUser { jQualification = qid, jUser = uid } else JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationExpiry { nQualification = qid, nExpiry = uex } } forM_ renewalUsers (queueDBJob . usr_job) dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act where act :: YesodJobDB UniWorX () 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.union_` ( (E.^. LmsResultIdent) <$> E.from (E.table @LmsResult ) ) `E.union_` ( (E.^. LmsUserIdent) <$> E.from (E.table @LmsUser ) ) E.orderBy [E.asc lui] pure lui now <- liftIO getCurrentTime let identsInUse = Set.fromList (E.unValue <$> identsInUseVs) mkLmsUser lpin lid = LmsUser { lmsUserQualification = qid , lmsUserUser = uid , lmsUserIdent = lid , lmsUserPin = lpin , lmsUserResetPin = False , lmsUserDatePin = now , lmsUserStatus = Nothing , lmsUserStatusDay = Nothing , lmsUserStarted = now , lmsUserReceived = Nothing , lmsUserNotified = Nothing , lmsUserEnded = Nothing } -- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser)) startLmsUser = do pw <- randomLMSpw maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser pw) (randomLMSIdentBut identsInUse) inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser case inserted of Nothing -> do uuid :: CryptoUUIDUser <- encrypt uid $logErrorS "LMS" $ "Generating and inserting fresh LmsIdent failed for uuid " <> tshow uuid <> " and qid " <> tshow qid <> "!" (Just _) -> return () -- lmsUser started, but not yet notified -- purge LmsIdent after QualificationAuditDuration expired dispatchJobLmsDequeue :: QualificationId -> JobHandler UniWorX dispatchJobLmsDequeue qid = JobHandlerAtomic act where act = do quali <- getJust qid -- may throw an error, aborting the job let qshort = CI.original $ qualificationShorthand quali $logInfoS "LMS" $ "Processing e-learning results for qualification " <> qshort now <- liftIO getCurrentTime let nowaday = utctDay now -- end users that expired by doing nothing expiredLearners <- E.select $ do (quser :& luser) <- E.from $ E.table @QualificationUser `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.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid E.&&. luser E.^. LmsUserQualification E.==. E.val qid E.&&. E.isNothing (luser E.^. LmsUserStatus) E.&&. E.isNothing (luser E.^. LmsUserEnded) E.&&. E.not_ (validQualification now quser) 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) E.&&. luser E.^. LmsUserQualification E.==. E.val qid $logInfoS "LMS" $ "Expired lms users " <> tshow nrExpired <> " for qualification " <> qshort when (quali ^. _qualificationExpiryNotification) $ do 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) forM_ notifyInvalidDrivers $ \(E.Value uid) -> queueDBJob JobUserNotification { jRecipient = uid , jNotification = NotificationQualificationExpired { nQualification = qid } } -- purge outdated LmsUsers case qualificationAuditDuration quali of Nothing -> return () -- no automatic removal (Just auditDuration) -> do let auditCutoff = addDiffDaysRollOver (fromMonths $ negate auditDuration) now $logInfoS "LMS" $ "Audit Cuttoff at " <> tshow auditCutoff <> " for Audit Duration " <> tshow auditDuration <> " for qualification " <> qshort delusersVals <- E.select $ do luser <- E.from $ E.table @LmsUser E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid E.&&. luser E.^. LmsUserEnded E.<. E.justVal auditCutoff E.&&. E.isJust (luser E.^. LmsUserEnded) -- E.&&. E.notExists (do -- laudit <- E.from $ E.table @LmsAudit -- E.where_ $ laudit E.^. LmsAuditQualification E.==. E.val qid -- E.&&. laudit E.^. LmsAuditIdent E.==. luser E.^. LmsUserIdent -- E.&&. laudit E.^. LmsAuditProcessed E.>=. E.val auditCutoff -- ) pure (luser E.^. LmsUserIdent) let delusers = E.unValue <$> delusersVals 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] deleteWhere [LmsUserlistQualification ==. qid, LmsUserlistIdent <-. delusers] deleteWhere [LmsResultQualification ==. qid, LmsResultIdent <-. delusers] -- deleteWhere [LmsAuditQualification ==. qid, LmsAuditIdent <-. delusers] -- processes received results and lengthen qualifications, if applicable dispatchJobLmsResults :: QualificationId -> JobHandler UniWorX dispatchJobLmsResults qid = JobHandlerAtomic act where -- act :: YesodJobDB UniWorX () act = hoist lift $ do results <- E.select $ do (quser :& luser :& lresult) <- 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 @LmsResult `E.on` (\(_ :& luser :& lresult) -> luser E.^. LmsUserIdent E.==. lresult E.^. LmsResultIdent E.&&. luser E.^. LmsUserQualification E.==. lresult E.^. LmsResultQualification) E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid E.&&. luser E.^. LmsUserQualification E.==. E.val qid -- E.&&. E.isNothing (luser E.^. LmsUserStatus) -- do not process learners already having a result WORKAROUND LMS-Bug: LMS may send blocked & success simultanesouly or within a few hours; in this case, success is the correct meaning E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners return (quser, luser, lresult) now <- liftIO getCurrentTime let locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now forM_ results $ \(Entity _quid QualificationUser{..}, Entity luid LmsUser{..}, Entity lrid LmsResult{..}) -> do -- 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 -- 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|] -- processes received input and block qualifications, if applicable dispatchJobLmsUserlist :: QualificationId -> JobHandler UniWorX dispatchJobLmsUserlist qid = JobHandlerAtomic act where act :: YesodJobDB UniWorX () act = do now <- liftIO getCurrentTime -- result :: [(Entity LmsUser, Entity LmsUserlist)] results <- E.select $ do (luser :& lulist) <- E.from $ E.table @LmsUser `E.leftJoin` E.table @LmsUserlist `E.on` (\(luser :& lulist) -> luser E.^. LmsUserIdent E.=?. lulist E.?. LmsUserlistIdent E.&&. luser E.^. LmsUserQualification E.=?. lulist E.?. LmsUserlistQualification) E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners return (luser, lulist) forM_ results $ \case (Entity luid luser, Nothing) | isJust $ lmsUserReceived luser -- mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected) , isNothing $ lmsUserEnded luser -> update luid [LmsUserEnded =. Just now] | otherwise -> return () -- users likely not yet started (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 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] ok <- qualificationUserBlocking qid [lmsUserUser luser] False (Right QualificationBlockFailedELearning) True 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}] audit TransactionLmsBlocked { transactionQualification = qid , transactionLmsIdent = lmsUserIdent luser , transactionLmsDay = lmsMsgDay , transactionLmsUser = Just $ lmsUserUser luser , transactionNote = Just $ "Old status was " <> tshow oldStatus , transactionReceived = lReceived } delete lulid $logInfoS "LMS" [st|Processed LMS Userlist with #{tshow (length results)} entries|]