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

refactor(qualification): blocks need exact time for ordering

Browse Source
This commit is contained in:
Steffen Jost 2023-06-26 10:07:41 +00:00
parent ff7675542a
commit a28fb72021
8 changed files with 98 additions and 87 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
models/lms.model
View File

@ -71,7 +71,7 @@ QualificationUser
QualificationUserBlock QualificationUserBlock
qualificationUser QualificationUserId OnDeleteCascade OnUpdateCascade qualificationUser QualificationUserId OnDeleteCascade OnUpdateCascade
unblock Bool unblock Bool
from Day from UTCTime
-- until Day Maybe -- if Nothing then the block holds indefinitely -- until Day Maybe -- if Nothing then the block holds indefinitely
reason Text reason Text
-- company -- to be encoded in reason -- company -- to be encoded in reason

1
src/Handler/LMS/Fake.hs
View File

@ -129,7 +129,6 @@ fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (u
qualificationUserValidUntil = addDays expOffset expiryNotifyDay qualificationUserValidUntil = addDays expOffset expiryNotifyDay
qualificationUserFirstHeld = addGregorianMonthsClip (-24) qualificationUserValidUntil qualificationUserFirstHeld = addGregorianMonthsClip (-24) qualificationUserValidUntil
qualificationUserLastRefresh = qualificationUserFirstHeld qualificationUserLastRefresh = qualificationUserFirstHeld
qualificationUserBlockedDue = Nothing
qualificationUserScheduleRenewal = True qualificationUserScheduleRenewal = True
qualificationUserLastNotified = now qualificationUserLastNotified = now
_ <- upsert QualificationUser{..} _ <- upsert QualificationUser{..}

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

@ -18,7 +18,7 @@ import qualified Database.Esqueleto.Utils as E
import Handler.Utils.DateTime (toMidnight) import Handler.Utils.DateTime (toMidnight)
-- needs refactoring, probbably no longer helpful -- needs refactoring, probbably no longer helpful
mkQualificationBlocked :: QualificationBlockStandardReason -> Day -> QualificationUserId -> QualificationUserBlock mkQualificationBlocked :: QualificationBlockStandardReason -> UTCTime -> QualificationUserId -> QualificationUserBlock
mkQualificationBlocked reason qualificationUserBlockFrom qualificationUserBlockQualificationUser = QualificationUserBlock{..} mkQualificationBlocked reason qualificationUserBlockFrom qualificationUserBlockQualificationUser = QualificationUserBlock{..}
where where
qualificationUserBlockReason = qualificationBlockedReasonText reason qualificationUserBlockReason = qualificationBlockedReasonText reason
@ -36,95 +36,98 @@ mkQualificationBlocked reason qualificationUserBlockFrom qualificationUserBlockQ
------------------ ------------------
-- | Recently became invalid or blocked and not yet notified -- | Recently became invalid or blocked and not yet notified
quserToNotify :: E.SqlExpr (Entity QualificationUser) -> Day -> E.SqlExpr (E.Value Bool) quserToNotify :: E.SqlExpr (Entity QualificationUser) -> UTCTime -> E.SqlExpr (E.Value Bool)
quserToNotify quser aday = -- recently invalid or... quserToNotify quser cutoff = -- recently invalid or...
( E.day (quser E.^. QualificationUserLastNotified) E.<. quser E.^. QualificationUserValidUntil ( E.day (quser E.^. QualificationUserLastNotified) E.<. quser E.^. QualificationUserValidUntil
E.&&. E.notExists (do E.&&. E.notExists (do
qualUserBlock <- E.from $ E.table @QualificationUserBlock qualUserBlock <- E.from $ E.table @QualificationUserBlock
E.where_ $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock) E.where_ $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock)
E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.>. E.day (quser E.^. QualificationUserLastNotified) E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.>. quser E.^. QualificationUserLastNotified
E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.<=. E.val aday E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.<=. E.val cutoff
E.&&. E.notExists (do -- block is the most recent block E.&&. E.notExists (do -- block is the most recent block
qualUserLaterBlock <- E.from $ E.table @QualificationUserBlock qualUserLaterBlock <- E.from $ E.table @QualificationUserBlock
E.where_ $ -- ((E.>.) `on` (E.^. QualificationUserBlockFrom) qualUserLaterBlock qualUserBlock) E.where_ $ -- ((E.>.) `on` (E.^. QualificationUserBlockFrom) qualUserLaterBlock qualUserBlock)
qualUserLaterBlock E.^. QualificationUserBlockFrom E.>. qualUserBlock E.^. QualificationUserBlockFrom 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 ) E.||. E.exists (do -- ...recently blocked
qualUserBlock <- E.from $ E.table @QualificationUserBlock qualUserBlock <- E.from $ E.table @QualificationUserBlock
E.where_ $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock) -- block is not an unblock 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.&&. E.day (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.>. quser E.^. QualificationUserLastNotified -- block has not yet been communicated
E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.<=. E.val aday -- block is already active E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.<=. E.val cutoff -- block is already active
E.&&. E.notExists (do -- block is the most recent block E.&&. E.notExists (do -- block is the most recent block
qualUserLaterBlock <- E.from $ E.table @QualificationUserBlock qualUserLaterBlock <- E.from $ E.table @QualificationUserBlock
E.where_ $ -- ((E.>.) `on` (E.^. QualificationUserBlockFrom) qualUserLaterBlock qualUserBlock)) E.where_ $ -- ((E.>.) `on` (E.^. QualificationUserBlockFrom) qualUserLaterBlock qualUserBlock))
qualUserLaterBlock E.^. QualificationUserBlockFrom E.>. qualUserBlock E.^. QualificationUserBlockFrom 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 :: 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 nowaday checkQualUserId mbBlockCondition = bool E.notExists E.exists negCond $ do quserBlockAux negCond cutoff checkQualUserId mbBlockCondition = bool E.notExists E.exists negCond $ do
qualUserBlock <- E.from $ E.table @QualificationUserBlock qualUserBlock <- E.from $ E.table @QualificationUserBlock
E.where_ $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock) 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.&&. checkQualUserId (qualUserBlock E.^. QualificationUserBlockQualificationUser)
E.&&. E.notExists (do E.&&. E.notExists (do
qualUserUnblock <- E.from $ E.table @QualificationUserBlock qualUserUnblock <- E.from $ E.table @QualificationUserBlock
E.where_ $ (qualUserUnblock E.^. QualificationUserBlockUnblock) E.where_ $ (qualUserUnblock E.^. QualificationUserBlockUnblock)
E.&&. checkQualUserId (qualUserUnblock E.^. QualificationUserBlockQualificationUser) 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 E.&&. qualUserUnblock E.^. QualificationUserBlockFrom E.>. qualUserBlock E.^. QualificationUserBlockFrom
) )
whenIsJust mbBlockCondition (E.where_ . ($ qualUserBlock)) whenIsJust mbBlockCondition (E.where_ . ($ qualUserBlock))
-- | Test whether a QualificationUser was blocked/unblocked at a given day; negCond: True:isBlocked False:isUnblocked -- | 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 :: Bool -> UTCTime -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool)
quserBlock negCond aday qualUser = quserBlockAux negCond aday (E.==. (qualUser E.^. QualificationUserId)) Nothing quserBlock negCond cutoff qualUser = quserBlockAux negCond cutoff (E.==. (qualUser E.^. QualificationUserId)) Nothing
-- | Variant of `isBlocked` for outer joins -- | Variant of `isBlocked` for outer joins
quserBlock' :: Bool -> Day -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool) quserBlock' :: Bool -> UTCTime -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool)
quserBlock' negCond aday qualUser = quserBlockAux negCond aday (E.=?. (qualUser E.?. QualificationUserId)) Nothing 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 qualificationValid = flip validQualification
validQualification :: Day -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool) validQualification :: UTCTime -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool)
validQualification nowaday qualUser = validQualification cutoff qualUser =
(E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld (E.val (utctDay cutoff) `E.between` (qualUser E.^. QualificationUserFirstHeld
,qualUser E.^. QualificationUserValidUntil)) -- currently valid ,qualUser E.^. QualificationUserValidUntil)) -- currently valid
E.&&. quserBlock False nowaday qualUser E.&&. quserBlock False cutoff qualUser
-- | Variant of `validQualification` for outer joins -- | Variant of `validQualification` for outer joins
validQualification' :: Day -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool) validQualification' :: UTCTime -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool)
validQualification' nowaday qualUser = validQualification' cutoff qualUser =
(E.justVal nowaday `E.between` (qualUser E.?. QualificationUserFirstHeld (E.justVal (utctDay cutoff) `E.between` (qualUser E.?. QualificationUserFirstHeld
,qualUser E.?. QualificationUserValidUntil)) -- currently valid ,qualUser E.?. QualificationUserValidUntil)) -- currently valid
E.&&. quserBlock' False nowaday qualUser E.&&. quserBlock' False cutoff qualUser
selectValidQualifications :: QualificationId -> Maybe [UserId] -> Day -> DB [Entity QualificationUser] selectValidQualifications :: QualificationId -> Maybe [UserId] -> UTCTime -> DB [Entity QualificationUser]
selectValidQualifications qid mbUids nowaday = selectValidQualifications qid mbUids cutoff =
-- nowaday <- utctDay <$> liftIO getCurrentTime -- cutoff <- utctDay <$> liftIO getCurrentTime
E.select $ do E.select $ do
qUser <- E.from $ E.table @QualificationUser qUser <- E.from $ E.table @QualificationUser
E.where_ $ (qUser E.^. QualificationUserQualification E.==. E.val qid) 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 -- 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) whenIsJust mbUids (\uids -> E.where_ $ qUser E.^. QualificationUserUser `E.in_` E.valList uids)
pure qUser pure qUser
selectRelevantBlock :: UTCTime -> QualificationUserId -> DB (Maybe (Entity QualificationUserBlock))
selectRelevantBlock cutoff quid =
selectFirst [QualificationUserBlockQualificationUser ==. quid, QualificationUserBlockFrom <=. cutoff] [Desc QualificationUserBlockFrom]
------------------------ ------------------------
-- Complete Functions -- -- 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 upsertQualificationUser qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal mbUnblockBecause qualificationUserUser = do
Entity quid _ <- upsert Entity quid _ <- upsert
QualificationUser QualificationUser
@ -165,10 +168,11 @@ renewValidQualificationUsers qid uids =
-- E.&&. (qu E.^. QualificationUserUser `E.in_` E.valList uids) -- E.&&. (qu E.^. QualificationUserUser `E.in_` E.valList uids)
get qid >>= \case get qid >>= \case
Just Qualification{qualificationValidDuration=Just renewalMonths} -> do Just Qualification{qualificationValidDuration=Just renewalMonths} -> do
nowaday <- utctDay <$> liftIO getCurrentTime now <- liftIO getCurrentTime
quEntsAll <- selectValidQualifications qid (Just uids) nowaday quEntsAll <- selectValidQualifications qid (Just uids) now
let maxValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) nowaday let nowaday = utctDay now
quEnts = filter (\q -> maxValidTo >= (q ^. _entityVal . _qualificationUserValidUntil)) quEntsAll maxValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) nowaday
quEnts = filter (\q -> maxValidTo >= (q ^. _entityVal . _qualificationUserValidUntil)) quEntsAll
forM_ quEnts $ \(Entity quId QualificationUser{..}) -> do forM_ quEnts $ \(Entity quId QualificationUser{..}) -> do
let newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil let newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil
update quId [ QualificationUserValidUntil =. newValidTo update quId [ QualificationUserValidUntil =. newValidTo
@ -184,8 +188,7 @@ renewValidQualificationUsers qid uids =
return $ length quEnts return $ length quEnts
_ -> return (-1) -- qualificationId not found, isNothing qualificationValidDuration, etc. _ -> return (-1) -- qualificationId not found, isNothing qualificationValidDuration, etc.
-- | Block or unblock some users for a given reason
-- qualificationUserBlocking :: QualificationId -> [UserId] -> Maybe QualificationBlocked -> DB Int64
qualificationUserBlocking :: qualificationUserBlocking ::
( AuthId (HandlerSite m) ~ Key User ( AuthId (HandlerSite m) ~ Key User
, IsPersistBackend (YesodPersistBackend (HandlerSite m)) , IsPersistBackend (YesodPersistBackend (HandlerSite m))
@ -199,12 +202,10 @@ qualificationUserBlocking ::
, MonadHandler m , MonadHandler m
, MonadCatch m , MonadCatch m
, Num n , Num n
) => QualificationId -> [UserId] -> Bool -> Text -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n ) => QualificationId -> [UserId] -> Bool -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
qualificationUserBlocking qid uids unblock (qualificationBlockReasonText -> reason) notify = do
qualificationUserBlocking qid uids unblock reason notify = do
authUsr <- liftHandler maybeAuthId authUsr <- liftHandler maybeAuthId
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let nowaday = utctDay now
-- -- Code would work, but problematic -- -- Code would work, but problematic
-- oks <- E.insertSelectCount . E.from $ \qualificationUser -> do -- oks <- E.insertSelectCount . E.from $ \qualificationUser -> do
-- E.where_ $ qualificationUser E.^. QualificationUserQualification E.==. E.val qid -- 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 qualUser <- E.from $ E.table @QualificationUser
E.where_ $ qualUser E.^. QualificationUserQualification E.==. E.val qid E.where_ $ qualUser E.^. QualificationUserQualification E.==. E.val qid
E.&&. qualUser E.^. QualificationUserUser `E.in_` E.valList uids 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) return (qualUser E.^. QualificationUserId, qualUser E.^. QualificationUserUser)
let toChange = E.unValue . fst <$> toChange' let toChange = E.unValue . fst <$> toChange'
E.insertMany_ $ map (\quid -> QualificationUserBlock E.insertMany_ $ map (\quid -> QualificationUserBlock
{ qualificationUserBlockQualificationUser = quid { qualificationUserBlockQualificationUser = quid
, qualificationUserBlockUnblock = unblock , qualificationUserBlockUnblock = unblock
, qualificationUserBlockFrom = nowaday , qualificationUserBlockFrom = now
, qualificationUserBlockReason = reason , qualificationUserBlockReason = reason
, qualificationUserBlockBlocker = authUsr , qualificationUserBlockBlocker = authUsr
}) toChange }) toChange
@ -256,14 +257,13 @@ qualificationUserUnblockByReason ::
, MonadHandler m , MonadHandler m
, MonadCatch m , MonadCatch m
, Num n , Num n
) => QualificationId -> [UserId] -> Text -> Text -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n ) => QualificationId -> [UserId] -> QualificationBlockReason -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
qualificationUserUnblockByReason qid uids reason undo_reason notify = do qualificationUserUnblockByReason qid uids (qualificationBlockReasonText -> reason) undo_reason notify = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let nowaday = utctDay now
toUnblock <- E.select $ do toUnblock <- E.select $ do
quser <- E.from $ E.table @QualificationUser quser <- E.from $ E.table @QualificationUser
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
E.&&. quser E.^. QualificationUserUser `E.in_` E.valList uids 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 return $ quser E.^. QualificationUserUser
qualificationUserBlocking qid (E.unValue <$> toUnblock) True undo_reason notify qualificationUserBlocking qid (E.unValue <$> toUnblock) True undo_reason notify

