chore(lms): job dequeue implemented, deleting missing still
This commit is contained in:
Steffen Jost
parent
9fe564ee25
commit
05423d4515
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 --
|
||||
---------
|
||||
|
||||
Loading…
Reference in New Issue
Block a user