{-# 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 $logInfoS "lms" $ "Notifying about exipiring qualification " <> tshow qid <> "." quali <- getJust qid -- may throw an error, aborting the job 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 -> $logErrorS "LMS" $ "Generating and inserting fresh LmsIdent failed for uid " <> tshow uid <> " and qid " <> tshow qid <> "!" (Just _) -> return () -- lmsUser started, but not yet notified -- process all received input and renew or block qualifications dispatchJobLmsDequeue :: QualificationId -> JobHandler UniWorX dispatchJobLmsDequeue qid = JobHandlerAtomic act -- wenn Aufbewahrungszeit abgelaufen: LmsIdent löschen (verhindert verfrühten neustart) where act = do $logInfoS "lms" $ "Processing e-learning results for qualification " <> tshow qid <> "." quali <- getJust qid -- may throw an error, aborting the job now <- liftIO getCurrentTime -- purge LmsUsers case qualificationAuditDuration quali of Nothing -> return () -- no automatic removal (Just auditDuration) -> let auditCutoff = addDiffDaysRollover (fromMonths $ negate auditDuration) now delusers <- fmap E.unValue $ 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 audit <- E.from $ E.table @LmsAudit E.where_ $ audit E.^. LmsAuditQualification E.==. E.val qid E.&&. audit E.^. LmsAuditIdent E.==. luser E.^. LmsUserIdent E.&&. audit E.^. LmsAuditProcessed E.>=. E.val auditCutoff ) pure (luser E.^. LmsUserIdent) deleteWhere [LmsUserQualification ==. qid, LmsUserIdent <-. delusers] deleteWhere [LmsUserlistQualification ==. qid, LmsUserlistIdent <-. delusers] deleteWhere [LmsResult ==. qid, LmsResultIdent <-. delusers] deleteWhere [LmsAudit ==. qid, LmsAuditIdent <-. delusers] deleteWhere [LmsUserQualification ==. qid, LmsUserEnded !=. Nothing, LmsUserEnded <. Just lmsCutoff] -- purge LmsAudit in E.delete $ do audit <- E.from $ E.table @LmsAudit E.where_ $ audit E.^. LmsAuditQualification E.==. E.val qid E.&&. E.notExists (do luser <- E.from $ E.table @LmsUser E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid E.&&. luser E.^. LmsUserIdent E.==. audit E.^. LmsAuditIdent ) E.groupBy $ audit E.^. LmsAuditIdent E.having $ E.val auditCutoff E.<. E.max_ (audit E.^. LmsAuditProcessed) in deleteWhere [LmsAuditQualification ==. qid, LmsAuditProcessed >. Just deleteDate] let auditCutoff = nowadayP1 = succ $ utctDay now -- add one day to account for time synch problems renewalMonths :: Word = fromMaybe (error ("Cannot renew qualification " <> citext2string (qualificationShorthand quali) <> " without specified validDuration!")) (qualificationValidDuration quali) case qualificationRefreshWithin quali of Nothing -> return () -- no automatic deletion (Just auditDuration) -> return () -- TODO deleteWhere [LmsUserEnded >. ] {- do now_day <- utctDay <$> liftIO getCurrentTime let _renewalDate = addGregorianDurationClip renewalPeriod now_day -- CONTINUE HERE: TODO -- delete users after audit period has expired!!! _renewalUsers <- E.select $ do (quser E.:& luser) <- E.from $ E.table @QualificationUser `E.innerJoin` E.table @LmsUser `E.on` (\(quser E.:& luser) -> quser E.^. QualificationUserUser E.==. luser E.^. LmsUserUser E.&&. quser E.^. QualificationUserQualification E.==. luser E.^. LmsUserQualification ) E.where_ $ E.val qid E.==. quser E.^. QualificationUserQualification E.&&. E.val qid E.==. luser E.^. LmsUserQualification E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val now_day -- still valid -- E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate -- due to renewal E.&&. E.isJust (luser E.^. LmsUserStatus) -- TODO: should check for success -- result already known pure (quser, luser) -} -- 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 now <- liftIO getCurrentTime let nowadayP1 = succ $ utctDay now -- add one day to account for time synch problems renewalMonths :: Word = fromMaybe (error ("Cannot renew qualification " <> citext2string (qualificationShorthand quali) <> " without specified validDuration!")) (qualificationValidDuration quali) -- 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) 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 = utctDay lmsUserStarted saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil nowadayP1) && qualificationUserLastRefresh <= lmsUserStartedDay newStatus = LmsSuccess lmsResultSuccess newValidTo = addGregorianMonthsRollover (toIntger 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) $ -- notify users that lms is available queueDBJob JobSendNotification { jRecipient = lmsUserUser luser , jNotification = NotificationQualificationRenewal { nQualification = qid } } 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|]