refactor(qualifications): update basic qualification blocking routines II (WIP)
This commit is contained in:
parent
d5c345ef69
commit
ff7675542a
@ -35,10 +35,41 @@ mkQualificationBlocked reason qualificationUserBlockFrom qualificationUserBlockQ
|
||||
-- SQL Snippets --
|
||||
------------------
|
||||
|
||||
-- | Recently became invalid or blocked and not yet notified
|
||||
quserToNotify :: E.SqlExpr (Entity QualificationUser) -> Day -> E.SqlExpr (E.Value Bool)
|
||||
quserToNotify quser aday = -- 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.>. E.day (quser E.^. QualificationUserLastNotified)
|
||||
E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.<=. E.val aday
|
||||
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 aday
|
||||
)
|
||||
)
|
||||
) 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.>. E.day (quser E.^. QualificationUserLastNotified) -- block has not yet been communicated
|
||||
E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.<=. E.val aday -- 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 aday
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
-- TODO: consider replacing `nowaday` by `Database.Esqueleto.PostgreSQL.now_` or better `day(now_)` cast as date
|
||||
|
||||
quserBlockAux :: Bool -> Day -> (E.SqlExpr (E.Value QualificationUserId) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool)
|
||||
quserBlockAux negCond nowaday checkQualUserId = bool E.notExists E.exists negCond $ do
|
||||
quserBlockAux :: Bool -> Day -> (E.SqlExpr (E.Value QualificationUserId) -> E.SqlExpr (E.Value Bool)) -> Maybe (E.SqlExpr (Entity QualificationUserBlock) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool)
|
||||
quserBlockAux negCond nowaday checkQualUserId mbBlockCondition = bool E.notExists E.exists negCond $ do
|
||||
qualUserBlock <- E.from $ E.table @QualificationUserBlock
|
||||
E.where_ $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock)
|
||||
E.&&. (qualUserBlock E.^. QualificationUserBlockFrom E.<=. E.val nowaday)
|
||||
@ -50,14 +81,15 @@ quserBlockAux negCond nowaday checkQualUserId = bool E.notExists E.exists negCon
|
||||
E.&&. qualUserUnblock E.^. QualificationUserBlockFrom E.<=. E.val nowaday
|
||||
E.&&. qualUserUnblock E.^. QualificationUserBlockFrom E.>. qualUserBlock E.^. QualificationUserBlockFrom
|
||||
)
|
||||
whenIsJust mbBlockCondition (E.where_ . ($ qualUserBlock))
|
||||
|
||||
-- | Test whether a QualificationUser was blocked/unblocked at a given day; negCond: True:isBlocked False:isUnblocked
|
||||
quserBlock :: Bool -> Day -> E.SqlExpr (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)) Nothing
|
||||
|
||||
-- | Variant of `isBlocked` for outer joins
|
||||
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)) Nothing
|
||||
|
||||
qualificationValid :: E.SqlExpr (Entity QualificationUser) -> Day -> E.SqlExpr (E.Value Bool)
|
||||
qualificationValid = flip validQualification
|
||||
@ -82,7 +114,8 @@ selectValidQualifications qid mbUids nowaday =
|
||||
qUser <- E.from $ E.table @QualificationUser
|
||||
E.where_ $ (qUser E.^. QualificationUserQualification E.==. E.val qid)
|
||||
E.&&. validQualification nowaday qUser
|
||||
E.&&. maybe E.true (\uids -> qUser E.^. QualificationUserUser `E.in_` E.valList uids) mbUids
|
||||
-- E.&&. maybe E.true (\uids -> qUser E.^. QualificationUserUser `E.in_` E.valList uids) mbUids
|
||||
whenIsJust mbUids (\uids -> E.where_ $ qUser E.^. QualificationUserUser `E.in_` E.valList uids)
|
||||
pure qUser
|
||||
|
||||
|
||||
@ -122,6 +155,7 @@ upsertQualificationUser qualificationUserQualification qualificationUserLastRef
|
||||
, transactionQualificationScheduleRenewal = mbScheduleRenewal
|
||||
}
|
||||
|
||||
-- | Renew an existing qualification, ignoring all blocks
|
||||
renewValidQualificationUsers :: QualificationId -> [UserId] -> DB Int
|
||||
renewValidQualificationUsers qid uids =
|
||||
-- This code works in principle, but it does not allow audit log entries.
|
||||
@ -208,34 +242,28 @@ qualificationUserBlocking qid uids unblock reason notify = do
|
||||
}
|
||||
return $ fromIntegral $ length toChange
|
||||
|
||||
-- no longer needed
|
||||
-- qualificationUserUnblockByReason ::
|
||||
-- ( AuthId (HandlerSite m) ~ Key User
|
||||
-- , IsPersistBackend (YesodPersistBackend (HandlerSite m))
|
||||
-- , BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend
|
||||
-- , BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
|
||||
-- , PersistQueryWrite (YesodPersistBackend (HandlerSite m))
|
||||
-- , PersistUniqueWrite (YesodPersistBackend (HandlerSite m))
|
||||
-- , HasInstanceID (HandlerSite m) InstanceId
|
||||
-- , YesodAuthPersist (HandlerSite m)
|
||||
-- , HasAppSettings (HandlerSite m)
|
||||
-- , MonadHandler m
|
||||
-- , MonadCatch m
|
||||
-- , Num n
|
||||
-- ) => QualificationId -> [UserId] -> Text -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
|
||||
-- qualificationUserUnblockByReason qid uids reason = do
|
||||
-- blockedUsers <- selectList [ QualificationUserQualification ==. qid
|
||||
-- , QualificationUserBlockedDue !=. Nothing
|
||||
-- , QualificationUserUser <-. uids
|
||||
-- ] [Asc QualificationUserId]
|
||||
-- let toUnblock = filter (\quent -> Just reason == quent ^? _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedReason) blockedUsers
|
||||
-- oks <- updateWhereCount [ QualificationUserId <-. (view _entityKey <$> toUnblock) ]
|
||||
-- [ QualificationUserBlockedDue =. Nothing ]
|
||||
-- forM_ toUnblock $ \ubl -> do
|
||||
-- audit TransactionQualificationUserBlocking
|
||||
-- { -- transactionQualificationUser = quid
|
||||
-- transactionQualification = qid
|
||||
-- , transactionUser = ubl ^. _entityVal . _qualificationUserUser
|
||||
-- , transactionQualificationBlock = Nothing
|
||||
-- }
|
||||
-- return $ fromIntegral oks
|
||||
|
||||
qualificationUserUnblockByReason ::
|
||||
( AuthId (HandlerSite m) ~ Key User
|
||||
, IsPersistBackend (YesodPersistBackend (HandlerSite m))
|
||||
, BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend
|
||||
, BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
|
||||
, PersistQueryWrite (YesodPersistBackend (HandlerSite m))
|
||||
, PersistUniqueWrite (YesodPersistBackend (HandlerSite m))
|
||||
, HasInstanceID (HandlerSite m) InstanceId
|
||||
, YesodAuthPersist (HandlerSite m)
|
||||
, HasAppSettings (HandlerSite m)
|
||||
, MonadHandler m
|
||||
, MonadCatch m
|
||||
, Num n
|
||||
) => QualificationId -> [UserId] -> Text -> Text -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
|
||||
qualificationUserUnblockByReason qid uids reason undo_reason notify = do
|
||||
now <- liftIO getCurrentTime
|
||||
let nowaday = utctDay now
|
||||
toUnblock <- E.select $ do
|
||||
quser <- E.from $ E.table @QualificationUser
|
||||
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
|
||||
E.&&. quser E.^. QualificationUserUser `E.in_` E.valList uids
|
||||
E.&&. quserBlockAux True nowaday (E.==. (quser E.^. QualificationUserId)) (Just (\qblock -> (qblock E.^. QualificationUserBlockReason) E.==. E.val reason))
|
||||
return $ quser E.^. QualificationUserUser
|
||||
qualificationUserBlocking qid (E.unValue <$> toUnblock) True undo_reason notify
|
||||
|
||||
@ -160,34 +160,9 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
|
||||
|
||||
notifyInvalidDrivers <- E.select $ do
|
||||
quser <- E.from $ E.table @QualificationUser
|
||||
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
|
||||
)
|
||||
))
|
||||
E.where_ $ E.not_ (quser `qualificationValid` nowaday) -- currently invalid
|
||||
E.&&. quser E.^. QualificationUserQualification E.==. E.val qid -- correct qualification
|
||||
E.&&. quser `quserToNotify` nowaday -- recently became invalid or blocked
|
||||
pure (quser E.^. QualificationUserUser)
|
||||
|
||||
forM_ notifyInvalidDrivers $ \(E.Value uid) ->
|
||||
@ -257,11 +232,11 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
|
||||
note <- if saneDate && replaceLmsStatus lmsUserStatus newStatus
|
||||
then do
|
||||
-- WORKAROUND LMS-Bug [supposedly fixed now, but isnt]: sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning
|
||||
-- _ok <- qualificationUserUnblockByReason qid [qualificationUserUser] (qualificationBlockedReasonText QualificationBlockFailedELearning) -- affects audit log
|
||||
when (Just (qualificationBlockedReasonText QualificationBlockFailedELearning) == qualificationUserBlockedDue ^? _Just . _qualificationBlockedReason) $
|
||||
update quid [ QualificationUserBlockedDue =. Nothing ]
|
||||
let reason_elearning = qualificationBlockedReasonText QualificationBlockFailedELearning
|
||||
ok_unblock <- qualificationUserUnblockByReason qid [qualificationUserUser] reason_elearning ("LMS Workaround undoing: " <> reason_elearning) False -- affects audit log
|
||||
when (ok_unblock > 0) ($logWarnS "LmsResult" [st|LMS workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid}|])
|
||||
|
||||
_ok <- renewValidQualificationUsers qid [qualificationUserUser] -- ignores possible blocks
|
||||
_ok_renew <- renewValidQualificationUsers qid [qualificationUserUser] -- ignores possible blocks
|
||||
-- when (ok==1) $ update luid -- we end lms regardless of whether or not a regular renewal was successful, since BPol users may simultaneoysly have on-premise renewal courses and E-Learnings
|
||||
|
||||
update luid
|
||||
@ -270,7 +245,7 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
|
||||
]
|
||||
return Nothing
|
||||
else do
|
||||
let errmsg = [st|LMS success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent}|]
|
||||
let errmsg = [st|LMS success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent} for #{tshow qid}|]
|
||||
$logErrorS "LmsResult" errmsg
|
||||
return $ Just errmsg
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user