244 lines
13 KiB
Haskell
244 lines
13 KiB
Haskell
{-# 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|]
|