From a28fb720218257a625deb59bf86d163408b7c17f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 26 Jun 2023 10:07:41 +0000 Subject: [PATCH] refactor(qualification): blocks need exact time for ordering --- models/lms.model | 2 +- src/Handler/LMS/Fake.hs | 3 +- src/Handler/Utils/Qualification.hs | 106 +++++++++--------- src/Handler/Utils/Table/Cells.hs | 25 +++-- src/Jobs/Handler/LMS.hs | 27 ++--- .../Handler/SendNotification/Qualification.hs | 9 +- src/Model/Types/Lms.hs | 8 +- src/Utils.hs | 5 + 8 files changed, 98 insertions(+), 87 deletions(-) diff --git a/models/lms.model b/models/lms.model index 8dc2e1bbe..c8528c2dd 100644 --- a/models/lms.model +++ b/models/lms.model @@ -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 diff --git a/src/Handler/LMS/Fake.hs b/src/Handler/LMS/Fake.hs index e0550e574..cd7392760 100644 --- a/src/Handler/LMS/Fake.hs +++ b/src/Handler/LMS/Fake.hs @@ -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{..} diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index 748a3bc7e..a59ac3bfe 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -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 diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index ebab8107a..88abb91b7 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -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 diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 2373c27f6..a633c983a 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -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|] diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index 241af0bc3..1f0435857 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -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 diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index de2b62853..8d7d3a804 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -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) diff --git a/src/Utils.hs b/src/Utils.hs index be7a78eef..9357d32cd 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -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