-- SPDX-FileCopyrightText: 2022 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 () -- no automatic scheduling for this qid (Just renewalPeriod) -> do let now_day = utctDay now renewalDate = addGregorianDurationClip renewalPeriod now_day 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 now_day E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate E.&&. E.isNothing (quser E.^. QualificationUserBlockedDue) 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 JobSendNotification { 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) ) `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 , 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_ $ E.isNothing (luser E.^. LmsUserStatus) E.&&. E.isNothing (luser E.^. LmsUserEnded) E.&&. E.not_ (validQualification nowaday quser) pure (luser E.^. LmsUserId) nrExpired <- E.updateCount $ \luser -> do E.set luser [LmsUserStatus E.=. E.justVal (LmsExpired nowaday)] E.where_ $ (luser E.^. LmsUserId) `E.in_` E.valList (E.unValue <$> expiredLearners) $logInfoS "LMS" $ "Expired lms users " <> tshow nrExpired <> " for qualification " <> qshort notifyInvalidDrivers <- E.select $ do quser <- E.from $ E.table @QualificationUser E.where_ $ E.not_ (validQualification nowaday quser) E.&&. (( E.isNothing (quser E.^. QualificationUserBlockedDue) E.&&. (E.day (quser E.^. QualificationUserLastNotified) E.<. quser E.^. QualificationUserValidUntil) ) E.||. ( E.isJust (quser E.^. QualificationUserBlockedDue) E.&&. (E.day (quser E.^. QualificationUserLastNotified) E.<. ((quser E.^. QualificationUserBlockedDue) E.->. "day" :: E.SqlExpr (E.Value Day))) )) pure (quser E.^. QualificationUserUser) forM_ notifyInvalidDrivers $ \(E.Value uid) -> queueDBJob JobSendNotification { 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.just (E.val 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 newStatus = Just $ LmsSuccess lmsResultSuccess -- newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards note <- if saneDate && replaceLmsStatus lmsUserStatus newStatus then do _ok <- renewValidQualificationUsers qid [qualificationUserUser] -- ignores possible blocks -- when (ok==1) $ update luid -- we end lms regardless of wether a regular renewal was successful, since BPol users may simultaneoysly have on-premise renewal courses and E-Learnings -- 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 -- _ok <- qualificationUserUnblockByReason qid [qualificationUserUser] (qualificationBlockedReasonText QualificationBlockFailedELearning) -- affects audit log when (Just (qualificationBlockedReasonText QualificationBlockFailedELearning) == qualificationUserBlockedDue ^? _Just . _qualificationBlockedReason) $ update quid [ QualificationUserBlockedDue =. Nothing ] update luid [ LmsUserStatus =. newStatus , LmsUserReceived =. Just lmsResultTimestamp ] return Nothing else do let errmsg = [st|LMS success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent}|] $logErrorS "LmsResult" 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 "LmsResult" [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 -- $logInfoS "LmsUserlist" $ tshow lulist when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available queueDBJob JobSendNotification { jRecipient = lmsUserUser luser , jNotification = NotificationQualificationRenewal { nQualification = qid } } let isBlocked = lmsUserlistFailed lulist oldStatus = lmsUserStatus luser newStatus = bool Nothing (Just $ LmsBlocked lmsMsgDay) isBlocked updateStatus = replaceLmsStatus oldStatus newStatus when updateStatus $ do audit TransactionLmsBlocked { transactionQualification = qid , transactionLmsIdent = lmsUserIdent luser , transactionLmsDay = lmsMsgDay , transactionLmsUser = Just $ lmsUserUser luser , transactionNote = Just $ "Old status was " <> tshow oldStatus , transactionReceived = lReceived } update luid [LmsUserStatus =. newStatus] void $ qualificationUserBlocking qid [lmsUserUser luser] $ Just $ mkQualificationBlocked QualificationBlockFailedELearning lmsMsgDay -- DEACTIVATED FOR NOW; UPON REACTIVATION: DELAY Sending to check for unblocking a few hours later! -- queueDBJob JobSendNotification -- { jRecipient = lmsUserUser luser -- , jNotification = NotificationQualificationExpired { nQualification = qid } -- } delete lulid $logInfoS "LmsUserlist" [st|Processed LMS Userlist with ${tshow (length results)} entries|]