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

chore(lms): minor refactoring for selectValidQualifications

Browse Source
This commit is contained in:
Steffen Jost 2023-09-20 09:51:43 +00:00
parent 967341fa1e
commit 520e649fc8
2 changed files with 14 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
src/Handler/Utils/Qualification.hs
View File

@ -120,21 +120,21 @@ validQualification' cutoff qualUser =
,qualUser E.?. QualificationUserValidUntil)) -- currently valid
E.&&. quserBlock' False cutoff qualUser
-- selectValidQualifications :: QualificationId -> Maybe [UserId] -> UTCTime -> DB [Entity QualificationUser]
-- selectValidQualifications :: QualificationId -> [UserId] -> UTCTime -> DB [Entity QualificationUser]
selectValidQualifications ::
( MonadIO m
, BackendCompatible SqlBackend backend
, PersistQueryRead backend
, PersistUniqueRead backend
) => QualificationId -> Maybe [UserId] -> UTCTime -> ReaderT backend m [Entity QualificationUser]
selectValidQualifications qid mbUids cutoff =
) => QualificationId -> [UserId] -> UTCTime -> ReaderT backend m [Entity QualificationUser]
selectValidQualifications qid uids cutoff =
-- cutoff <- utctDay <$> liftIO getCurrentTime
E.select $ do
qUser <- E.from $ E.table @QualificationUser
E.where_ $ (qUser E.^. QualificationUserQualification E.==. E.val qid)
E.&&. validQualification cutoff qUser
-- E.&&. maybe E.true (\uids -> qUser E.^. QualificationUserUser `E.in_` E.valList uids) mbUids
whenIsJust mbUids (\uids -> E.where_ $ qUser E.^. QualificationUserUser `E.in_` E.valList uids)
E.&&. qUser E.^. QualificationUserUser `E.in_` E.valList uids
E.&&. validQualification cutoff qUser
-- whenIsJust mbUids (\uids -> E.where_ $ qUser E.^. QualificationUserUser `E.in_` E.valList uids)
pure qUser
selectRelevantBlock :: UTCTime -> QualificationUserId -> DB (Maybe (Entity QualificationUserBlock))
@ -194,15 +194,15 @@ renewValidQualificationUsers qid renewalTime uids =
-- E.&&. (qu E.^. QualificationUserUser `E.in_` E.valList uids)
get qid >>= \case
Just Qualification{qualificationValidDuration=Just renewalMonths} -> do
now <- maybe (liftIO getCurrentTime) return renewalTime
quEntsAll <- selectValidQualifications qid (Just uids) now
let nowaday = utctDay now
maxValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) nowaday
cutoff <- maybe (liftIO getCurrentTime) return renewalTime
quEntsAll <- selectValidQualifications qid uids cutoff
let cutoffday = utctDay cutoff
maxValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) cutoffday
quEnts = filter (\q -> maxValidTo >= (q ^. _entityVal . _qualificationUserValidUntil)) quEntsAll
forM_ quEnts $ \(Entity quId QualificationUser{..}) -> do
let newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil
update quId [ QualificationUserValidUntil =. newValidTo
, QualificationUserLastRefresh =. nowaday
, QualificationUserLastRefresh =. cutoffday
]
audit TransactionQualificationUserEdit
{ transactionQualificationUser = quId
@ -282,11 +282,11 @@ qualificationUserUnblockByReason ::
, Num n
) => QualificationId -> [UserId] -> Maybe UTCTime -> QualificationBlockReason -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
qualificationUserUnblockByReason qid uids mbUnblockTime (qualificationBlockReasonText -> reason) undo_reason notify = do
now <- maybe (liftIO getCurrentTime) return mbUnblockTime
cutoff <- maybe (liftIO getCurrentTime) return mbUnblockTime
toUnblock <- E.select $ do
quser <- E.from $ E.table @QualificationUser
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
E.&&. quser E.^. QualificationUserUser `E.in_` E.valList uids
E.&&. quserBlockAux True (E.val now) (E.==. (quser E.^. QualificationUserId)) (Just (\qblock -> (qblock E.^. QualificationUserBlockReason) E.==. E.val reason))
E.&&. quserBlockAux True (E.val cutoff) (E.==. (quser E.^. QualificationUserId)) (Just (\qblock -> (qblock E.^. QualificationUserBlockReason) E.==. E.val reason))
return $ quser E.^. QualificationUserUser
qualificationUserBlocking qid (E.unValue <$> toUnblock) True mbUnblockTime undo_reason notify

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

@ -318,7 +318,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
-- 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 (lmsReportDate lreport) [lmsUserUser luser]-- only valid qualifications are truly renewed; transcribes to audit log
ok_renew <- renewValidQualificationUsers qid 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