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

refactor(qualifications): working on lms background jobs (WIP)

Browse Source
This commit is contained in:
Steffen Jost 2023-06-23 09:14:53 +00:00
parent f22252ecc3
commit d5c345ef69
3 changed files with 44 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -59,6 +59,9 @@ quserBlock negCond aday qualUser = quserBlockAux negCond aday (E.==. (qualUser E
quserBlock' :: Bool -> Day -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool)
quserBlock' negCond aday qualUser = quserBlockAux negCond aday (E.=?. (qualUser E.?. QualificationUserId))
qualificationValid :: E.SqlExpr (Entity QualificationUser) -> Day -> E.SqlExpr (E.Value Bool)
qualificationValid = flip validQualification
validQualification :: Day -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool)
validQualification nowaday qualUser =
(E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld
@ -89,7 +92,7 @@ selectValidQualifications qid mbUids nowaday =
upsertQualificationUser :: QualificationId -> Day -> Day -> Maybe Bool -> Maybe (Day, Text, Maybe UserId) -> UserId -> DB () -- may also unblock
upsertQualificationUser qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal _mbUnblockBecause qualificationUserUser = do
upsertQualificationUser qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal mbUnblockBecause qualificationUserUser = do
Entity quid _ <- upsert
QualificationUser
{ qualificationUserFirstHeld = qualificationUserLastRefresh
@ -104,13 +107,12 @@ upsertQualificationUser qualificationUserQualification qualificationUserLastRef
, QualificationUserLastRefresh =. qualificationUserLastRefresh
]
)
_ <- error "TODO: Continue here!"
-- whenIsJust mbUnblockBecause $ \(qualificationUserBlockFrom, qualificationUserBlockReason, qualificationUserBlockBlocker) -> do
-- block <- selectFirst [ QualificationUserBlockQualificationUser ==. quid ] [ Desc QualificationUserBlockFrom ]
-- whenIsJust block $ \qub ->
-- unless (qub ^. _qualificationUserBlockUnblock) $ -- TODO does not work like this anymore
-- insert_ QualificationUserBlock{ qualificationUserBlockQualificationUser = quid, qualificationUserBlockUnblock = True, ..}
whenIsJust mbUnblockBecause $ \(qualificationUserBlockFrom, qualificationUserBlockReason, qualificationUserBlockBlocker) -> do
block <- selectFirst [ QualificationUserBlockQualificationUser ==. quid ] [ Desc QualificationUserBlockFrom ]
whenIsJust block $ \qub ->
unless (qub ^. _entityVal . _qualificationUserBlockUnblock) $
insert_ QualificationUserBlock{ qualificationUserBlockQualificationUser = quid, qualificationUserBlockUnblock = True, ..}
audit TransactionQualificationUserEdit
{ transactionQualificationUser = quid

6
src/Handler/Utils/Table/Cells.hs
View File

@ -14,7 +14,7 @@ import Handler.Utils.DateTime
import Handler.Utils.Widgets
import Handler.Utils.Occurrences
import Handler.Utils.LMS (lmsUserStatusWidget)
import Handler.Utils.Qualification (isValidQualification)
-- import Handler.Utils.Qualification (isValidQualification)
type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with WithHoles !
@ -326,8 +326,8 @@ qualificationValidUntilCell q = textCell (qsh <> ": ") <> dayCell vtd
qsh = q ^. hasQualification . _qualificationShorthand . _CI
vtd = q ^. hasQualificationUser . _qualificationUserValidUntil
qualificationValidIconCell :: (IsDBTable m c, HasQualificationUser a) => Day -> a -> DBCell m c
qualificationValidIconCell = (iconBoolCell .) . isValidQualification
-- qualificationValidIconCell :: (IsDBTable m c, HasQualificationUser a) => Day -> a -> DBCell m c
-- qualificationValidIconCell = (iconBoolCell .) . isValidQualification
lmsShortCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c
lmsShortCell (view hasQualification -> Qualification{..}) = anchorCell link name

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

@ -64,15 +64,14 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
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
let nowaday = utctDay now
renewalDate = addGregorianDurationClip renewalPeriod nowaday
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 now_day
E.&&. quser E.^. QualificationUserScheduleRenewal
E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate
E.&&. E.isNothing (quser E.^. QualificationUserBlockedDue)
E.&&. (quser `qualificationValid` nowaday)
E.&&. E.notExists (do
luser <- E.from $ E.table @LmsUser
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
@ -161,12 +160,33 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
notifyInvalidDrivers <- E.select $ do
quser <- E.from $ E.table @QualificationUser
E.where_ $ E.not_ (validQualification nowaday quser)
E.&&. (( E.isNothing (quser E.^. QualificationUserBlockedDue)
E.&&. (E.day (quser E.^. QualificationUserLastNotified) E.<. quser E.^. QualificationUserValidUntil)
) E.||. (
E.isJust (quser E.^. QualificationUserBlockedDue)
E.&&. (E.day (quser E.^. QualificationUserLastNotified) E.<. E.day' ((quser E.^. QualificationUserBlockedDue) E.->>. "day"))
E.where_ $ E.not_ (quser `qualificationValid` nowaday) -- currently invalid
E.&&. quser E.^. QualificationUserQualification E.==. E.val qid -- correct qualification
E.&&. (( -- recently invalid or...
E.day (quser E.^. QualificationUserLastNotified) E.<. quser E.^. QualificationUserValidUntil
E.&&. E.notExists (do
qualUserBlock <- E.from $ E.table @QualificationUserBlock
E.where_ $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock)
E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.>. quser E.^. QualificationUserLastNotified
E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.<=. E.val nowaday
E.&&. E.notExists (do -- block is the most recent block
qualUserLaterBlock <- E.from $ E.table @QualificationUserBlock
E.where_ (E.>.) `on` (E.^. QualificationUserBlockFrom) qualUserLaterBlock qualUserBlock
E.&&. qualUserLaterBlock E.^. QualificationUserBlockFrom E.<=. E.val nowaday
--E.where_ $ qualUserLaterBlock E.^. QualificationUserBlockFrom E.>. qualUserBlock E.^. QualificationUserBlockFrom
)
)
) E.||. E.exists (do -- ...recently blocked
qualUserBlock <- E.from $ E.table @QualificationUserBlock
E.where_ $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock) -- block is not an unblock
E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.<. quser E.^. QualificationUserValidUntil -- block was essential during validity
E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.>. quser E.^. QualificationUserLastNotified -- block has not yet been communicated
E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.<=. E.val nowaday -- block is already active
E.&&. E.notExists (do -- block is the most recent block
qualUserLaterBlock <- E.from $ E.table @QualificationUserBlock
E.where_ (E.>.) `on` (E.^. QualificationUserBlockFrom) qualUserLaterBlock qualUserBlock
E.&&. qualUserLaterBlock E.^. QualificationUserBlockFrom E.<=. E.val nowaday
)
))
pure (quser E.^. QualificationUserUser)