From 8b0218ba89cc947c5e5d3b431513fd096622c122 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 28 Sep 2023 11:29:02 +0000 Subject: [PATCH] refactor(qualification): more efficient correct code to discern expiry notifications --- src/Database/Esqueleto/Utils.hs | 7 +++++ src/Handler/Qualification.hs | 32 +++++++++++------------ src/Handler/Utils/Qualification.hs | 41 +++++++++--------------------- src/Jobs/Handler/LMS.hs | 13 +++++++--- 4 files changed, 44 insertions(+), 49 deletions(-) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 53a480fa8..dc9f5159e 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -33,6 +33,7 @@ module Database.Esqueleto.Utils , selectExists, selectNotExists , SqlHashable , sha256 + , isTrue, isFalse , maybe, maybe2, maybeEq, guardMaybe, unsafeCoalesce , bool , 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)) +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) => E.SqlExpr (E.Value b) -> (E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value b)) diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index ddc7154b0..6553bb300 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -30,7 +30,7 @@ import Database.Persist.Sql (updateWhereCount) import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma 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 Database.Esqueleto.Utils.TH @@ -328,17 +328,17 @@ blockActRemoveSupervisors _ = False -- E.where_ $ fltr qualUser E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) -- 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.SqlExpr (Entity User) , E.SqlExpr (Maybe (Entity LmsUser)) , 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.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.&&. 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 @@ -371,7 +371,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do dbtIdent :: Text dbtIdent = "qualification" 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) dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock) -> 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 | otherwise -> E.true ) - -- , single ("tobe-notified", FilterColumn $ \(queryQualUser -> quser) criterion -> - -- if | Just True <- getLast criterion -> quser `quserToNotify` now - -- | otherwise -> E.true - -- ) + , single ("tobe-notified", FilterColumn $ \row criterion -> + if | Just True <- getLast criterion -> quserToNotify now (queryQualUser row) (queryQualBlock row) + | otherwise -> E.true + ) , single ("status" , FilterColumn . E.mkExactFilterMaybeLast' (views (to queryLmsUser) (E.?. LmsUserId)) $ views (to queryLmsUser) (E.?. LmsUserStatus)) ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgLmsUser mPrev - , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) - , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber) - , prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo) - , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) - , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) + , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) + , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber) + , prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo) + , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) + , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) , if isNothing mbRenewal then mempty 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 "status" . maybePrism _PathPiece) mPrev $ aopt (hoistField liftHandler (selectField optionsFinite) :: (Field _ (Maybe LmsStatus))) (fslI MsgTableLmsStatus) + , 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) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtCsvEncode = Just DBTCsvEncode diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index 9c877906a..370ff80b6 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -41,35 +41,18 @@ isValidQualification d qu qb= d `inBetween` (qu ^. hasQualificationUser . _quali -- SQL Snippets -- ------------------ --- | Recently became invalid or blocked and not yet notified -quserToNotify :: E.SqlExpr (Entity QualificationUser) -> UTCTime -> E.SqlExpr (E.Value Bool) -quserToNotify quser cutoff = -- 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 cutoff - 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 - ) - ) - ) 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 - ) - ) +-- | 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 :: UTCTime -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value Bool) +quserToNotify cutoff quser qblock = -- either recently become invalid with no prior block or recently blocked + -- has expired without being blocked + quser E.^. QualificationUserScheduleRenewal + E.&&. (( quser E.^. QualificationUserValidUntil E.<. E.val (utctDay cutoff) + E.&&. quser E.^. QualificationUserValidUntil E.>. E.day (quser E.^. QualificationUserLastNotified) + E.&&. E.not_ (E.isFalse (qblock E.?. QualificationUserBlockUnblock)) -- not currently blocked + ) E.||. ( -- was recently blocked + E.isFalse (qblock E.?. QualificationUserBlockUnblock) + E.&&. qblock E.?. QualificationUserBlockFrom E.>. E.just (quser E.^. QualificationUserLastNotified) + )) -- 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) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 5550e0706..388bfc2af 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -207,10 +207,15 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act when (quali ^. _qualificationExpiryNotification) $ do -- notifies expired and previously lms-failed drivers notifyInvalidDrivers <- E.select $ do - quser <- E.from $ E.table @QualificationUser - E.where_ $ E.not_ (validQualification now quser) -- currently invalid - E.&&. quser E.^. QualificationUserQualification E.==. E.val qid -- correct qualification - E.&&. quser `quserToNotify` now -- recently became invalid or blocked + (quser :& qblock) <- E.from $ + E.table @QualificationUser + `E.leftJoin` E.table @QualificationUserBlock + `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) forM_ notifyInvalidDrivers $ \(E.Value uid) ->