refactor(qualification): blocks need exact time for ordering
This commit is contained in:
parent
ff7675542a
commit
a28fb72021
@ -71,7 +71,7 @@ QualificationUser
|
||||
QualificationUserBlock
|
||||
qualificationUser QualificationUserId OnDeleteCascade OnUpdateCascade
|
||||
unblock Bool
|
||||
from Day
|
||||
from UTCTime
|
||||
-- until Day Maybe -- if Nothing then the block holds indefinitely
|
||||
reason Text
|
||||
-- company -- to be encoded in reason
|
||||
|
||||
@ -128,8 +128,7 @@ fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (u
|
||||
qualificationUserQualification = qid
|
||||
qualificationUserValidUntil = addDays expOffset expiryNotifyDay
|
||||
qualificationUserFirstHeld = addGregorianMonthsClip (-24) qualificationUserValidUntil
|
||||
qualificationUserLastRefresh = qualificationUserFirstHeld
|
||||
qualificationUserBlockedDue = Nothing
|
||||
qualificationUserLastRefresh = qualificationUserFirstHeld
|
||||
qualificationUserScheduleRenewal = True
|
||||
qualificationUserLastNotified = now
|
||||
_ <- upsert QualificationUser{..}
|
||||
|
||||
@ -18,7 +18,7 @@ import qualified Database.Esqueleto.Utils as E
|
||||
import Handler.Utils.DateTime (toMidnight)
|
||||
|
||||
-- needs refactoring, probbably no longer helpful
|
||||
mkQualificationBlocked :: QualificationBlockStandardReason -> Day -> QualificationUserId -> QualificationUserBlock
|
||||
mkQualificationBlocked :: QualificationBlockStandardReason -> UTCTime -> QualificationUserId -> QualificationUserBlock
|
||||
mkQualificationBlocked reason qualificationUserBlockFrom qualificationUserBlockQualificationUser = QualificationUserBlock{..}
|
||||
where
|
||||
qualificationUserBlockReason = qualificationBlockedReasonText reason
|
||||
@ -36,95 +36,98 @@ mkQualificationBlocked reason qualificationUserBlockFrom qualificationUserBlockQ
|
||||
------------------
|
||||
|
||||
-- | 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...
|
||||
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.>. E.day (quser E.^. QualificationUserLastNotified)
|
||||
E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.<=. E.val aday
|
||||
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 aday
|
||||
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.&&. 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.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 aday
|
||||
E.&&. qualUserLaterBlock E.^. QualificationUserBlockFrom E.<=. E.val cutoff
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
-- TODO: consider replacing `nowaday` by `Database.Esqueleto.PostgreSQL.now_` or better `day(now_)` cast as date
|
||||
-- TODO: consider replacing `cutoff` by `Database.Esqueleto.PostgreSQL.now_`?
|
||||
|
||||
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
|
||||
quserBlockAux :: Bool -> UTCTime -> (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 cutoff 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)
|
||||
E.&&. (qualUserBlock E.^. QualificationUserBlockFrom E.<=. E.val cutoff)
|
||||
E.&&. checkQualUserId (qualUserBlock E.^. QualificationUserBlockQualificationUser)
|
||||
E.&&. E.notExists (do
|
||||
qualUserUnblock <- E.from $ E.table @QualificationUserBlock
|
||||
E.where_ $ (qualUserUnblock E.^. QualificationUserBlockUnblock)
|
||||
E.&&. checkQualUserId (qualUserUnblock E.^. QualificationUserBlockQualificationUser)
|
||||
E.&&. qualUserUnblock E.^. QualificationUserBlockFrom E.<=. E.val nowaday
|
||||
E.&&. qualUserUnblock E.^. QualificationUserBlockFrom E.<=. E.val cutoff
|
||||
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)) Nothing
|
||||
quserBlock :: Bool -> UTCTime -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool)
|
||||
quserBlock negCond cutoff qualUser = quserBlockAux negCond cutoff (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)) Nothing
|
||||
quserBlock' :: Bool -> UTCTime -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool)
|
||||
quserBlock' negCond cutoff qualUser = quserBlockAux negCond cutoff (E.=?. (qualUser E.?. QualificationUserId)) Nothing
|
||||
|
||||
qualificationValid :: E.SqlExpr (Entity QualificationUser) -> Day -> E.SqlExpr (E.Value Bool)
|
||||
qualificationValid :: E.SqlExpr (Entity QualificationUser) -> UTCTime -> E.SqlExpr (E.Value Bool)
|
||||
qualificationValid = flip validQualification
|
||||
|
||||
validQualification :: Day -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool)
|
||||
validQualification nowaday qualUser =
|
||||
(E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld
|
||||
,qualUser E.^. QualificationUserValidUntil)) -- currently valid
|
||||
E.&&. quserBlock False nowaday qualUser
|
||||
validQualification :: UTCTime -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool)
|
||||
validQualification cutoff qualUser =
|
||||
(E.val (utctDay cutoff) `E.between` (qualUser E.^. QualificationUserFirstHeld
|
||||
,qualUser E.^. QualificationUserValidUntil)) -- currently valid
|
||||
E.&&. quserBlock False cutoff qualUser
|
||||
|
||||
-- | Variant of `validQualification` for outer joins
|
||||
validQualification' :: Day -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool)
|
||||
validQualification' nowaday qualUser =
|
||||
(E.justVal nowaday `E.between` (qualUser E.?. QualificationUserFirstHeld
|
||||
,qualUser E.?. QualificationUserValidUntil)) -- currently valid
|
||||
E.&&. quserBlock' False nowaday qualUser
|
||||
validQualification' :: UTCTime -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool)
|
||||
validQualification' cutoff qualUser =
|
||||
(E.justVal (utctDay cutoff) `E.between` (qualUser E.?. QualificationUserFirstHeld
|
||||
,qualUser E.?. QualificationUserValidUntil)) -- currently valid
|
||||
E.&&. quserBlock' False cutoff qualUser
|
||||
|
||||
selectValidQualifications :: QualificationId -> Maybe [UserId] -> Day -> DB [Entity QualificationUser]
|
||||
selectValidQualifications qid mbUids nowaday =
|
||||
-- nowaday <- utctDay <$> liftIO getCurrentTime
|
||||
selectValidQualifications :: QualificationId -> Maybe [UserId] -> UTCTime -> DB [Entity QualificationUser]
|
||||
selectValidQualifications qid mbUids cutoff =
|
||||
-- cutoff <- utctDay <$> liftIO getCurrentTime
|
||||
E.select $ do
|
||||
qUser <- E.from $ E.table @QualificationUser
|
||||
E.where_ $ (qUser E.^. QualificationUserQualification E.==. E.val qid)
|
||||
E.&&. validQualification nowaday qUser
|
||||
E.&&. validQualification cutoff qUser
|
||||
-- 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
|
||||
|
||||
selectRelevantBlock :: UTCTime -> QualificationUserId -> DB (Maybe (Entity QualificationUserBlock))
|
||||
selectRelevantBlock cutoff quid =
|
||||
selectFirst [QualificationUserBlockQualificationUser ==. quid, QualificationUserBlockFrom <=. cutoff] [Desc QualificationUserBlockFrom]
|
||||
|
||||
------------------------
|
||||
-- Complete Functions --
|
||||
------------------------
|
||||
|
||||
|
||||
upsertQualificationUser :: QualificationId -> Day -> Day -> Maybe Bool -> Maybe (Day, Text, Maybe UserId) -> UserId -> DB () -- may also unblock
|
||||
upsertQualificationUser :: QualificationId -> Day -> Day -> Maybe Bool -> Maybe (UTCTime, Text, Maybe UserId) -> UserId -> DB () -- may also unblock
|
||||
upsertQualificationUser qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal mbUnblockBecause qualificationUserUser = do
|
||||
Entity quid _ <- upsert
|
||||
QualificationUser
|
||||
@ -165,10 +168,11 @@ renewValidQualificationUsers qid uids =
|
||||
-- E.&&. (qu E.^. QualificationUserUser `E.in_` E.valList uids)
|
||||
get qid >>= \case
|
||||
Just Qualification{qualificationValidDuration=Just renewalMonths} -> do
|
||||
nowaday <- utctDay <$> liftIO getCurrentTime
|
||||
quEntsAll <- selectValidQualifications qid (Just uids) nowaday
|
||||
let maxValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) nowaday
|
||||
quEnts = filter (\q -> maxValidTo >= (q ^. _entityVal . _qualificationUserValidUntil)) quEntsAll
|
||||
now <- liftIO getCurrentTime
|
||||
quEntsAll <- selectValidQualifications qid (Just uids) now
|
||||
let nowaday = utctDay now
|
||||
maxValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) nowaday
|
||||
quEnts = filter (\q -> maxValidTo >= (q ^. _entityVal . _qualificationUserValidUntil)) quEntsAll
|
||||
forM_ quEnts $ \(Entity quId QualificationUser{..}) -> do
|
||||
let newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil
|
||||
update quId [ QualificationUserValidUntil =. newValidTo
|
||||
@ -184,8 +188,7 @@ renewValidQualificationUsers qid uids =
|
||||
return $ length quEnts
|
||||
_ -> return (-1) -- qualificationId not found, isNothing qualificationValidDuration, etc.
|
||||
|
||||
|
||||
-- qualificationUserBlocking :: QualificationId -> [UserId] -> Maybe QualificationBlocked -> DB Int64
|
||||
-- | Block or unblock some users for a given reason
|
||||
qualificationUserBlocking ::
|
||||
( AuthId (HandlerSite m) ~ Key User
|
||||
, IsPersistBackend (YesodPersistBackend (HandlerSite m))
|
||||
@ -199,12 +202,10 @@ qualificationUserBlocking ::
|
||||
, MonadHandler m
|
||||
, MonadCatch m
|
||||
, Num n
|
||||
) => QualificationId -> [UserId] -> Bool -> Text -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
|
||||
|
||||
qualificationUserBlocking qid uids unblock reason notify = do
|
||||
) => QualificationId -> [UserId] -> Bool -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
|
||||
qualificationUserBlocking qid uids unblock (qualificationBlockReasonText -> reason) notify = do
|
||||
authUsr <- liftHandler maybeAuthId
|
||||
now <- liftIO getCurrentTime
|
||||
let nowaday = utctDay now
|
||||
now <- liftIO getCurrentTime
|
||||
-- -- Code would work, but problematic
|
||||
-- oks <- E.insertSelectCount . E.from $ \qualificationUser -> do
|
||||
-- E.where_ $ qualificationUser E.^. QualificationUserQualification E.==. E.val qid
|
||||
@ -220,13 +221,13 @@ qualificationUserBlocking qid uids unblock reason notify = do
|
||||
qualUser <- E.from $ E.table @QualificationUser
|
||||
E.where_ $ qualUser E.^. QualificationUserQualification E.==. E.val qid
|
||||
E.&&. qualUser E.^. QualificationUserUser `E.in_` E.valList uids
|
||||
E.&&. quserBlock (not unblock) nowaday qualUser -- only unblock blocked qualification and vice versa
|
||||
E.&&. quserBlock (not unblock) now qualUser -- only unblock blocked qualification and vice versa
|
||||
return (qualUser E.^. QualificationUserId, qualUser E.^. QualificationUserUser)
|
||||
let toChange = E.unValue . fst <$> toChange'
|
||||
E.insertMany_ $ map (\quid -> QualificationUserBlock
|
||||
{ qualificationUserBlockQualificationUser = quid
|
||||
, qualificationUserBlockUnblock = unblock
|
||||
, qualificationUserBlockFrom = nowaday
|
||||
, qualificationUserBlockFrom = now
|
||||
, qualificationUserBlockReason = reason
|
||||
, qualificationUserBlockBlocker = authUsr
|
||||
}) toChange
|
||||
@ -256,14 +257,13 @@ qualificationUserUnblockByReason ::
|
||||
, 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
|
||||
) => QualificationId -> [UserId] -> QualificationBlockReason -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
|
||||
qualificationUserUnblockByReason qid uids (qualificationBlockReasonText -> reason) undo_reason notify = do
|
||||
now <- liftIO getCurrentTime
|
||||
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))
|
||||
E.&&. quserBlockAux True now (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
|
||||
|
||||
@ -376,18 +376,19 @@ lmsStatusCell extendedInfo (Just toLink) lu = cell $ do
|
||||
uuid <- liftHandler $ encrypt $ lu ^. _lmsUserUser
|
||||
modal (lmsUserStatusWidget extendedInfo lu) (Left $ SomeRoute $ toLink uuid)
|
||||
|
||||
qualificationBlockedCellNoReason :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a
|
||||
qualificationBlockedCellNoReason Nothing = mempty
|
||||
qualificationBlockedCellNoReason (Just QualificationBlocked{qualificationBlockedDay=d}) =
|
||||
iconCell IconBlocked <> spacerCell <> dayCell d
|
||||
|
||||
qualificationBlockedCell :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a
|
||||
qualificationBlockedCell Nothing = mempty
|
||||
qualificationBlockedCell (Just QualificationBlocked{..})
|
||||
| 32 >= length qualificationBlockedReason = mkCellWith textCell
|
||||
| otherwise = mkCellWith modalCell
|
||||
where
|
||||
mkCellWith c = c qualificationBlockedReason <> spacerCell <> iconCell IconBlocked <> spacerCell <> dayCell qualificationBlockedDay
|
||||
-- TODO: rework this below once it is clear what we need instead
|
||||
-- qualificationBlockedCellNoReason :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a
|
||||
-- qualificationBlockedCellNoReason Nothing = mempty
|
||||
-- qualificationBlockedCellNoReason (Just QualificationBlocked{qualificationBlockedDay=d}) =
|
||||
-- iconCell IconBlocked <> spacerCell <> dayCell d
|
||||
-- TODO: rework this below once it is clear what we need instead
|
||||
-- qualificationBlockedCell :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a
|
||||
-- qualificationBlockedCell Nothing = mempty
|
||||
-- qualificationBlockedCell (Just QualificationBlocked{..})
|
||||
-- | 32 >= length qualificationBlockedReason = mkCellWith textCell
|
||||
-- | otherwise = mkCellWith modalCell
|
||||
-- where
|
||||
-- mkCellWith c = c qualificationBlockedReason <> spacerCell <> iconCell IconBlocked <> spacerCell <> dayCell qualificationBlockedDay
|
||||
|
||||
avsPersonNoCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c
|
||||
avsPersonNoCell = numCell . view _userAvsNoPerson
|
||||
|
||||
@ -222,7 +222,7 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
|
||||
return (quser, luser, lresult)
|
||||
now <- liftIO getCurrentTime
|
||||
let locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now
|
||||
forM_ results $ \(Entity quid QualificationUser{..}, Entity luid LmsUser{..}, Entity lrid LmsResult{..}) -> do
|
||||
forM_ results $ \(Entity _quid QualificationUser{..}, Entity luid LmsUser{..}, Entity lrid LmsResult{..}) -> do
|
||||
-- three separate DB operations per result is not so nice. All within one transaction though.
|
||||
let lmsUserStartedDay = localDay $ TZ.utcToLocalTimeTZ appTZ lmsUserStarted
|
||||
saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil locDay)
|
||||
@ -232,8 +232,8 @@ 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
|
||||
let reason_elearning = qualificationBlockedReasonText QualificationBlockFailedELearning
|
||||
ok_unblock <- qualificationUserUnblockByReason qid [qualificationUserUser] reason_elearning ("LMS Workaround undoing: " <> reason_elearning) False -- affects audit log
|
||||
let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning
|
||||
ok_unblock <- qualificationUserUnblockByReason qid [qualificationUserUser] (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log
|
||||
when (ok_unblock > 0) ($logWarnS "LmsResult" [st|LMS workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid}|])
|
||||
|
||||
_ok_renew <- renewValidQualificationUsers qid [qualificationUserUser] -- ignores possible blocks
|
||||
@ -263,7 +263,7 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
|
||||
|
||||
-- processes received input and block qualifications, if applicable
|
||||
dispatchJobLmsUserlist :: QualificationId -> JobHandler UniWorX
|
||||
dispatchJobLmsUserlist qid = JobHandlerAtomic act
|
||||
dispatchJobLmsUserlist qid = JobHandlerAtomic act
|
||||
where
|
||||
act :: YesodJobDB UniWorX ()
|
||||
act = do
|
||||
@ -284,7 +284,7 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
|
||||
update luid [LmsUserEnded =. Just now]
|
||||
| otherwise -> return () -- users likely not yet started
|
||||
|
||||
(Entity luid luser, Just (Entity lulid lulist)) -> do
|
||||
(Entity luid luser, Just (Entity _lulid lulist)) -> do
|
||||
let lReceived = lmsUserlistTimestamp lulist
|
||||
lmsMsgDay = utctDay lReceived
|
||||
update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotified is only updated upon sending notifications
|
||||
@ -299,8 +299,13 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
|
||||
let isBlocked = lmsUserlistFailed lulist
|
||||
oldStatus = lmsUserStatus luser
|
||||
newStatus = bool Nothing (Just $ LmsBlocked lmsMsgDay) isBlocked
|
||||
updateStatus = replaceLmsStatus oldStatus newStatus
|
||||
when updateStatus $ do
|
||||
updateStatus = replaceLmsStatus oldStatus newStatus
|
||||
when updateStatus $ do
|
||||
update luid [LmsUserStatus =. newStatus]
|
||||
ok <- qualificationUserBlocking qid [lmsUserUser luser] False (Right QualificationBlockFailedELearning) True
|
||||
when (ok /= 1) $ do
|
||||
uuid :: CryptoUUIDUser <- encrypt $ lmsUserUser luser
|
||||
$logWarnS "LmsUserlist" [st|Blocking by failed E-learning failed for learner #{tshow uuid} and qualification #{tshow qid}]
|
||||
audit TransactionLmsBlocked
|
||||
{ transactionQualification = qid
|
||||
, transactionLmsIdent = lmsUserIdent luser
|
||||
@ -309,13 +314,5 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
|
||||
, transactionNote = Just $ "Old status was " <> tshow oldStatus
|
||||
, transactionReceived = lReceived
|
||||
}
|
||||
update luid [LmsUserStatus =. newStatus]
|
||||
void $ qualificationUserBlocking qid [lmsUserUser luser] True $ Just $ mkQualificationBlocked QualificationBlockFailedELearning lmsMsgDay
|
||||
-- DEACTIVATED FOR NOW; UPON REACTIVATION: DELAY Sending to check for unblocking a few hours later!
|
||||
-- queueDBJob JobSendNotification
|
||||
-- { jRecipient = lmsUserUser luser
|
||||
-- , jNotification = NotificationQualificationExpired { nQualification = qid }
|
||||
-- }
|
||||
|
||||
delete lulid
|
||||
$logInfoS "LmsUserlist" [st|Processed LMS Userlist with ${tshow (length results)} entries|]
|
||||
|
||||
@ -43,18 +43,21 @@ dispatchNotificationQualificationExpiry nQualification dExpiry jRecipient = user
|
||||
|
||||
|
||||
dispatchNotificationQualificationExpired :: QualificationId -> UserId -> Handler ()
|
||||
dispatchNotificationQualificationExpired nQualification jRecipient = do
|
||||
dispatchNotificationQualificationExpired nQualification jRecipient = do
|
||||
encRecipient :: CryptoUUIDUser <- encrypt jRecipient
|
||||
encRecShort <- encrypt jRecipient
|
||||
dbRes <- runDB $ (,,)
|
||||
<$> get jRecipient
|
||||
<*> get nQualification
|
||||
<*> getBy (UniqueQualificationUser nQualification jRecipient)
|
||||
<*> getBy (UniqueQualificationUser nQualification jRecipient)
|
||||
|
||||
case dbRes of
|
||||
( Just User{..}, Just Qualification{..}, Just (Entity quId QualificationUser{..})) -> do
|
||||
now <- liftIO getCurrentTime
|
||||
qub_entry <- runDB $ selectRelevantBlock now quId
|
||||
let block = find (not . qualificationUserBlockUnblock) qub_entry
|
||||
urender <- getUrlRender
|
||||
let expDay = maybe qualificationUserValidUntil (min qualificationUserValidUntil . qualificationBlockedDay) qualificationUserBlockedDue
|
||||
let expDay = maybe qualificationUserValidUntil (min qualificationUserValidUntil . qualificationUserBlockFrom) block
|
||||
qname = CI.original qualificationName
|
||||
qshort = CI.original qualificationShorthand
|
||||
letter = LetterExpireQualificationF
|
||||
|
||||
@ -86,7 +86,7 @@ instance Csv.ToField LmsStatus where
|
||||
toField (LmsExpired d) = "Expired: " <> Csv.toField d
|
||||
toField (LmsSuccess d) = "Success: " <> Csv.toField d
|
||||
|
||||
|
||||
-- | Default Block/Unblock reasons
|
||||
data QualificationBlockStandardReason
|
||||
= QualificationBlockFailedELearning
|
||||
| QualificationBlockReturnedByCompany
|
||||
@ -101,6 +101,12 @@ qualificationBlockedReasonText =
|
||||
let dictionary :: Map.Map QualificationBlockStandardReason Text = Map.fromList [(r, tshow r) | r <- universeF]
|
||||
in (dictionary !) -- cannot fail due to universeF
|
||||
|
||||
type QualificationBlockReason = Either Text QualificationBlockStandardReason
|
||||
|
||||
qualificationBlockReasonText :: QualificationBlockReason -> Text
|
||||
qualificationBlockReasonText (Left reason) = reason
|
||||
qualificationBlockReasonText (Right stdreason) = qualificationBlockedReasonText stdreason
|
||||
|
||||
-- | LMS interface requires Bool to be encoded by 0 or 1 only
|
||||
newtype LmsBool = LmsBool { lms2bool :: Bool }
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
|
||||
@ -870,6 +870,11 @@ deepAlt altFst _ = altFst
|
||||
maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m
|
||||
maybeEmpty = flip foldMap
|
||||
|
||||
-- Use instead the more general `find :: Foldable t => (a -> Bool) -> t a -> Maybe a`
|
||||
-- filterMaybe :: (a -> Bool) -> Maybe a -> Maybe a
|
||||
-- filterMaybe c r@(Just x) | c x = r
|
||||
-- filterMaybe _ _ = Nothing
|
||||
|
||||
-- | also referred to as whenJust
|
||||
whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
|
||||
whenIsJust (Just x) f = f x
|
||||
|
||||
Loading…
Reference in New Issue
Block a user