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

refactor(qualification): more efficient correct code to discern expiry notifications

Browse Source
This commit is contained in:
Steffen Jost 2023-09-28 11:29:02 +00:00
parent 382fa7fc07
commit 8b0218ba89
4 changed files with 44 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
src/Database/Esqueleto/Utils.hs
View File

@ -33,6 +33,7 @@ module Database.Esqueleto.Utils
, selectExists, selectNotExists , selectExists, selectNotExists
, SqlHashable , SqlHashable
, sha256 , sha256
, isTrue, isFalse
, maybe, maybe2, maybeEq, guardMaybe, unsafeCoalesce , maybe, maybe2, maybeEq, guardMaybe, unsafeCoalesce
, bool , bool
, max, min , max, min
@ -488,6 +489,12 @@ sha256 :: SqlHashable a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value (Digest S
sha256 = E.unsafeSqlFunction "digest" . (, E.val "sha256" :: E.SqlExpr (E.Value Text)) sha256 = E.unsafeSqlFunction "digest" . (, E.val "sha256" :: E.SqlExpr (E.Value Text))
isTrue :: E.SqlExpr (E.Value (Maybe Bool)) -> E.SqlExpr (E.Value Bool)
isTrue expr = E.unsafeSqlBinOp "IS TRUE" expr $ E.unsafeSqlValue ""
isFalse :: E.SqlExpr (E.Value (Maybe Bool)) -> E.SqlExpr (E.Value Bool)
isFalse expr = E.unsafeSqlBinOp "IS FALSE" expr $ E.unsafeSqlValue ""
maybe :: (PersistField a, PersistField b) maybe :: (PersistField a, PersistField b)
=> E.SqlExpr (E.Value b) => E.SqlExpr (E.Value b)
-> (E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value b)) -> (E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value b))

32
src/Handler/Qualification.hs
View File

@ -30,7 +30,7 @@ import Database.Persist.Sql (updateWhereCount)
import Database.Esqueleto.Experimental ((:&)(..)) import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.PostgreSQL as E -- import qualified Database.Esqueleto.PostgreSQL as E
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH import Database.Esqueleto.Utils.TH
@ -328,17 +328,17 @@ blockActRemoveSupervisors _ = False
-- E.where_ $ fltr qualUser E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) -- E.where_ $ fltr qualUser E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification)
-- return (qualUser, user, lmsUser) -- return (qualUser, user, lmsUser)
qualificationTableQuery :: QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr qualificationTableQuery :: UTCTime -> QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr
-> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
, E.SqlExpr (Entity User) , E.SqlExpr (Entity User)
, E.SqlExpr (Maybe (Entity LmsUser)) , E.SqlExpr (Maybe (Entity LmsUser))
, E.SqlExpr (Maybe (Entity QualificationUserBlock)) , E.SqlExpr (Maybe (Entity QualificationUserBlock))
) )
qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do qualificationTableQuery now qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do
-- E.distinctOnOrderBy will not work: sorting with dbTable should work, except that columns contained in distinctOnOrderBy cannot be sorted inversely by user; but PostgreSQL leftJoin with distinct filters too many results, see SQL Example lead/lag under jost/misc DevOps -- E.distinctOnOrderBy will not work: sorting with dbTable should work, except that columns contained in distinctOnOrderBy cannot be sorted inversely by user; but PostgreSQL leftJoin with distinct filters too many results, see SQL Example lead/lag under jost/misc DevOps
-- --
E.on $ qualBlock E.?. QualificationUserBlockQualificationUser E.?=. qualUser E.^. QualificationUserId E.on $ qualBlock E.?. QualificationUserBlockQualificationUser E.?=. qualUser E.^. QualificationUserId
E.&&. qualBlock `isLatestBlockBefore` E.now_ E.&&. qualBlock `isLatestBlockBefore` E.val now
E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser
E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work
E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
@ -371,7 +371,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
dbtIdent :: Text dbtIdent :: Text
dbtIdent = "qualification" dbtIdent = "qualification"
fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs
dbtSQLQuery = qualificationTableQuery qid fltrSvs dbtSQLQuery = qualificationTableQuery now qid fltrSvs
dbtRowKey = queryUser >>> (E.^. UserId) dbtRowKey = queryUser >>> (E.^. UserId)
dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock) -> do dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock) -> do
-- cmps <- E.select . E.from $ \(usrComp `E.InnerJoin` comp) -> do -- cmps <- E.select . E.from $ \(usrComp `E.InnerJoin` comp) -> do
@ -437,23 +437,23 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
| otherwise -> E.true | otherwise -> E.true
) )
-- , single ("tobe-notified", FilterColumn $ \(queryQualUser -> quser) criterion -> , single ("tobe-notified", FilterColumn $ \row criterion ->
-- if | Just True <- getLast criterion -> quser `quserToNotify` now if | Just True <- getLast criterion -> quserToNotify now (queryQualUser row) (queryQualBlock row)
-- | otherwise -> E.true | otherwise -> E.true
-- ) )
, single ("status" , FilterColumn . E.mkExactFilterMaybeLast' (views (to queryLmsUser) (E.?. LmsUserId)) $ views (to queryLmsUser) (E.?. LmsUserStatus)) , single ("status" , FilterColumn . E.mkExactFilterMaybeLast' (views (to queryLmsUser) (E.?. LmsUserId)) $ views (to queryLmsUser) (E.?. LmsUserStatus))
] ]
dbtFilterUI mPrev = mconcat dbtFilterUI mPrev = mconcat
[ fltrUserNameEmailHdrUI MsgLmsUser mPrev [ fltrUserNameEmailHdrUI MsgLmsUser mPrev
, prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
, prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber) , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
, prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo) , prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo)
, prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
, prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
, if isNothing mbRenewal then mempty , if isNothing mbRenewal then mempty
else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
-- , prismAForm (singletonFilter "tobe-notified" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsNotificationDue) , prismAForm (singletonFilter "tobe-notified" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsNotificationDue)
, prismAForm (singletonFilter "status" . maybePrism _PathPiece) mPrev $ aopt (hoistField liftHandler (selectField optionsFinite) :: (Field _ (Maybe LmsStatus))) (fslI MsgTableLmsStatus) , prismAForm (singletonFilter "status" . maybePrism _PathPiece) mPrev $ aopt (hoistField liftHandler (selectField optionsFinite) :: (Field _ (Maybe LmsStatus))) (fslI MsgTableLmsStatus)
] ]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtCsvEncode = Just DBTCsvEncode dbtCsvEncode = Just DBTCsvEncode

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

