refactor(lms): WIP created a nice E.delete that I am no using now
This commit is contained in:
Steffen Jost
parent
6f623c70c5
commit
86fd7423b8
@ -77,11 +77,6 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
|
||||
NotificationQualificationExpiry { nQualification = qid, nExpiry = uex }
|
||||
}
|
||||
forM_ renewalUsers (queueDBJob . usr_job)
|
||||
case qualificationAuditDuration quali of
|
||||
Nothing -> return () -- no automatic removal
|
||||
(Just auditDuration) ->
|
||||
let deleteDate = addMonths auditDuration now
|
||||
in deleteWhere [LmsUserQualification ==. qid, LmsUserEnded !=. Nothing, LmsUserEnded >. Just deleteDate]
|
||||
|
||||
dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX
|
||||
dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
|
||||
@ -113,16 +108,69 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
|
||||
-- process all received input and renew or block qualifications
|
||||
dispatchJobLmsDequeue :: QualificationId -> JobHandler UniWorX
|
||||
dispatchJobLmsDequeue qid = JobHandlerAtomic act
|
||||
-- wenn bestanden: qualification verlängern
|
||||
-- wenn Aufbewahrungszeit abgelaufen: LmsIdent löschen (verhindert verfrühten neustart)
|
||||
where
|
||||
act = do
|
||||
$logInfoS "lms" $ "Processing e-learning results for qualification " <> tshow qid <> "."
|
||||
quali <- getJust qid -- may throw an error, aborting the job
|
||||
now <- liftIO getCurrentTime
|
||||
-- purge LmsUsers
|
||||
case qualificationAuditDuration quali of
|
||||
Nothing -> return () -- no automatic removal
|
||||
(Just auditDuration) ->
|
||||
let auditCutoff = addDiffDaysRollover (fromMonths $ negate auditDuration) now
|
||||
delusers <- fmap E.unValue $ 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
|
||||
audit <- E.from $ E.table @LmsAudit
|
||||
E.where_ $ audit E.^. LmsAuditQualification E.==. E.val qid
|
||||
E.&&. audit E.^. LmsAuditIdent E.==. luser E.^. LmsUserIdent
|
||||
E.&&. audit E.^. LmsAuditProcessed E.>=. E.val auditCutoff
|
||||
)
|
||||
pure (luser E.^. LmsUserIdent)
|
||||
deleteWhere [LmsUserQualification ==. qid, LmsUserIdent <-. delusers]
|
||||
deleteWhere [LmsUserlistQualification ==. qid, LmsUserlistIdent <-. delusers]
|
||||
deleteWhere [LmsResult ==. qid, LmsResultIdent <-. delusers]
|
||||
deleteWhere [LmsAudit ==. qid, LmsAuditIdent <-. delusers]
|
||||
|
||||
|
||||
|
||||
deleteWhere [LmsUserQualification ==. qid, LmsUserEnded !=. Nothing, LmsUserEnded <. Just lmsCutoff]
|
||||
-- purge LmsAudit
|
||||
|
||||
in E.delete $ do
|
||||
audit <- E.from $ E.table @LmsAudit
|
||||
E.where_ $ audit E.^. LmsAuditQualification E.==. E.val qid
|
||||
E.&&. E.notExists (do
|
||||
luser <- E.from $ E.table @LmsUser
|
||||
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
|
||||
E.&&. luser E.^. LmsUserIdent E.==. audit E.^. LmsAuditIdent
|
||||
)
|
||||
E.groupBy $ audit E.^. LmsAuditIdent
|
||||
E.having $ E.val auditCutoff E.<. E.max_ (audit E.^. LmsAuditProcessed)
|
||||
|
||||
|
||||
|
||||
in deleteWhere [LmsAuditQualification ==. qid, LmsAuditProcessed >. Just deleteDate]
|
||||
|
||||
|
||||
|
||||
let auditCutoff =
|
||||
|
||||
nowadayP1 = succ $ utctDay now -- add one day to account for time synch problems
|
||||
renewalMonths :: Word = fromMaybe (error ("Cannot renew qualification " <> citext2string (qualificationShorthand quali) <> " without specified validDuration!"))
|
||||
(qualificationValidDuration quali)
|
||||
|
||||
|
||||
case qualificationRefreshWithin quali of
|
||||
Nothing -> return () -- no automatic scheduling for this qid (usually job is not scheduled for these qualifications, see above)
|
||||
(Just _renewalPeriod) ->
|
||||
Nothing -> return () -- no automatic deletion
|
||||
(Just auditDuration) ->
|
||||
return () -- TODO
|
||||
|
||||
deleteWhere [LmsUserEnded >. ]
|
||||
{- do
|
||||
now_day <- utctDay <$> liftIO getCurrentTime
|
||||
let _renewalDate = addGregorianDurationClip renewalPeriod now_day
|
||||
@ -178,9 +226,8 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
|
||||
saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil nowadayP1)
|
||||
&& qualificationUserLastRefresh <= lmsUserStartedDay
|
||||
newStatus = LmsSuccess lmsResultSuccess
|
||||
newValidTo = addMonthsDay renewalMonths qualificationUserValidUntil -- renew from old validUntil onwards
|
||||
-- addMonthsDay renewalMonths lmsResultSuccess -- renew from completion onwards
|
||||
if saneDate && isLmsSuccess newStatus
|
||||
newValidTo = addGregorianMonthsRollover (toIntger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards
|
||||
note <- if saneDate && isLmsSuccess newStatus
|
||||
then do
|
||||
update quid [ QualificationUserValidUntil =. newValidTo
|
||||
, QualificationUserLastRefresh =. lmsResultSuccess
|
||||
@ -188,9 +235,13 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
|
||||
update luid [ LmsUserStatus =. Just newStatus
|
||||
, LmsUserReceived =. Just lmsResultTimestamp
|
||||
]
|
||||
else
|
||||
$logErrorS "LmsResult" [st|LMS success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent}|]
|
||||
insert_ $ LmsAudit qid lmsUserIdent newStatus lmsResultTimestamp now -- always log success, since this is only transmitted once
|
||||
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|]
|
||||
|
||||
@ -226,13 +277,12 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
|
||||
}
|
||||
let lReceived = lmsUserlistTimestamp lulist
|
||||
isBlocked = lmsUserlistFailed lulist
|
||||
newStatus = LmsBlocked $ utctDay lReceived
|
||||
oldStatus = lmsUserStatus luser
|
||||
update luid [ LmsUserStatus =. (oldStatus <> toMaybe isBlocked newStatus)
|
||||
, LmsUserReceived =. Just lReceived ]
|
||||
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))]
|
||||
insert_ $ LmsAudit qid (lmsUserIdent luser) newStatus lReceived now -- always log blocked
|
||||
delete lulid
|
||||
|
||||
delete lulid
|
||||
$logInfoS "LmsUserlist" [st|Processed LMS Userlist with ${tshow (length results)} entries|]
|
||||
|
||||
Loading…
Reference in New Issue
Block a user