diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index b46db0796..748a3bc7e 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -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 \ No newline at end of file + +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 diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 9aaff6533..2373c27f6 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -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