546 lines
34 KiB
Haskell
546 lines
34 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <s.jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# LANGUAGE TypeApplications #-}
|
|
|
|
module Jobs.Handler.LMS
|
|
( dispatchJobLmsQualificationsEnqueue
|
|
, dispatchJobLmsQualificationsDequeue
|
|
, dispatchJobLmsEnqueue, dispatchJobLmsEnqueueUser
|
|
, dispatchJobLmsDequeue
|
|
, dispatchJobLmsReports
|
|
, dispatchJobLmsResults
|
|
, dispatchJobLmsUserlist
|
|
) where
|
|
|
|
import Import
|
|
import Jobs.Queue
|
|
|
|
-- import Jobs.Handler.Intervals.Utils
|
|
import Database.Persist.Sql -- (deleteWhereCount, updateWhereCount)
|
|
import Database.Esqueleto.Experimental ((:&)(..))
|
|
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 qualified Data.Set as Set
|
|
-- import qualified Data.Map as Map
|
|
|
|
import qualified Data.Time.Zones as TZ
|
|
import Handler.Utils.DateTime
|
|
import Handler.Utils.LMS (randomLMSIdentBut, randomLMSpw, maxLmsUserIdentRetries)
|
|
import Handler.Utils.Qualification
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
import qualified Data.Text as Text
|
|
|
|
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 () -- TODO: no renewal period, no reminders currently
|
|
(Just renewalPeriod) -> do
|
|
let nowaday = utctDay now
|
|
renewalDate = addGregorianDurationClip renewalPeriod nowaday
|
|
sendReminders remindPeriod = do
|
|
let remindDate = addGregorianDurationClip remindPeriod nowaday
|
|
reminders <- E.select $ do -- TODO: refactor to remove some redundancies with later query
|
|
(luser :& quser) <- E.from $ E.table @LmsUser `E.innerJoin` E.table @QualificationUser
|
|
`E.on` (\(luser :& quser) -> luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification
|
|
E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
|
|
)
|
|
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
|
|
E.&&. quser E.^. QualificationUserScheduleRenewal
|
|
E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val remindDate
|
|
E.&&. validQualification now quser
|
|
E.&&. E.isNothing (luser E.^. LmsUserEnded)
|
|
E.&&. E.isNothing (luser E.^. LmsUserStatus)
|
|
E.&&. E.isJust (luser E.^. LmsUserNotified)
|
|
-- E.&&. ((day_ (luser E.^. LmsUserNotified) E.+. E.interval remindPeriod) E.<. quser E.^. QualificationUserValidUntil) -- not sure whether may throw runtime errors, so we check in Haskell-Land instead
|
|
return (luser, quser E.^. QualificationUserValidUntil)
|
|
forM_ reminders $ \case
|
|
(Entity _ LmsUser{lmsUserUser=luser, lmsUserNotified=Just lnotified}, E.Value quValidUntil)
|
|
| addGregorianDurationClip remindPeriod (utctDay lnotified) < quValidUntil ->
|
|
queueDBJob JobUserNotification
|
|
{ jRecipient = luser
|
|
, jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = True }
|
|
}
|
|
_ -> return ()
|
|
-- send second reminders first, before enqueing even more
|
|
ifMaybeM (qualificationRefreshReminder quali) () sendReminders
|
|
|
|
renewalUsers <- E.select $ do
|
|
quser <- E.from $ E.table @QualificationUser
|
|
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
|
|
E.&&. quser E.^. QualificationUserScheduleRenewal
|
|
E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate
|
|
E.&&. (quser `qualificationValid` now)
|
|
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
|
|
E.&&. E.isNothing (luser E.^. LmsUserEnded)
|
|
)
|
|
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 JobUserNotification { 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
|
|
quali <- getJust qid -- may throw an error, aborting the job
|
|
let qshort = CI.original $ qualificationShorthand quali
|
|
qprefix = fst <$> Text.uncons (Text.toLower qshort)
|
|
identsInUseVs <- E.select $ do
|
|
lui <- E.from $
|
|
|
|
( (E.^. LmsUserIdent) <$> E.from (E.table @LmsUser ) ) -- no filter by Qid, since LmsIdents must be unique across all
|
|
`E.union_`
|
|
( (E.^. LmsReportIdent) <$> E.from (E.table @LmsReport ) ) -- V2
|
|
`E.union_`
|
|
( (E.^. LmsResultIdent) <$> E.from (E.table @LmsResult ) ) -- V1 DEPRECATED
|
|
`E.union_`
|
|
( (E.^. LmsUserlistIdent) <$> E.from (E.table @LmsUserlist) ) -- V1 DEPRECATED
|
|
E.orderBy [E.asc lui]
|
|
pure lui
|
|
now <- liftIO getCurrentTime
|
|
let identsInUse = Set.fromList (E.unValue <$> identsInUseVs)
|
|
mkLmsUser lpin lid = LmsUser
|
|
{ lmsUserQualification = qid
|
|
, lmsUserUser = uid
|
|
, lmsUserIdent = lid
|
|
, lmsUserPin = lpin
|
|
, lmsUserResetPin = False
|
|
, lmsUserDatePin = now
|
|
, lmsUserStatus = Nothing
|
|
, lmsUserStatusDay = Nothing
|
|
, lmsUserStarted = now
|
|
, lmsUserReceived = Nothing
|
|
, lmsUserNotified = Nothing
|
|
, lmsUserEnded = Nothing
|
|
, lmsUserResetTries = False
|
|
, lmsUserLocked = True -- initially display locked, since it is not yet available until the first feedback
|
|
}
|
|
-- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser))
|
|
startLmsUser = do
|
|
lpw <- randomLMSpw
|
|
maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser lpw) (randomLMSIdentBut qprefix identsInUse)
|
|
-- runMaybeT $ do
|
|
-- lid <- MaybeT $ randomLMSIdentBu qprefix identsInUse
|
|
-- MaybeT $ E.insertUniqueEntity $ mkLmsUser lpw lid
|
|
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 Entity{entityKey=lkey, entityVal=LmsUser{lmsUserIdent=lid, lmsUserUser=luid, lmsUserQualification=lqid}}) -> -- lmsUser started, but not yet notified
|
|
audit $ TransactionLmsStart
|
|
{ transactionQualification = lqid
|
|
, transactionLmsIdent = lid
|
|
, transactionLmsUser = luid
|
|
, transactionLmsUserKey = lkey
|
|
}
|
|
|
|
|
|
-- purge LmsIdent after 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
|
|
-- end users that expired by doing nothing
|
|
expiredUsers <- E.select $ do
|
|
(quser :& luser) <- E.from $
|
|
E.table @QualificationUser
|
|
`E.leftJoin` E.table @LmsUser
|
|
`E.on` (\(quser :& luser) ->
|
|
luser E.?. LmsUserUser E.?=. quser E.^. QualificationUserUser
|
|
E.&&. luser E.?. LmsUserQualification E.?=. quser E.^. QualificationUserQualification)
|
|
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
|
|
-- E.&&. luser E.?. LmsUserQualification E.?=. E.val qid
|
|
-- E.&&. E.isNothing (luser E.^. LmsUserStatus)
|
|
-- E.&&. E.isNothing (luser E.^. LmsUserEnded)
|
|
E.&&. E.not_ (validQualification now quser)
|
|
pure (luser E.?. LmsUserId, quser E.^. QualificationUserUser)
|
|
nrBlocked <- qualificationUserBlocking qid (E.unValue . snd <$> expiredUsers) False (Just now) (Right QualificationBlockExpired) True -- essential that blocks occur only once
|
|
let expiredLearners = [ luid | (E.Value (Just luid), _) <- expiredUsers ]
|
|
-- let expiredLearners = catMaybes (E.unValue . fst <$> expiredUsers)
|
|
nrExpired <- E.updateCount $ \luser -> do
|
|
E.set luser [LmsUserStatus E.=. E.justVal LmsExpired, LmsUserStatusDay E.=. E.justVal now]
|
|
E.where_ $ E.isNothing (luser E.^. LmsUserStatus)
|
|
E.&&. luser E.^. LmsUserQualification E.==. E.val qid
|
|
E.&&. (luser E.^. LmsUserId) `E.in_` E.valList expiredLearners
|
|
$logInfoS "LMS" $ "Expired qualification holders " <> tshow nrBlocked <> " and expired lms users " <> tshow nrExpired <> " for qualification " <> qshort
|
|
|
|
when (quali ^. _qualificationExpiryNotification) $ do -- notifies expired and previously lms-failed drivers
|
|
notifyInvalidDrivers <- E.select $ do
|
|
(quser :& qblock) <- E.from $
|
|
E.table @QualificationUser
|
|
`E.leftJoin` E.table @QualificationUserBlock
|
|
`E.on` (\(quser :& qblock) -> qblock E.?. QualificationUserBlockQualificationUser E.?=. quser E.^. QualificationUserId
|
|
E.&&. qblock `isLatestBlockBefore` E.val now
|
|
)
|
|
E.where_ $ -- E.not_ (validQualification now quser) -- currently invalid
|
|
quser E.^. QualificationUserQualification E.==. E.val qid -- correct qualification
|
|
E.&&. quserToNotify now quser qblock -- recently became invalid or blocked
|
|
pure (quser E.^. QualificationUserUser)
|
|
|
|
forM_ notifyInvalidDrivers $ \(E.Value uid) ->
|
|
queueDBJob JobUserNotification
|
|
{ jRecipient = uid
|
|
, jNotification = NotificationQualificationExpired { nQualification = qid }
|
|
}
|
|
|
|
-- purge outdated 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 <> " for qualification " <> qshort
|
|
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.justVal 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]
|
|
deleteWhere [LmsReportLogQualification ==. qid, LmsReportLogTimestamp <. auditCutoff ]
|
|
|
|
|
|
dispatchJobLmsReports :: QualificationId -> JobHandler UniWorX
|
|
dispatchJobLmsReports qid = JobHandlerAtomic act
|
|
where
|
|
-- act :: YesodJobDB UniWorX ()
|
|
act = whenM (exists [LmsReportQualification ==. qid]) $ do -- executing twice must be prohibited due to assertion that ALL learners are always sent (D fails otherwise)
|
|
now <- liftIO getCurrentTime
|
|
-- DEBUG 2rows; remove later
|
|
totalrows <- count [LmsReportQualification ==. qid]
|
|
$logInfoS "LMS" $ "Report processing " <> tshow totalrows <> " rows for qualification " <> tshow qid
|
|
when (totalrows > 0) $ do
|
|
let -- locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now -- no longer necessary, since LMS reports dates only
|
|
-- DB query for LmsUserUser, provided a matching LmsReport exists
|
|
luserQry luFltr repFltr = E.select $ do
|
|
luser <- E.from $ E.table @LmsUser
|
|
E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification
|
|
E.&&. E.isNothing (luser E.^. LmsUserEnded) -- ignore all closed learners
|
|
E.&&. luFltr luser
|
|
E.&&. E.exists (do
|
|
lreport <- E.from $ E.table @LmsReport
|
|
E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent
|
|
E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
|
|
E.&&. repFltr luser lreport
|
|
)
|
|
return $ luser E.^. LmsUserUser
|
|
-- DB query for LmsUser innerJoin LmsReport
|
|
lrepQry lrFltr = E.select $ do
|
|
(luser :& lreport) <- E.from $ E.table @LmsUser`E.innerJoin` E.table @LmsReport
|
|
`E.on` (\(luser :& lreport) -> luser E.^. LmsUserIdent E.==. lreport E.^. LmsReportIdent
|
|
E.&&. luser E.^. LmsUserQualification E.==. lreport E.^. LmsReportQualification)
|
|
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
|
|
E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
|
|
E.&&. E.isNothing (luser E.^. LmsUserEnded) -- ignore all closed learners
|
|
E.&&. lrFltr luser lreport
|
|
return (luser, lreport)
|
|
-- A) reset status for learners that had their tries just resetted as indicated by LmsOpen
|
|
E.update $ \luser -> do
|
|
E.set luser [ LmsUserStatus E.=. E.nothing
|
|
, LmsUserStatusDay E.=. E.nothing
|
|
, LmsUserResetTries E.=. E.false ]
|
|
E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification
|
|
E.&&. E.isNothing (luser E.^. LmsUserEnded ) -- must still exist at server
|
|
E.&&. E.isJust (luser E.^. LmsUserReceived) -- seen before, for otherwise it might not have been started yet
|
|
E.&&. luser E.^. LmsUserResetTries
|
|
E.&&. E.exists (do
|
|
lreport <- E.from $ E.table @LmsReport
|
|
E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent
|
|
E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
|
|
E.&&. lreport E.^. LmsReportResult E.==. E.val LmsOpen
|
|
E.&&. lreport E.^. LmsReportLock E.==. E.true
|
|
)
|
|
-- B) notify all newly reported users that lms is available
|
|
let luserFltrNew luser = E.isNothing $ luser E.^. LmsUserReceived -- not seen before, just starting
|
|
notifyNewLearner (E.Value uid) = queueDBJob JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False } }
|
|
in luserQry luserFltrNew (const $ const E.true) >>= mapM_ notifyNewLearner
|
|
-- C) block qualifications for failed learners by calling qualificationUserBlocking [uids] (includes audit), notified during expiry
|
|
let lrFltrBlock luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsFailed
|
|
procBlock (Entity luid luser, Entity _ lreport) = do
|
|
let repDay = lmsReportDate lreport <|> Just now
|
|
ok_block <- qualificationUserBlocking qid [lmsUserUser luser] False (lmsReportDate lreport) (Right $ QualificationBlockFailedELearningBy $ lmsUserIdent luser) True -- only valid qualifications are blocked; transcribes to audit log
|
|
update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. repDay]
|
|
return $ Sum ok_block
|
|
in lrepQry lrFltrBlock
|
|
>>= foldMapM procBlock
|
|
>>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " status set to blocked for qualification " <> tshow qid -- debug, remove later
|
|
-- D) renew qualifications for all successfull learners
|
|
let lrFltrSuccess luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsPassed
|
|
procRenew (Entity luid luser, Entity _ lreport) = do
|
|
let repDay = lmsReportDate lreport <|> Just now
|
|
reason = Just $ Right $ QualificationRenewELearningBy $ lmsUserIdent luser
|
|
-- LMS WORKAROUND 2: [supposedly fixed now] sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning
|
|
-- let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning
|
|
-- ok_unblock <- qualificationUserUnblockByReason qid [lmsUserUser luser] repTime (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log
|
|
-- when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid} having success reported after initially failed e-learning|])
|
|
-- END LMS WORKAROUND 2
|
|
ok_renew <- renewValidQualificationUsers qid reason repDay [lmsUserUser luser]-- only valid qualifications are truly renewed; transcribes to audit log
|
|
update luid [LmsUserStatus =. Just LmsSuccess, LmsUserStatusDay =. repDay]
|
|
return $ Sum ok_renew
|
|
in lrepQry lrFltrSuccess
|
|
>>= foldMapM procRenew
|
|
>>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " renewed and status set to success for qualification " <> tshow qid -- debug, remove later
|
|
-- E) mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected)
|
|
E.update $ \luser -> do
|
|
E.set luser [ LmsUserEnded E.=. E.justVal now ]
|
|
E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification
|
|
E.&&. E.isNothing (luser E.^. LmsUserEnded )
|
|
E.&&. E.isJust (luser E.^. LmsUserStatus ) -- status is decided
|
|
E.&&. E.isJust (luser E.^. LmsUserReceived) -- seen before, for otherwise it might not have been started yet
|
|
E.&&. E.notExists (do
|
|
lreport <- E.from $ E.table @LmsReport
|
|
E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent
|
|
E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
|
|
)
|
|
|
|
-- F) lock expired learners: happens during JobLmsDequeue only
|
|
-- G) update lock and received
|
|
let updateReceivedLocked lockstatus = E.updateCount $ \luser -> do -- due to the absence of UPDATE..FROM in esqueleto, we call update twice
|
|
E.set luser [ LmsUserReceived E.=. E.justVal now
|
|
, LmsUserLocked E.=. E.val lockstatus ]
|
|
E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification
|
|
-- E.&&. E.isNothing (luser E.^. LmsUserEnded) -- should always be true, but maybe there is a bug?
|
|
E.&&. E.exists (do
|
|
lreport <- E.from $ E.table @LmsReport
|
|
E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent
|
|
E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
|
|
E.&&. lreport E.^. LmsReportLock E.==. E.val lockstatus -- Maybe more efficient, but less readable: bool E.not_ id lockstatus (lreport E.^. LmsReport Lock)
|
|
)
|
|
-- NOTE: this code leads to a runtime errror; apparently from-clauses are not allowed in updates yet
|
|
-- let updateReceivedLocked lockstatus = E.update $ \luser -> do -- attempt to use 'from'-clause in update as per PostgreSQL
|
|
-- E.set luser [ LmsUserReceived E.=. E.justVal now
|
|
-- , LmsUserLocked E.=. E.val lockstatus ]
|
|
-- lreport <- E.from $ E.table @LmsReport
|
|
-- E.where_ $ E.isNothing (luser E.^. LmsUserEnded)
|
|
-- E.&&. luser E.^. LmsUserQualification E.==. E.val qid
|
|
-- E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
|
|
-- E.&&. lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent
|
|
-- E.&&. lreport E.^. LmsReportLock E.==. E.val lockstatus -- Maybe more efficient, but less readable: bool E.not_ id lockstatus (lreport E.^. LmsReport Lock)
|
|
updateReceivedLocked False
|
|
>>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as unlocked and received for qualification " <> tshow qid -- debug, remove later
|
|
updateReceivedLocked True
|
|
>>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as locked and received for qualification " <> tshow qid -- debug, remove later
|
|
-- G) Truncate LmsReport for qid, after updating log
|
|
E.insertSelect $ do
|
|
lreport <- E.from $ E.table @LmsReport
|
|
let samelog = E.subSelect $ do
|
|
lrl <- E.from $ E.table @LmsReportLog
|
|
E.where_ $ lrl E.^. LmsReportLogQualification E.==. E.val qid
|
|
E.&&. lrl E.^. LmsReportLogIdent E.==. lreport E.^. LmsReportIdent
|
|
E.orderBy [E.desc $ lrl E.^. LmsReportLogTimestamp]
|
|
return $ lreport E.^. LmsReportResult E.==. lrl E.^. LmsReportLogResult
|
|
E.&&. lreport E.^. LmsReportLock E.==. lrl E.^. LmsReportLogLock
|
|
E.&&. E.not_ (lrl E.^. LmsReportLogMissing)
|
|
E.where_ $ lreport E.^. LmsReportQualification E.==. E.val qid
|
|
E.&&. E.not_ (E.isTrue samelog)
|
|
return (LmsReportLog
|
|
E.<# (lreport E.^. LmsReportQualification)
|
|
E.<&> (lreport E.^. LmsReportIdent )
|
|
E.<&> (lreport E.^. LmsReportDate )
|
|
E.<&> (lreport E.^. LmsReportResult )
|
|
E.<&> (lreport E.^. LmsReportLock )
|
|
E.<&> (lreport E.^. LmsReportTimestamp )
|
|
E.<&> E.false)
|
|
E.insertSelect $ do
|
|
lrl <- E.from $ E.table @LmsReportLog
|
|
E.where_ $ E.not_ (lrl E.^. LmsReportLogMissing)
|
|
E.&&. lrl E.^. LmsReportLogQualification E.==. E.val qid
|
|
E.&&. E.notExists (do
|
|
lreport <- E.from $ E.table @LmsReport
|
|
E.where_ $ lreport E.^. LmsReportQualification E.==. E.val qid
|
|
E.&&. lreport E.^. LmsReportIdent E.==. lrl E.^. LmsReportLogIdent
|
|
)
|
|
E.&&. E.notExists (do
|
|
lrl_old <- E.from $ E.table @LmsReportLog
|
|
E.where_ $ lrl_old E.^. LmsReportLogQualification E.==. E.val qid
|
|
E.&&. lrl_old E.^. LmsReportLogIdent E.==. lrl E.^. LmsReportLogIdent
|
|
E.&&. lrl_old E.^. LmsReportLogTimestamp E.>. lrl E.^. LmsReportLogTimestamp
|
|
)
|
|
return (LmsReportLog
|
|
E.<# (lrl E.^. LmsReportLogQualification)
|
|
E.<&> (lrl E.^. LmsReportLogIdent )
|
|
E.<&> E.nothing
|
|
E.<&> (lrl E.^. LmsReportLogResult )
|
|
E.<&> (lrl E.^. LmsReportLogLock )
|
|
E.<&> E.val now
|
|
E.<&> E.true)
|
|
repProc <- deleteWhereCount [LmsReportQualification ==. qid]
|
|
$logInfoS "LMS" [st|Processed #{tshow repProc} e-learning status reports for qualification #{tshow qid}.|]
|
|
|
|
|
|
-- DEPRECATED processes received results and lengthen qualifications, if applicable
|
|
dispatchJobLmsResults :: QualificationId -> JobHandler UniWorX
|
|
dispatchJobLmsResults qid = JobHandlerAtomic act
|
|
where
|
|
-- act :: YesodJobDB UniWorX ()
|
|
act = hoist lift $ do
|
|
results <- E.select $ do
|
|
(quser :& luser :& 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 :& luser) ->
|
|
luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
|
|
E.&&. luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification)
|
|
`E.innerJoin` E.table @LmsResult
|
|
`E.on` (\(_ :& luser :& 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 WORKAROUND LMS-Bug: LMS may send blocked & success simultanesouly or within a few hours; in this case, success is the correct meaning
|
|
E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners
|
|
return (quser, luser, lresult)
|
|
now <- liftIO getCurrentTime
|
|
let locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now
|
|
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 = localDay $ TZ.utcToLocalTimeTZ appTZ lmsUserStarted
|
|
saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil locDay)
|
|
-- && qualificationUserLastRefresh <= utctDay lmsUserStarted NOTE: not always true due to manual intervention; also renewValidQualificationUsers prevents double renewals anyway
|
|
-- newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards
|
|
note <- if saneDate && (lmsUserStatus /= Just LmsSuccess)
|
|
then do
|
|
-- WORKAROUND LMS-Bug [supposedly fixed now, but isnt]: sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning
|
|
let reason_undo = Left $ "LMS Workaround undoing: " <> tshow (QualificationBlockFailedELearningBy lmsUserIdent)
|
|
ok_unblock <- qualificationUserUnblockByReason qid [qualificationUserUser] Nothing (Right $ QualificationBlockFailedELearningBy lmsUserIdent) reason_undo False -- affects audit log
|
|
when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid}|])
|
|
|
|
_ok_renew <- renewValidQualificationUsers qid (Just $ Right $ QualificationRenewELearningBy lmsUserIdent) Nothing [qualificationUserUser] -- only unblocked are renewed
|
|
-- when (ok==1) $ update luid -- we end lms regardless of whether or not a regular renewal was successful, since BPol users may simultaneoysly have on-premise renewal courses and E-Learnings
|
|
|
|
update luid
|
|
[ LmsUserStatus =. Just LmsSuccess
|
|
, LmsUserStatusDay =. Just (utctDayMidnight lmsResultSuccess)
|
|
, LmsUserReceived =. Just lmsResultTimestamp
|
|
]
|
|
return Nothing
|
|
else do
|
|
let errmsg = [st|LMS Result: success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent} for #{tshow qid}|]
|
|
$logErrorS "LMS" errmsg
|
|
return $ Just errmsg
|
|
|
|
audit TransactionLmsSuccess -- always log success, since this is only transmitted once
|
|
{ transactionQualification = qid
|
|
, transactionLmsIdent = lmsUserIdent
|
|
, transactionLmsDay = utctDayMidnight lmsResultSuccess
|
|
, transactionLmsUser = lmsUserUser
|
|
, transactionNote = note
|
|
, transactionReceived = lmsResultTimestamp
|
|
}
|
|
delete lrid
|
|
$logInfoS "LMS" [st|Processed #{tshow (length results)} LMS results|]
|
|
|
|
|
|
-- DEPRECATED processes received input and block qualifications, if applicable
|
|
dispatchJobLmsUserlist :: QualificationId -> JobHandler UniWorX
|
|
dispatchJobLmsUserlist qid = JobHandlerAtomic act
|
|
where
|
|
act :: YesodJobDB UniWorX ()
|
|
act = whenM (exists [LmsUserlistQualification ==. qid]) $ do -- safeguard against multiple calls, which would close all learners due to first case below
|
|
now <- liftIO getCurrentTime
|
|
-- result :: [(Entity LmsUser, Entity LmsUserlist)]
|
|
results <- E.select $ do
|
|
(luser :& lulist) <- E.from $
|
|
E.table @LmsUser `E.leftJoin` E.table @LmsUserlist
|
|
`E.on` (\(luser :& 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
|
|
let lReceived = lmsUserlistTimestamp lulist
|
|
update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotified is only updated upon sending notifications
|
|
|
|
when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available
|
|
queueDBJob JobUserNotification
|
|
{ jRecipient = lmsUserUser luser
|
|
, jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False }
|
|
}
|
|
|
|
let isBlocked = lmsUserlistFailed lulist
|
|
oldStatus = lmsUserStatus luser
|
|
updateStatus = isBlocked && oldStatus /= Just LmsSuccess
|
|
when updateStatus $ do
|
|
update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. Just lReceived]
|
|
ok <- qualificationUserBlocking qid [lmsUserUser luser] False Nothing (Right QualificationBlockFailedELearning) True
|
|
when (ok /= 1) $ do
|
|
uuid :: CryptoUUIDUser <- encrypt $ lmsUserUser luser
|
|
$logWarnS "LmsUserlist" [st|Blocking by failed E-learning failed for learner #{tshow uuid} and qualification #{tshow qid}]
|
|
audit TransactionLmsBlocked
|
|
{ transactionQualification = qid
|
|
, transactionLmsIdent = lmsUserIdent luser
|
|
, transactionLmsDay = lReceived
|
|
, transactionLmsUser = lmsUserUser luser
|
|
, transactionNote = Just $ "Old status was " <> tshow oldStatus
|
|
, transactionReceived = lReceived
|
|
}
|
|
delete lulid
|
|
$logInfoS "LMS" [st|Processed LMS Userlist with #{tshow (length results)} entries|]
|