From 19f77dad027724aa644d8ec8be277a2cb8ac6c98 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 5 Apr 2022 18:06:33 +0200 Subject: [PATCH] chore(lms): implement job handler to enqueue renewals --- models/lms.model | 6 +++--- src/Jobs/Handler/LMS.hs | 46 ++++++++++++++++++++++++++++++++--------- src/Jobs/Types.hs | 9 ++++---- 3 files changed, 44 insertions(+), 17 deletions(-) diff --git a/models/lms.model b/models/lms.model index 0daa2e96a..4b2e36ed6 100644 --- a/models/lms.model +++ b/models/lms.model @@ -58,9 +58,9 @@ QualificationUser -- LMS Interface Tables, need regular processing by background jobs, per QualificationId: -- -- 1. Daily Job: Add to LmsUser daily all qualification holders with - -- 0 <= QualificationUserValidUntil - now < QualificationRefreshWithin (time to schedule refresher) - -- /\ now - max(LmsUserStarted) > QualificationRefreshWithin (not already enlisted; Problem: QualificationELearningOnly!) - -- generate fresh ident and pin. (Bools?) + -- QualificationUserValidUntil >= now + -- /\ QualificationUserValudUntil <= now + QualificationRefreshWithin (time to schedule refresher) + -- /\ not already enlisted -- -- 2. REST GET User.csv: -- - where LmsUserReceived == Nothing \/ (LmsUserResetPin /\ LmsUserEnded == Nothing) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index c9928f54c..c2cb820a6 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -1,13 +1,14 @@ {-# LANGUAGE TypeApplications #-} module Jobs.Handler.LMS - ( dispatchJobLmsEnqueue + ( dispatchJobLmsEnqueue, dispatchJobLmsEnqueueUser , dispatchJobLmsDequeue , dispatchJobLmsResults , dispatchJobLmsUserlist ) where import Import +import Jobs.Queue -- import Jobs.Handler.Intervals.Utils import qualified Database.Esqueleto.Experimental as E @@ -18,14 +19,32 @@ import qualified Database.Esqueleto.Utils as E -- import Handler.Utils.DateTime (addDiffDays) dispatchJobLmsEnqueue :: QualificationId -> JobHandler UniWorX -dispatchJobLmsEnqueue _qid = JobHandlerAtomic act +dispatchJobLmsEnqueue qid = JobHandlerAtomic act where -- act :: YesodJobDB UniWorX () - act = hoist lift $ do - {- - now <- liftIO getCurrentTime - mbq <- E.selectOne $ E.from $ \quali -> E.where_ (quali E.^. QualificationId E.==. E.val qid) >> pure quali - -- Just quali <- get qid + act = do + quali <- getJust qid -- may throw an error, aborting the job + case qualificationRefreshWithin quali of + Nothing -> return () -- no automatic scheduling for this qid + (Just renewalPeriod) -> do + nowaday <- utctDay <$> liftIO getCurrentTime + let renewalDate = addGregorianDurationClip renewalPeriod nowaday + 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 nowaday + 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 E.^. QualificationUserUser) + forM_ renewalUsers (\uid -> queueDBJob JobLmsEnqueueUser { jQualification = qid, jUser = E.unValue uid } ) + + +{- + hoist lift $ do let (Entity _ quali) = fromMaybe (error "TODO") mbq -- HACK / TODO refreshTime = fromMaybe (error "TODO") $ qualificationRefreshWithin quali -- HACK / TODO @@ -51,7 +70,7 @@ dispatchJobLmsEnqueue _qid = JobHandlerAtomic act E.<# E.val qid E.<&> (quser E.^. QualificationUserUser) E.<&> E.val freshIdent -- ident -- THIS IS A PROBLEM! MUST ALSO BE UNIQUE! - E.<&> E.val freshPin -- pin -- THIS IS A PROBLEM! + E.<&> E.val freshPin -- pin -- can be done: E.unsafeSqlFunction "substring(gen_random_uuid()::text from 1 for 8)" E.<&> E.false -- reset E.<&> E.nothing -- status E.<&> E.val now -- started @@ -60,15 +79,22 @@ dispatchJobLmsEnqueue _qid = JobHandlerAtomic act ) -- find qualification holders - -} + - error "lms dequeu stub" + -} + +dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX +dispatchJobLmsEnqueueUser _qid _uid = + -- lident <- randomLMSIdent + -- lpw <- randomLMSpw + error "lms enqueue user stub" dispatchJobLmsDequeue :: QualificationId -> JobHandler UniWorX dispatchJobLmsDequeue _qid = -- wenn bestanden: qualification verlängern & LmsIdent löschen -- wenn durchgefallen: LmsIdent löschen -- wenn Zeit abgelaufen: LmsIdent löschen - error "lms dequeu stub" + error "lms dequeue stub" dispatchJobLmsResults :: QualificationId -> JobHandler UniWorX dispatchJobLmsResults qid = JobHandlerAtomic act diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index e971bfee9..c7fea5cbc 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -105,10 +105,11 @@ data Job , jEpoch , jIteration :: Natural } - | JobLmsEnqueue { jQualification :: QualificationId } - | JobLmsDequeue { jQualification :: QualificationId } - | JobLmsUserlist { jQualification :: QualificationId } - | JobLmsResults { jQualification :: QualificationId } + | JobLmsEnqueue { jQualification :: QualificationId } + | JobLmsEnqueueUser { jQualification :: QualificationId, jUser :: UserId } + | JobLmsDequeue { jQualification :: QualificationId } + | JobLmsUserlist { jQualification :: QualificationId } + | JobLmsResults { jQualification :: QualificationId } deriving (Eq, Ord, Show, Read, Generic, Typeable) data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }