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' :: Bool -> Day -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool)
quserBlock' negCond aday qualUser = quserBlockAux negCond aday (E.=?. (qualUser E.?. QualificationUserId)) 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 :: Day -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool)
validQualification nowaday qualUser = validQualification nowaday qualUser =
(E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld (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 :: 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 Entity quid _ <- upsert
QualificationUser QualificationUser
{ qualificationUserFirstHeld = qualificationUserLastRefresh { qualificationUserFirstHeld = qualificationUserLastRefresh
@ -104,13 +107,12 @@ upsertQualificationUser qualificationUserQualification qualificationUserLastRef
, QualificationUserLastRefresh =. qualificationUserLastRefresh , QualificationUserLastRefresh =. qualificationUserLastRefresh
] ]
) )
_ <- error "TODO: Continue here!" whenIsJust mbUnblockBecause $ \(qualificationUserBlockFrom, qualificationUserBlockReason, qualificationUserBlockBlocker) -> do
-- whenIsJust mbUnblockBecause $ \(qualificationUserBlockFrom, qualificationUserBlockReason, qualificationUserBlockBlocker) -> do block <- selectFirst [ QualificationUserBlockQualificationUser ==. quid ] [ Desc QualificationUserBlockFrom ]
-- block <- selectFirst [ QualificationUserBlockQualificationUser ==. quid ] [ Desc QualificationUserBlockFrom ] whenIsJust block $ \qub ->
-- whenIsJust block $ \qub -> unless (qub ^. _entityVal . _qualificationUserBlockUnblock) $
-- unless (qub ^. _qualificationUserBlockUnblock) $ -- TODO does not work like this anymore insert_ QualificationUserBlock{ qualificationUserBlockQualificationUser = quid, qualificationUserBlockUnblock = True, ..}
-- insert_ QualificationUserBlock{ qualificationUserBlockQualificationUser = quid, qualificationUserBlockUnblock = True, ..}
audit TransactionQualificationUserEdit audit TransactionQualificationUserEdit
{ transactionQualificationUser = quid { 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.Widgets
import Handler.Utils.Occurrences import Handler.Utils.Occurrences
import Handler.Utils.LMS (lmsUserStatusWidget) import Handler.Utils.LMS (lmsUserStatusWidget)
import Handler.Utils.Qualification (isValidQualification) -- import Handler.Utils.Qualification (isValidQualification)
type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with WithHoles ! type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with WithHoles !
@ -326,8 +326,8 @@ qualificationValidUntilCell q = textCell (qsh <> ": ") <> dayCell vtd
qsh = q ^. hasQualification . _qualificationShorthand . _CI qsh = q ^. hasQualification . _qualificationShorthand . _CI
vtd = q ^. hasQualificationUser . _qualificationUserValidUntil vtd = q ^. hasQualificationUser . _qualificationUserValidUntil
qualificationValidIconCell :: (IsDBTable m c, HasQualificationUser a) => Day -> a -> DBCell m c -- qualificationValidIconCell :: (IsDBTable m c, HasQualificationUser a) => Day -> a -> DBCell m c
qualificationValidIconCell = (iconBoolCell .) . isValidQualification -- qualificationValidIconCell = (iconBoolCell .) . isValidQualification
lmsShortCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c lmsShortCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c
lmsShortCell (view hasQualification -> Qualification{..}) = anchorCell link name 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 case qualificationRefreshWithin quali of
Nothing -> return () -- no automatic scheduling for this qid Nothing -> return () -- no automatic scheduling for this qid
(Just renewalPeriod) -> do (Just renewalPeriod) -> do
let now_day = utctDay now let nowaday = utctDay now
renewalDate = addGregorianDurationClip renewalPeriod now_day renewalDate = addGregorianDurationClip renewalPeriod nowaday
renewalUsers <- E.select $ do renewalUsers <- E.select $ do
quser <- E.from $ E.table @QualificationUser quser <- E.from $ E.table @QualificationUser
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
E.&&. quser E.^. QualificationUserScheduleRenewal E.&&. quser E.^. QualificationUserScheduleRenewal
E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val now_day
E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate
E.&&. E.isNothing (quser E.^. QualificationUserBlockedDue) E.&&. (quser `qualificationValid` nowaday)
E.&&. E.notExists (do E.&&. E.notExists (do
luser <- E.from $ E.table @LmsUser luser <- E.from $ E.table @LmsUser
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
@ -161,12 +160,33 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
notifyInvalidDrivers <- E.select $ do notifyInvalidDrivers <- E.select $ do
quser <- E.from $ E.table @QualificationUser quser <- E.from $ E.table @QualificationUser
E.where_ $ E.not_ (validQualification nowaday quser) E.where_ $ E.not_ (quser `qualificationValid` nowaday) -- currently invalid
E.&&. (( E.isNothing (quser E.^. QualificationUserBlockedDue) E.&&. quser E.^. QualificationUserQualification E.==. E.val qid -- correct qualification
E.&&. (E.day (quser E.^. QualificationUserLastNotified) E.<. quser E.^. QualificationUserValidUntil) E.&&. (( -- recently invalid or...
) E.||. ( E.day (quser E.^. QualificationUserLastNotified) E.<. quser E.^. QualificationUserValidUntil
E.isJust (quser E.^. QualificationUserBlockedDue) E.&&. E.notExists (do
E.&&. (E.day (quser E.^. QualificationUserLastNotified) E.<. E.day' ((quser E.^. QualificationUserBlockedDue) E.->>. "day")) 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) pure (quser E.^. QualificationUserUser)