fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactor(lms): WIP created a nice E.delete that I am no using now

Browse Source
This commit is contained in:
Steffen Jost 2022-09-19 18:57:53 +02:00
parent 6f623c70c5
commit 86fd7423b8
1 changed files with 71 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

92
src/Jobs/Handler/LMS.hs
View File

@ -77,11 +77,6 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
NotificationQualificationExpiry { nQualification = qid, nExpiry = uex } NotificationQualificationExpiry { nQualification = qid, nExpiry = uex }
} }
forM_ renewalUsers (queueDBJob . usr_job) 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 :: QualificationId -> UserId -> JobHandler UniWorX
dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
@ -113,16 +108,69 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
-- process all received input and renew or block qualifications -- process all received input and renew or block qualifications
dispatchJobLmsDequeue :: QualificationId -> JobHandler UniWorX dispatchJobLmsDequeue :: QualificationId -> JobHandler UniWorX
dispatchJobLmsDequeue qid = JobHandlerAtomic act dispatchJobLmsDequeue qid = JobHandlerAtomic act
-- wenn bestanden: qualification verlängern
-- wenn Aufbewahrungszeit abgelaufen: LmsIdent löschen (verhindert verfrühten neustart) -- wenn Aufbewahrungszeit abgelaufen: LmsIdent löschen (verhindert verfrühten neustart)
where where
act = do act = do
$logInfoS "lms" $ "Processing e-learning results for qualification " <> tshow qid <> "." $logInfoS "lms" $ "Processing e-learning results for qualification " <> tshow qid <> "."
quali <- getJust qid -- may throw an error, aborting the job 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 case qualificationRefreshWithin quali of
Nothing -> return () -- no automatic scheduling for this qid (usually job is not scheduled for these qualifications, see above) Nothing -> return () -- no automatic deletion
(Just _renewalPeriod) -> (Just auditDuration) ->
return () -- TODO return () -- TODO
deleteWhere [LmsUserEnded >. ]
{- do {- do
now_day <- utctDay <$> liftIO getCurrentTime now_day <- utctDay <$> liftIO getCurrentTime
let _renewalDate = addGregorianDurationClip renewalPeriod now_day let _renewalDate = addGregorianDurationClip renewalPeriod now_day
@ -178,9 +226,8 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil nowadayP1) saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil nowadayP1)
&& qualificationUserLastRefresh <= lmsUserStartedDay && qualificationUserLastRefresh <= lmsUserStartedDay
newStatus = LmsSuccess lmsResultSuccess newStatus = LmsSuccess lmsResultSuccess
newValidTo = addMonthsDay renewalMonths qualificationUserValidUntil -- renew from old validUntil onwards newValidTo = addGregorianMonthsRollover (toIntger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards
-- addMonthsDay renewalMonths lmsResultSuccess -- renew from completion onwards note <- if saneDate && isLmsSuccess newStatus
if saneDate && isLmsSuccess newStatus
then do then do
update quid [ QualificationUserValidUntil =. newValidTo update quid [ QualificationUserValidUntil =. newValidTo
, QualificationUserLastRefresh =. lmsResultSuccess , QualificationUserLastRefresh =. lmsResultSuccess
@ -188,9 +235,13 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
update luid [ LmsUserStatus =. Just newStatus update luid [ LmsUserStatus =. Just newStatus
, LmsUserReceived =. Just lmsResultTimestamp , LmsUserReceived =. Just lmsResultTimestamp
] ]
else return Nothing
$logErrorS "LmsResult" [st|LMS success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent}|] else do
insert_ $ LmsAudit qid lmsUserIdent newStatus lmsResultTimestamp now -- always log success, since this is only transmitted once 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 delete lrid
$logInfoS "LmsResult" [st|Processed #{tshow (length results)} LMS results|] $logInfoS "LmsResult" [st|Processed #{tshow (length results)} LMS results|]
@ -226,13 +277,12 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
} }
let lReceived = lmsUserlistTimestamp lulist let lReceived = lmsUserlistTimestamp lulist
isBlocked = lmsUserlistFailed lulist isBlocked = lmsUserlistFailed lulist
newStatus = LmsBlocked $ utctDay lReceived update luid [LmsUserReceived =. Just lReceived]
oldStatus = lmsUserStatus luser
update luid [ LmsUserStatus =. (oldStatus <> toMaybe isBlocked newStatus)
, LmsUserReceived =. Just lReceived ]
when isBlocked $ do 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))] 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|] $logInfoS "LmsUserlist" [st|Processed LMS Userlist with ${tshow (length results)} entries|]