diff --git a/models/lms.model b/models/lms.model index 7f6437260..750045876 100644 --- a/models/lms.model +++ b/models/lms.model @@ -1,4 +1,5 @@ Qualification + -- INVARIANT: 2*refreshWithin < validDuration school SchoolId --TODO: Ansprechpartner der Schule in Briefe erwähnen shorthand (CI Text) name (CI Text) @@ -85,7 +86,7 @@ QualificationUser -- - move row to LmsAudit -- -- 7. Daily Job: dequeue LMS Users - -- - + -- - renew qualification, if passed -- - remove from LmsUser after audit Period has passed LmsUser diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 88bfdc345..2990ca28f 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -86,6 +86,10 @@ true = E.val True false :: E.SqlExpr (E.Value Bool) false = E.val False +-- Timestamp larger than any other; not sure if this is a good idea to use +-- infinity :: E.SqlExpr (E.Value UTCTime) +-- infinity = unsafeSqlValue "'infinity'" + justVal :: PersistField typ => typ -> E.SqlExpr (E.Value (Maybe typ)) justVal = E.val . Just diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 21fb0df59..9138a1cf4 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -181,7 +181,7 @@ mkLmsTable (Entity qid quali) = do lift $ do E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser - E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification + E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification return (qualUser, user, lmsUser) dbtRowKey = queryUser >>> (E.^. UserId) diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index ad321b2b4..d134c3ebd 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -172,7 +172,7 @@ mkLmsTable (Entity qid quali) = do lift $ do E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser - E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification + E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification return (qualUser, user, lmsUser) dbtRowKey = queryUser >>> (E.^. UserId) diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index e04a8e455..8f6878216 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -14,6 +14,7 @@ module Handler.Utils.DateTime , validDateTimeFormats, dateTimeFormatOptions , addLocalDays, addDiffDays , addOneWeek, addWeeks + , fromMonths , weeksToAdd , setYear, getYear , firstDayOfWeekOnAfter @@ -251,6 +252,14 @@ addLocalDays n utct = localTimeToUTCTZ appTZ newLocal newDay = addDays n oldDay newLocal = oldLocal { localDay = newDay } +---------------------- +-- CalendarDiffDays -- +---------------------- + +fromMonths :: Word -> CalendarDiffDays +fromMonths m = scaleCalendarDiffDays (toInteger m) calendarMonth +-- fromMonths m = CalendarDiffDays { cdMonths = m, cdDays = 0 } -- above is equivalent + addDiffDays :: CalendarDiffDays -> UTCTime -> UTCTime addDiffDays = over _utctDay . addGregorianDurationClip diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index a3bf653fc..ee93206d4 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -2,6 +2,7 @@ module Jobs.Handler.LMS ( dispatchJobLmsQualifications + , dispatchJobQualificationsDequeue , dispatchJobLmsEnqueue, dispatchJobLmsEnqueueUser , dispatchJobLmsDequeue , dispatchJobLmsResults @@ -17,7 +18,7 @@ import qualified Database.Esqueleto.Experimental as E -- import qualified Database.Esqueleto.PostgreSQL as E -- for insertSelect variant import qualified Database.Esqueleto.Utils as E --- import Handler.Utils.DateTime (addDiffDays) +import Handler.Utils.DateTime (fromMonths) import Handler.Utils.LMS (randomLMSIdent, randomLMSpw, maxLmsUserIdentRetries) @@ -31,17 +32,18 @@ dispatchJobLmsQualifications = JobHandlerAtomic act E.where_ $ E.isJust (q E.^. QualificationRefreshWithin) -- E.&&. q E.^. QualificationElearningStart -- checked later, since we need to send out notifications regardless pure $ q E.^. QualificationId - forM_ qids $ \(E.unValue -> qid) -> do - $logInfoS "lms" $ "Start e-learning for qualification " <> tshow qid <> "." + forM_ qids $ \(E.unValue -> qid) -> queueDBJob $ JobLmsEnqueue 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 - -- TODO: get rid of QualificationId Parameter and use a join instead? Fails since addGregorianDurationClip cannot be performed within DB + where -- act :: YesodJobDB UniWorX () act = do + $logInfoS "lms" $ "Start e-learning users for qualification " <> tshow qid <> "." quali <- getJust qid -- may throw an error, aborting the job case qualificationRefreshWithin quali of Nothing -> return () -- no automatic scheduling for this qid @@ -98,12 +100,58 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act } +dispatchJobQualificationsDequeue :: JobHandler UniWorX +dispatchJobQualificationsDequeue = JobHandlerAtomic act + where + act :: YesodJobDB UniWorX () + act = do + qids <- E.select $ do + q <- E.from $ E.table @Qualification + E.where_ $ E.isJust (q E.^. QualificationRefreshWithin) + -- E.&&. q E.^. QualificationElearningStart -- checked later, since we need to send out notifications regardless + pure $ q E.^. QualificationId + forM_ qids $ \(E.unValue -> qid) -> + queueDBJob $ JobLmsEnqueue qid + 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 "TODO: lms dequeue stub" +dispatchJobLmsDequeue qid = JobHandlerAtomic act + -- wenn bestanden: qualification verlängern + -- wenn Aufbewahrungszeit abgelaufen: LmsIdent löschen (verhindert verfrühten neustart) + where + act = do + $logInfoS "lms" $ "Process e-learning results for qualification " <> tshow qid <> "." + 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 + + -- CONTINUE HERE: + -- select users that need renewal due to success + -- 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 nowaday -- 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) + let usr_job (quser, luser) = + let vold = quser ^. _entityVal . _qualificationUserValidUntil + pmonth = fromMonths $ fromMaybe 0 $ qualificationValidDuration quali -- TODO: decide how to deal with qualfication that have infinite validity?! + vnew = addGregorianDurationClip pmonth vold + lmsstatus = luser ^. _entityVal . _lmsUserStatus + in case lmsstatus of + Just (LmsSuccess refreshDay) -> update (quser ^. _entityKey) [QualificationUserValidUntil =. vnew, QualificationUserLastRefresh =. refreshDay] + _ -> return () + forM_ renewalUsers usr_job + dispatchJobLmsResults :: QualificationId -> JobHandler UniWorX dispatchJobLmsResults qid = JobHandlerAtomic act diff --git a/src/Utils/DateTime.hs b/src/Utils/DateTime.hs index 8df9cc792..f97596ef3 100644 --- a/src/Utils/DateTime.hs +++ b/src/Utils/DateTime.hs @@ -12,8 +12,7 @@ module Utils.DateTime , nominalHour, nominalMinute , minNominalYear, avgNominalYear , diffMinute, diffHour, diffDay - , module Zones - , fromMonths + , module Zones , day ) where @@ -30,7 +29,7 @@ import Data.Time.Format.Instances () import Data.Time.Clock.System (systemEpochDay) import qualified Data.Time.Format.ISO8601 as Time import qualified Data.Time.Format as Time -import Data.Time.Calendar (CalendarDiffDays, calendarMonth, scaleCalendarDiffDays) +-- import Data.Time.Calendar (CalendarDiffDays, calendarMonth, scaleCalendarDiffDays) import qualified Data.List.NonEmpty as NonEmpty @@ -161,13 +160,6 @@ diffMinute = 60 diffHour = 3600 diffDay = 86400 ----------------------- --- CalendarDiffDays -- ----------------------- - -fromMonths :: Word -> CalendarDiffDays -fromMonths m = scaleCalendarDiffDays (toInteger m) calendarMonth - --------- -- Day -- ---------