25
src/Handler/Utils/Table/Cells.hs
View File

@ -376,18 +376,19 @@ lmsStatusCell extendedInfo (Just toLink) lu = cell $ do
uuid <- liftHandler $ encrypt $ lu ^. _lmsUserUser uuid <- liftHandler $ encrypt $ lu ^. _lmsUserUser
modal (lmsUserStatusWidget extendedInfo lu) (Left $ SomeRoute $ toLink uuid) modal (lmsUserStatusWidget extendedInfo lu) (Left $ SomeRoute $ toLink uuid)
qualificationBlockedCellNoReason :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a -- TODO: rework this below once it is clear what we need instead
qualificationBlockedCellNoReason Nothing = mempty -- qualificationBlockedCellNoReason :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a
qualificationBlockedCellNoReason (Just QualificationBlocked{qualificationBlockedDay=d}) = -- qualificationBlockedCellNoReason Nothing = mempty
iconCell IconBlocked <> spacerCell <> dayCell d -- qualificationBlockedCellNoReason (Just QualificationBlocked{qualificationBlockedDay=d}) =
-- iconCell IconBlocked <> spacerCell <> dayCell d
qualificationBlockedCell :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a -- TODO: rework this below once it is clear what we need instead
qualificationBlockedCell Nothing = mempty -- qualificationBlockedCell :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a
qualificationBlockedCell (Just QualificationBlocked{..}) -- qualificationBlockedCell Nothing = mempty
| 32 >= length qualificationBlockedReason = mkCellWith textCell -- qualificationBlockedCell (Just QualificationBlocked{..})
| otherwise = mkCellWith modalCell -- | 32 >= length qualificationBlockedReason = mkCellWith textCell
where -- | otherwise = mkCellWith modalCell
mkCellWith c = c qualificationBlockedReason <> spacerCell <> iconCell IconBlocked <> spacerCell <> dayCell qualificationBlockedDay -- where
-- mkCellWith c = c qualificationBlockedReason <> spacerCell <> iconCell IconBlocked <> spacerCell <> dayCell qualificationBlockedDay
avsPersonNoCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c avsPersonNoCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c
avsPersonNoCell = numCell . view _userAvsNoPerson avsPersonNoCell = numCell . view _userAvsNoPerson

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

