{-# 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 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 Handler.Utils.DateTime import Handler.Utils.LMS (randomLMSIdent, randomLMSpw, maxLmsUserIdentRetries) 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.^. QualificationUserValidUntil E.>=. E.val now_day E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate 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 ) 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 now <- liftIO getCurrentTime let mkLmsUser lid lpin = 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 = E.insertUniqueEntity =<< (mkLmsUser <$> randomLMSIdent <*> randomLMSpw) 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 adter 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 -- purge 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 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 quali <- getJust qid whenIsJust (qualificationValidDuration quali) $ \renewalMonths -> do -- otherwise there is nothing to do: we cannot renew s qualification without a specified validDuration -- result :: [(Entity QualificationUser, Entity LmsUser, Entity LmsResult)] results <- E.select $ do (quser E.:& luser E.:& 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 E.:& luser) -> luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser E.&&. luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification) `E.innerJoin` E.table @LmsResult `E.on` (\(_ E.:& luser E.:& 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 E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners return (quser, luser, lresult) now <- liftIO getCurrentTime 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 nowadayP1 = succ $ utctDay now -- add one day to account for time synch problems lmsUserStartedDay = utctDay lmsUserStarted saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil nowadayP1) && qualificationUserLastRefresh <= lmsUserStartedDay newStatus = LmsSuccess lmsResultSuccess newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards note <- if saneDate && isLmsSuccess newStatus then do update quid [ QualificationUserValidUntil =. newValidTo , QualificationUserLastRefresh =. lmsResultSuccess ] update luid [ LmsUserStatus =. Just 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 insert_ $ LmsAudit qid lmsUserIdent newStatus note lmsResultTimestamp now -- always log success, since this is only transmitted once 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 E.:& lulist) <- E.from $ E.table @LmsUser `E.leftJoin` E.table @LmsUserlist `E.on` (\(luser E.:& 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 when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available queueDBJob JobSendNotification { jRecipient = lmsUserUser luser , jNotification = NotificationQualificationRenewal { nQualification = qid } } -- update luid [ LmsUserNotified =. Just now ] -- wird erst beim tatsächlichen senden gesetzt! let lReceived = lmsUserlistTimestamp lulist isBlocked = lmsUserlistFailed lulist update luid [LmsUserReceived =. Just lReceived] when isBlocked $ do let newStatus = LmsBlocked $ utctDay lReceived oldStatus = lmsUserStatus luser insert_ $ LmsAudit qid (lmsUserIdent luser) newStatus (Just $ "Old Status was " <> tshow oldStatus) lReceived now update luid [LmsUserStatus =. (oldStatus <> Just newStatus)] updateBy (UniqueQualificationUser qid (lmsUserUser luser)) [QualificationUserBlockedDue =. Just (QualificationBlockedLms (utctDay lReceived))] delete lulid $logInfoS "LmsUserlist" [st|Processed LMS Userlist with ${tshow (length results)} entries|]