@ -41,35 +41,18 @@ isValidQualification d qu qb= d `inBetween` (qu ^. hasQualificationUser . _quali
-- SQL Snippets -- -- SQL Snippets --
------------------ ------------------
-- | Recently became invalid or blocked and not yet notified -- | Recently became invalid or blocked and not yet notified; assumes that second argument is latest active block (if exists), also checks validity with respect to given timestamp
quserToNotify :: E.SqlExpr (Entity QualificationUser) -> UTCTime -> E.SqlExpr (E.Value Bool) quserToNotify :: UTCTime -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value Bool)
quserToNotify quser cutoff = -- recently invalid or... quserToNotify cutoff quser qblock = -- either recently become invalid with no prior block or recently blocked
( E.day (quser E.^. QualificationUserLastNotified) E.<. quser E.^. QualificationUserValidUntil -- has expired without being blocked
E.&&. E.notExists (do quser E.^. QualificationUserScheduleRenewal
qualUserBlock <- E.from $ E.table @QualificationUserBlock E.&&. (( quser E.^. QualificationUserValidUntil E.<. E.val (utctDay cutoff)
E.where_ $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock) E.&&. quser E.^. QualificationUserValidUntil E.>. E.day (quser E.^. QualificationUserLastNotified)
E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.>. quser E.^. QualificationUserLastNotified E.&&. E.not_ (E.isFalse (qblock E.?. QualificationUserBlockUnblock)) -- not currently blocked
E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.<=. E.val cutoff ) E.||. ( -- was recently blocked
E.&&. E.notExists (do -- block is the most recent block E.isFalse (qblock E.?. QualificationUserBlockUnblock)
qualUserLaterBlock <- E.from $ E.table @QualificationUserBlock E.&&. qblock E.?. QualificationUserBlockFrom E.>. E.just (quser E.^. QualificationUserLastNotified)
E.where_ $ -- ((E.>.) `on` (E.^. QualificationUserBlockFrom) qualUserLaterBlock qualUserBlock) ))
qualUserLaterBlock E.^. QualificationUserBlockFrom E.>. qualUserBlock E.^. QualificationUserBlockFrom
E.&&. qualUserLaterBlock E.^. QualificationUserBlockFrom E.<=. E.val cutoff
)
)
) 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.&&. E.day (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 cutoff -- 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))
qualUserLaterBlock E.^. QualificationUserBlockFrom E.>. qualUserBlock E.^. QualificationUserBlockFrom
E.&&. qualUserLaterBlock E.^. QualificationUserBlockFrom E.<=. E.val cutoff
)
)
-- condition to ensure that the lastest QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended -- condition to ensure that the lastest QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended
isLatestBlockBefore :: E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool) isLatestBlockBefore :: E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool)

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

@ -207,10 +207,15 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
when (quali ^. _qualificationExpiryNotification) $ do -- notifies expired and previously lms-failed drivers when (quali ^. _qualificationExpiryNotification) $ do -- notifies expired and previously lms-failed drivers
notifyInvalidDrivers <- E.select $ do notifyInvalidDrivers <- E.select $ do
quser <- E.from $ E.table @QualificationUser (quser :& qblock) <- E.from $
E.where_ $ E.not_ (validQualification now quser) -- currently invalid E.table @QualificationUser
E.&&. quser E.^. QualificationUserQualification E.==. E.val qid -- correct qualification `E.leftJoin` E.table @QualificationUserBlock
E.&&. quser `quserToNotify` now -- recently became invalid or blocked `E.on` (\(quser :& qblock) -> qblock E.?. QualificationUserBlockQualificationUser E.?=. quser E.^. QualificationUserId
E.&&. qblock `isLatestBlockBefore` E.val now
)
E.where_ $ -- E.not_ (validQualification now quser) -- currently invalid
quser E.^. QualificationUserQualification E.==. E.val qid -- correct qualification
E.&&. quserToNotify now quser qblock -- recently became invalid or blocked
pure (quser E.^. QualificationUserUser) pure (quser E.^. QualificationUserUser)
forM_ notifyInvalidDrivers $ \(E.Value uid) -> forM_ notifyInvalidDrivers $ \(E.Value uid) ->