@ -222,7 +222,7 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
return (quser, luser, lresult) return (quser, luser, lresult)
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now 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. -- three separate DB operations per result is not so nice. All within one transaction though.
let lmsUserStartedDay = localDay $ TZ.utcToLocalTimeTZ appTZ lmsUserStarted let lmsUserStartedDay = localDay $ TZ.utcToLocalTimeTZ appTZ lmsUserStarted
saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil locDay) saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil locDay)
@ -232,8 +232,8 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
note <- if saneDate && replaceLmsStatus lmsUserStatus newStatus note <- if saneDate && replaceLmsStatus lmsUserStatus newStatus
then do 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 -- 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 let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning
ok_unblock <- qualificationUserUnblockByReason qid [qualificationUserUser] reason_elearning ("LMS Workaround undoing: " <> reason_elearning) False -- affects audit log 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}|]) 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 _ok_renew <- renewValidQualificationUsers qid [qualificationUserUser] -- ignores possible blocks
@ -263,7 +263,7 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
-- processes received input and block qualifications, if applicable -- processes received input and block qualifications, if applicable
dispatchJobLmsUserlist :: QualificationId -> JobHandler UniWorX dispatchJobLmsUserlist :: QualificationId -> JobHandler UniWorX
dispatchJobLmsUserlist qid = JobHandlerAtomic act dispatchJobLmsUserlist qid = JobHandlerAtomic act
where where
act :: YesodJobDB UniWorX () act :: YesodJobDB UniWorX ()
act = do act = do
@ -284,7 +284,7 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
update luid [LmsUserEnded =. Just now] update luid [LmsUserEnded =. Just now]
| otherwise -> return () -- users likely not yet started | 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 let lReceived = lmsUserlistTimestamp lulist
lmsMsgDay = utctDay lReceived lmsMsgDay = utctDay lReceived
update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotified is only updated upon sending notifications update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotified is only updated upon sending notifications
@ -301,6 +301,11 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
newStatus = bool Nothing (Just $ LmsBlocked lmsMsgDay) isBlocked newStatus = bool Nothing (Just $ LmsBlocked lmsMsgDay) isBlocked
updateStatus = replaceLmsStatus oldStatus newStatus updateStatus = replaceLmsStatus oldStatus newStatus
when updateStatus $ do 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 audit TransactionLmsBlocked
{ transactionQualification = qid { transactionQualification = qid
, transactionLmsIdent = lmsUserIdent luser , transactionLmsIdent = lmsUserIdent luser
@ -309,13 +314,5 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
, transactionNote = Just $ "Old status was " <> tshow oldStatus , transactionNote = Just $ "Old status was " <> tshow oldStatus
, transactionReceived = lReceived , 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 delete lulid
$logInfoS "LmsUserlist" [st|Processed LMS Userlist with ${tshow (length results)} entries|] $logInfoS "LmsUserlist" [st|Processed LMS Userlist with ${tshow (length results)} entries|]

5
src/Jobs/Handler/SendNotification/Qualification.hs
View File

@ -53,8 +53,11 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do
case dbRes of case dbRes of
( Just User{..}, Just Qualification{..}, Just (Entity quId QualificationUser{..})) -> do ( 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 urender <- getUrlRender
let expDay = maybe qualificationUserValidUntil (min qualificationUserValidUntil . qualificationBlockedDay) qualificationUserBlockedDue let expDay = maybe qualificationUserValidUntil (min qualificationUserValidUntil . qualificationUserBlockFrom) block
qname = CI.original qualificationName qname = CI.original qualificationName
qshort = CI.original qualificationShorthand qshort = CI.original qualificationShorthand
letter = LetterExpireQualificationF letter = LetterExpireQualificationF

8
src/Model/Types/Lms.hs
View File

@ -86,7 +86,7 @@ instance Csv.ToField LmsStatus where
toField (LmsExpired d) = "Expired: " <> Csv.toField d toField (LmsExpired d) = "Expired: " <> Csv.toField d
toField (LmsSuccess d) = "Success: " <> Csv.toField d toField (LmsSuccess d) = "Success: " <> Csv.toField d
-- | Default Block/Unblock reasons
data QualificationBlockStandardReason data QualificationBlockStandardReason
= QualificationBlockFailedELearning = QualificationBlockFailedELearning
| QualificationBlockReturnedByCompany | QualificationBlockReturnedByCompany
@ -101,6 +101,12 @@ qualificationBlockedReasonText =
let dictionary :: Map.Map QualificationBlockStandardReason Text = Map.fromList [(r, tshow r) | r <- universeF] let dictionary :: Map.Map QualificationBlockStandardReason Text = Map.fromList [(r, tshow r) | r <- universeF]
in (dictionary !) -- cannot fail due to 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 -- | LMS interface requires Bool to be encoded by 0 or 1 only
newtype LmsBool = LmsBool { lms2bool :: Bool } newtype LmsBool = LmsBool { lms2bool :: Bool }
deriving (Eq, Ord, Read, Show, Generic) deriving (Eq, Ord, Read, Show, Generic)

5
src/Utils.hs
View File

@ -870,6 +870,11 @@ deepAlt altFst _ = altFst
maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m
maybeEmpty = flip foldMap 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 -- | also referred to as whenJust
whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust (Just x) f = f x whenIsJust (Just x) f = f x