refactor(qualification): more efficient correct code to discern expiry notifications
This commit is contained in:
parent
382fa7fc07
commit
8b0218ba89
@ -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))
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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) ->
|
||||
|
||||
Loading…
Reference in New Issue
Block a user