From d377d717d2f374a19f8ed837b8bb84b308eb3b60 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 24 May 2023 16:25:34 +0000 Subject: [PATCH 01/85] refactor(qualification): WIP db migration implemented --- models/lms.model | 16 +++++++++++++++- src/Audit/Types.hs | 4 ++-- src/Handler/Utils/Qualification.hs | 6 ++++++ src/Model.hs | 6 ++++++ src/Model/Migration/Definitions.hs | 18 ++++++++++++++++++ src/Model/Migration/Types.hs | 15 +++++++++++++++ src/Model/Types/Lms.hs | 25 ------------------------- src/Utils/Lens.hs | 2 ++ 8 files changed, 64 insertions(+), 28 deletions(-) diff --git a/models/lms.model b/models/lms.model index 4f841f984..c8329b72f 100644 --- a/models/lms.model +++ b/models/lms.model @@ -60,7 +60,7 @@ QualificationUser validUntil Day -- addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil lastRefresh Day -- lastRefresh > validUntil possible, if Qualification^elearningOnly == False firstHeld Day -- first time the qualification was earned, should never change - blockedDue QualificationBlocked Maybe -- isJust means that the qualification is currently revoked + -- blockedDue QualificationBlocked Maybe -- TODO: refactor own table isJust means that the qualification is currently revoked scheduleRenewal Bool default=true -- if false, no automatic renewal is scheduled and the qualification expires lastNotified UTCTime default=now() -- last notficiation about being invalid -- temporärer Entzug vorsehen -- SAP Schnittstelle muss dann angepasst werden @@ -68,6 +68,13 @@ QualificationUser UniqueQualificationUser qualification user deriving Generic +QualificationUserBlock + qualificationUser QualificationUserId OnDeleteCascade OnUpdateCascade + from Day + until Day Maybe -- if Nothing then the block holds indefinitely + reason Text + deriving Eq Ord Read Show Generic + -- LMS Interface Tables, need regular processing by background jobs, per QualificationId: -- -- 1. Daily Job: Add to LmsUser daily all qualification holders with @@ -119,6 +126,13 @@ LmsUser UniqueLmsQualificationUser qualification user -- each user may be enrolled at most once per course deriving Generic +-- LmsUserStatus +-- lmsUser LmsUserId OnDeleteCascade OnUpdateCascade +-- result LmsStatus -- data LmsStatus = LmsBlocked | LmsExpired | LmsSuccess +-- day Day +-- UniqueLmsUserStatus lmsUser +-- deriving Generic + -- LmsUserlist stores LMS upload for later processing only LmsUserlist qualification QualificationId OnDeleteCascade OnUpdateCascade diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 4ba414ea8..37ba6ee4d 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -211,9 +211,9 @@ data Transaction } | TransactionQualificationUserBlocking { transactionUser :: UserId -- qualification holder that is updated - -- , transactionQualificationUser :: QualificationUserId -- not neccessary due to UniqueQualificationUser + -- , transactionQualificationUser :: QualificationUserId -- not neccessary due to UniqueQualificationUser , transactionQualification :: QualificationId - , transactionQualificationBlock :: Maybe QualificationBlocked -- Nothing indicates unblocking + , transactionQualificationBlock :: QualificationUserBlock } deriving (Eq, Ord, Read, Show, Generic) diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index 4f386659f..ccd08868a 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -17,6 +17,12 @@ import qualified Database.Esqueleto.Utils as E import Handler.Utils.DateTime (toMidnight) +mkQualificationBlocked :: QualificationBlockStandardReason -> Day -> Maybe Day -> QualificationUserBlock +mkQualificationBlocked reason qualificationUserBlockFrom qualificationUserBlockUntil = QualificationUserBlock{..} + where + qualificationUserBlockReason = qualificationBlockedReasonText reason + + isValidQualification :: HasQualificationUser a => Day -> a -> Bool isValidQualification d q = d `inBetween` (q ^. hasQualificationUser . _qualificationUserFirstHeld ,q ^. hasQualificationUser . _qualificationUserValidUntil) diff --git a/src/Model.hs b/src/Model.hs index 67b1ace01..cebdd4056 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -243,3 +243,9 @@ instance IsFileReference MaterialFile where fileReferenceTitleField = MaterialFileTitle fileReferenceContentField = MaterialFileContent fileReferenceModifiedField = MaterialFileModified + +deriveJSON defaultOptions + { tagSingleConstructors = False + , fieldLabelModifier = camelToPathPiece' 2 + , omitNothingFields = True + } ''QualificationUserBlock diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index 146785bea..b43dce36b 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -92,6 +92,7 @@ data ManualMigration | Migration20210208StudyFeaturesRelevanceCachedUUIDs | Migration20210318CrontabSubmissionRatedNotification | Migration20210608SeparateTermActive + | Migration20230524QualificationUserBlock deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) deriving anyclass (Universe, Finite) @@ -854,6 +855,23 @@ customMigrations = mapF $ \case ALTER TABLE "term" DROP COLUMN "active"; |] + Migration20230524QualificationUserBlock -> + unlessM (tableExists "qualification_user_block") $ do + [executeQQ| + CREATE TABLE "qualification_user_block" ("id" SERIAL8 PRIMARY KEY UNIQUE, "qualification_user" bigint NOT NULL, "from" date NOT NULL, "until" date, "reason" character varying NOT NULL) + CONSTRAINT qualification_user_fkey FOREIGN KEY (qualification_user) REFERENCES qualification_user(id) + |] + + let getBlocks = [queryQQ|SELECT "id", "blocked_due" FROM "qualification_user" WHERE "blocked_due" IS NOT NULL|] + migrateBlocks [ fromPersistValue -> Right (quid :: QualificationUserId), fromPersistValue -> Right (Just (Legacy.QualificationBlocked{..} :: Legacy.QualificationBlocked)) ] = + [executeQQ|INSERT INTO "qualification_user_block" ("qualification_user", "from", "reason") VALUES (#{quid}, #{qualificationBlockedDay}, #{qualificationBlockedReason})|] + migrateBlocks _ = return () + in runConduit $ getBlocks .| C.mapM_ migrateBlocks + + [executeQQ| + ALTER TABLE "qualification_user" DROP COLUMN "blocked_due"; + |] + tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool tableExists table = do diff --git a/src/Model/Migration/Types.hs b/src/Model/Migration/Types.hs index 50df4a3ee..bd3da98fe 100644 --- a/src/Model/Migration/Types.hs +++ b/src/Model/Migration/Types.hs @@ -124,3 +124,18 @@ examModeDNF :: ExamModeDNF -> Current.ExamModeDNF examModeDNF (ExamModeDNF PredDNF{..}) = Current.ExamModeDNF . Current.PredDNF $ Set.map (impureNonNull . Set.map toCurrentPredLiteral . toNullable) dnfTerms where toCurrentPredLiteral PLVariable{..} = Current.PLVariable plVar toCurrentPredLiteral PLNegated{..} = Current.PLNegated plVar + + +data QualificationBlocked = QualificationBlocked { qualificationBlockedDay :: Day + , qualificationBlockedReason :: Text + } + deriving (Eq, Ord, Read, Show, Generic, NFData) + +-- makeLenses_ ''QualificationBlocked +-- +deriveJSON defaultOptions + { tagSingleConstructors = False + , fieldLabelModifier = camelToPathPiece' 2 + , omitNothingFields = True + } ''QualificationBlocked +Current.derivePersistFieldJSON ''QualificationBlocked \ No newline at end of file diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index 85483197b..de2b62853 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -86,26 +86,6 @@ instance Csv.ToField LmsStatus where toField (LmsExpired d) = "Expired: " <> Csv.toField d toField (LmsSuccess d) = "Success: " <> Csv.toField d -data QualificationBlocked = QualificationBlocked { qualificationBlockedDay :: Day - , qualificationBlockedReason :: Text - } - deriving (Eq, Ord, Read, Show, Generic, NFData) - -makeLenses_ ''QualificationBlocked - -deriveJSON defaultOptions - { tagSingleConstructors = False - , fieldLabelModifier = camelToPathPiece' 2 - , omitNothingFields = True - } ''QualificationBlocked -derivePersistFieldJSON ''QualificationBlocked - -instance Csv.ToField QualificationBlocked where - toField QualificationBlocked{..} = "Blocked " <> Csv.toField qualificationBlockedDay <> " due to " <> Csv.toField qualificationBlockedReason - --- | ToMessage instance ignores contained timestamp by design --- instance ToMessage QualificationBlocked where -- no longer used --- toMessage QualificationBlocked{..} = qualificationBlockedReason data QualificationBlockStandardReason = QualificationBlockFailedELearning @@ -121,11 +101,6 @@ qualificationBlockedReasonText = let dictionary :: Map.Map QualificationBlockStandardReason Text = Map.fromList [(r, tshow r) | r <- universeF] in (dictionary !) -- cannot fail due to universeF -mkQualificationBlocked :: QualificationBlockStandardReason -> Day -> QualificationBlocked -mkQualificationBlocked reason qualificationBlockedDay = QualificationBlocked{..} - where - qualificationBlockedReason = qualificationBlockedReasonText reason - -- | 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/Lens.hs b/src/Utils/Lens.hs index 2375e3f3c..92e76ee4b 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -122,7 +122,9 @@ makeClassyFor_ ''StudySubTerms makeClassyFor_ ''Qualification makeClassyFor_ ''QualificationUser +makeClassyFor_ ''QualificationUserBlock makeClassyFor_ ''LmsUser +-- makeClassyFor_ ''LmsUserStatus makeClassyFor_ ''LmsUserlist makeClassyFor_ ''LmsResult makeClassyFor_ ''UserAvs From 64ea50ebf6575cafa4363d9c2417e383037b9696 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 26 May 2023 10:44:04 +0000 Subject: [PATCH 02/85] chore(qualification): WIP add comments for further development --- models/lms.model | 7 +++++-- src/Handler/Qualification.hs | 2 ++ 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/models/lms.model b/models/lms.model index c8329b72f..8dc2e1bbe 100644 --- a/models/lms.model +++ b/models/lms.model @@ -70,9 +70,12 @@ QualificationUser QualificationUserBlock qualificationUser QualificationUserId OnDeleteCascade OnUpdateCascade + unblock Bool from Day - until Day Maybe -- if Nothing then the block holds indefinitely - reason Text + -- until Day Maybe -- if Nothing then the block holds indefinitely + reason Text + -- company -- to be encoded in reason + blocker UserId Maybe deriving Eq Ord Read Show Generic -- LMS Interface Tables, need regular processing by background jobs, per QualificationId: diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index a1863add9..9ce89fc8e 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -270,6 +270,8 @@ data QualificationTableActionData | QualificationActUnexpireData | QualificationActBlockSupervisorData | QualificationActBlockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool } + -- idea: implement some standard answers in addition to a free form answer + | QualificationActBlockData { qualTableActBlockStandard :: QualificationBlockStandardReason, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool } | QualificationActUnblockData | QualificationActRenewData | QualificationActGrantData { qualTableActGrantUntil :: Day } From a0295c76549b9a235a5f41d395721ecfe215cf20 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 13 Jun 2023 16:43:44 +0000 Subject: [PATCH 03/85] refactor(qualification): work on blocking WIP --- src/Database/Esqueleto/Utils.hs | 2 +- src/Handler/LMS.hs | 9 ++++--- src/Handler/Utils/Qualification.hs | 36 +++++++++++++++++++------ src/Handler/Utils/Users.hs | 43 +++++++++++++----------------- 4 files changed, 54 insertions(+), 36 deletions(-) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 7064697e4..78cf1ab1d 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -468,7 +468,7 @@ max, min :: PersistField a max a b = bool a b $ b E.>. a min a b = bool a b $ b E.<. a --- these alternatives for max/min ought to be more efficient; note that NULL is avoided by greatest/least +-- these alternatives for max/min ought to be more efficient; note that NULL is avoided by PostgreSQL greatest/least greatest :: PersistField a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) greatest a b = E.unsafeSqlFunction "GREATEST" $ E.toArgList (a,b) diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index a96c3a839..b7638b482 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -651,7 +651,10 @@ postLmsR sid qsh = do (LmsActRestartData{..}, selectedUsers) -> do let usersList = Set.toList selectedUsers delUsers <- runDB $ do - when (lmsActRestartUnblock == Just True) $ do + when (lmsActRestartUnblock == Just True && ) $ do + authBy <- maybeAuthId + TODO + let unblock = toMaybe (lmsActRestartUnblock == Just True) (nowaday, "Manueller LMS Neustart", authBy) unblockUsers <- view (_entityVal . _qualificationUserUser) <<$>> selectList [ QualificationUserQualification ==. qid , QualificationUserUser <-. usersList @@ -666,8 +669,8 @@ postLmsR sid qsh = do , QualificationUserUser <-. usersList , QualificationUserBlockedDue ==. Nothing , QualificationUserValidUntil <. cutoff - ] [] - forM_ shortUsers $ upsertQualificationUser qid nowaday cutoff Nothing + ] [] + forM_ shortUsers $ upsertQualificationUser qid nowaday cutoff Nothing Nothing fromIntegral <$> deleteWhereCount [LmsUserQualification ==. qid, LmsUserUser <-. usersList] diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index ccd08868a..bffbad258 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -62,12 +62,11 @@ selectValidQualifications qid mbUids nowaday = ------------------------ -upsertQualificationUser :: QualificationId -> Day -> Day -> Maybe Bool -> UserId -> DB () -upsertQualificationUser qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal qualificationUserUser = do +upsertQualificationUser :: QualificationId -> Day -> Day -> Maybe Bool -> Maybe (Day, Text, Maybe UserId) -> UserId -> DB () -- may also unblock +upsertQualificationUser qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal mbUnblockBecause qualificationUserUser = do Entity quid _ <- upsert QualificationUser - { qualificationUserFirstHeld = qualificationUserLastRefresh - , qualificationUserBlockedDue = Nothing + { qualificationUserFirstHeld = qualificationUserLastRefresh , qualificationUserScheduleRenewal = fromMaybe True mbScheduleRenewal , qualificationUserLastNotified = toMidnight qualificationUserLastRefresh , .. @@ -76,10 +75,15 @@ upsertQualificationUser qualificationUserQualification qualificationUserLastRef [ QualificationUserScheduleRenewal =. scheduleRenewal | Just scheduleRenewal <- [mbScheduleRenewal] ] ++ [ QualificationUserValidUntil =. qualificationUserValidUntil - , QualificationUserLastRefresh =. qualificationUserLastRefresh - , QualificationUserBlockedDue =. Nothing + , QualificationUserLastRefresh =. qualificationUserLastRefresh ] ) + whenIsJust mbUnblockBecause $ \(qualificationUserBlockFrom, qualificationUserBlockReason, qualificationUserBlockBlocker) -> do + block <- selectFirst [ QualificationUserBlockQualificationUser ==. quid ] [ Desc QualificationUserBlackFrom ] + whenIsJust block $ \qub -> + unless (qub ^. _qualificationUserBlockUnblock) $ + insert QualificationUserBlock{ qualificationUserBlockQualificationUser = quid, qualificationUserBlockUnblock = True, ..} + audit TransactionQualificationUserEdit { transactionQualificationUser = quid , transactionQualification = qualificationUserQualification @@ -131,10 +135,26 @@ qualificationUserBlocking :: , MonadHandler m , MonadCatch m , Num n - ) => QualificationId -> [UserId] -> Bool -> Maybe QualificationBlocked -> ReaderT (YesodPersistBackend (HandlerSite m)) m n + ) => QualificationId -> [UserId] -> Bool -> Text -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n -qualificationUserBlocking qid uids notify qb = do +qualificationUserBlocking qid uids unblock reason notify qb = do + authUsr <- liftHandler maybeAuthId now <- liftIO getCurrentTime + let nowaday = utctDay now + -- TODO: filter by blocked selectList ??? + + E.insertSelect . E.from $ \qualificationUser -> do + E.where_ $ qualificationUser E.^. QualificationUserQualification E.==. E.val qid + E.&&. qualificationUser E.^. QualificationUserUser E.in_ E.valList uid + E.&&. -- TODO: latest entry is just sql for + return $ QualificationUserBlock + E.<# qualificationUser E.^. QualificationUserId + E.<&> E.val unblock + E.<&> E.val nowaday + E.<&> E.val reason + E.<&> E.val authUsr + + oks <- updateWhereCount -- prevents storage of transactionQualificatioUser ( [ QualificationUserBlockedDue !=. Nothing | isNothing qb -- only unblock blocked qualification; allow overwrite for existing blocks ] ++ diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 087a543a7..fb19f07a7 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -815,30 +815,25 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do unless (Set.null qResolvable) $ deleteWhere [ LmsUserUser ==. oldUserId, LmsUserQualification <-. Set.toList qResolvable ] -- delete conflicting and finished LMS, which are still within auditDuration updateWhere [ LmsUserUser ==. oldUserId ] [ LmsUserUser =. newUserId ] updateWhere [ QualificationEditUser ==. oldUserId ] [ QualificationEditUser =. newUserId ] - E.insertSelectWithConflict - UniqueQualificationUser - (E.from $ \qualificationUser -> do - E.where_ $ qualificationUser E.^. QualificationUserUser E.==. E.val oldUserId - return $ QualificationUser - E.<# E.val newUserId - E.<&> (qualificationUser E.^. QualificationUserQualification) - E.<&> (qualificationUser E.^. QualificationUserValidUntil) - E.<&> (qualificationUser E.^. QualificationUserLastRefresh) - E.<&> (qualificationUser E.^. QualificationUserFirstHeld) - E.<&> (qualificationUser E.^. QualificationUserBlockedDue) - E.<&> (qualificationUser E.^. QualificationUserScheduleRenewal) - E.<&> (qualificationUser E.^. QualificationUserLastNotified) - ) - (\current excluded -> - [ QualificationUserValidUntil E.=. combineWith current excluded E.greatest QualificationUserValidUntil - , QualificationUserLastRefresh E.=. combineWith current excluded E.greatest QualificationUserLastRefresh - , QualificationUserFirstHeld E.=. combineWith current excluded E.least QualificationUserFirstHeld - , QualificationUserBlockedDue E.=. combineWith current excluded E.greatest QualificationUserBlockedDue -- Tested: PostgreSQL GREATEST/LEAST ignores NULL values - , QualificationUserScheduleRenewal E.=. combineWith current excluded E.greatest QualificationUserScheduleRenewal - , QualificationUserLastNotified E.=. combineWith current excluded E.greatest QualificationUserLastNotified - ] - ) - deleteWhere [ QualificationUserUser ==. oldUserId ] + usrQualis <- E.select $ E.from $ \(oldQual `E.LeftOuterJoin` newQual) -> do + E.on ( newQual E.?. QualificationUserQualification E.?=. oldQual E.^. QualificationUserQualification + E.&&. newQual E.?. QualificationUserUser E.?=. E.val newUserId + ) + E.where_ $ oldQual E.^. QualificationUserUser E.==. E.val oldUserId + return (oldQual, newQual) + forM_ usrQualis $ \case + (Entity oldQKey _, Nothing) -> update oldQKey [ QualificationUserUser =. newUserId ] -- update must succeed if there is not RHS in the join + (Entity oldQKey oldQUsr, Just (Entity newQKey newQUsr)) -> do + updateWhere [ QualificationUserBlockQualificationUser ==. oldQKey ] [ QualificationUserBlockQualificationUser =. newQKey ] + update newQKey + [ QualificationUserValidUntil =. (max `on` view _qualificationUserValidUntil ) oldQUsr newQUsr + , QualificationUserLastRefresh =. (max `on` view _qualificationUserLastRefresh ) oldQUsr newQUsr + , QualificationUserFirstHeld =. (min `on` view _qualificationUserFirstHeld ) oldQUsr newQUsr + , QualificationUserScheduleRenewal =. (max `on` view _qualificationUserScheduleRenewal) oldQUsr newQUsr + , QualificationUserLastNotified =. (max `on` view _qualificationUserLastNotified ) oldQUsr newQUsr + ] + delete oldQKey + -- deleteWhere [ QualificationUserUser ==. oldUserId ] -- no longer needed -- Supervision is fully merged E.insertSelectWithConflict From 43dbe18110727b600613a7c83ebf2ae3fdd2ad49 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 16 Jun 2023 14:07:02 +0000 Subject: [PATCH 04/85] refactor(qualifications): idea how to work with blocks as a table (WIP) --- src/Handler/LMS.hs | 4 +-- src/Handler/Qualification.hs | 42 +++++++++++++++++++++++++----- src/Handler/Utils/Qualification.hs | 19 +++++++++++++- 3 files changed, 55 insertions(+), 10 deletions(-) diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index b7638b482..b08c16cce 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -355,8 +355,8 @@ lmsTableQuery :: QualificationId -> LmsTableExpr lmsTableQuery qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser) = do -- RECALL: another outer join on PrintJob did not work out well, since -- - E.distinctOn [E.don $ printJob E.?. PrintJobLmsUser] $ do -- types, but destroys the ability to sort interactively, since distinctOn requires sorting; - -- - using noExsists on printJob join condition works, but only deliver single value; - -- experiments with separate sub-query showed that we would need two subsqueries to learn whether the request was indeed the latest + -- - using notExists on printJob join condition works, but only deliver single value, aggregation can deliver all; + -- experiments with separate sub-query showed that we would need two subqueries to learn whether the request was indeed the latest E.on $ user E.^. UserId E.==. lmsUser E.^. LmsUserUser E.&&. E.val qid E.==. lmsUser E.^. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 9ce89fc8e..9f76a6c1e 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -27,6 +27,7 @@ import qualified Data.Text as T import qualified Data.CaseInsensitive as CI import qualified Data.Conduit.List as C import Database.Persist.Sql (updateWhereCount) +import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Legacy as E -- import qualified Database.Esqueleto.PostgreSQL as E @@ -209,19 +210,22 @@ instance CsvColumnsExplained QualificationTableCsv where type QualificationTableExpr = ( E.SqlExpr (Entity QualificationUser) `E.InnerJoin` E.SqlExpr (Entity User) - ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) + ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock)) queryQualUser :: QualificationTableExpr -> E.SqlExpr (Entity QualificationUser) -queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1) +queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) queryUser :: QualificationTableExpr -> E.SqlExpr (Entity User) -queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 2 1) +queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) queryLmsUser :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity LmsUser)) -queryLmsUser = $(sqlLOJproj 2 2) +queryLmsUser = $(sqlLOJproj 3 2) +queryQualBlock :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock)) +queryQualBlock = $(sqlLOJproj 3 3) -type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), [Entity UserCompany]) +type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), [Entity UserCompany], Maybe (Entity LmsUser)) resultQualUser :: Lens' QualificationTableData (Entity QualificationUser) resultQualUser = _dbrOutput . _1 @@ -235,6 +239,9 @@ resultLmsUser = _dbrOutput . _3 . _Just resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany] resultCompanyUser = _dbrOutput . _4 +resultQualBlock :: Traversal' QualificationTableData (Entity QualificationUserBlock) +resultQualBlock = _dbrOutput . _5 . _Just + instance HasEntity QualificationTableData User where hasEntity = resultUser @@ -293,16 +300,37 @@ blockActRemoveSupervisors QualificationActBlockSupervisorData = True blockActRemoveSupervisors QualificationActBlockData{qualTableActRemoveSupervisors=res} = res blockActRemoveSupervisors _ = False +-- qualificationTableQuery :: QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr +-- -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) +-- , E.SqlExpr (Entity User) +-- , E.SqlExpr (Maybe (Entity LmsUser)) +-- ) +-- qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUse) = do +-- E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser +-- E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work +-- E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser +-- E.where_ $ fltr qualUser E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) +-- return (qualUser, user, lmsUser) + qualificationTableQuery :: QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) , E.SqlExpr (Entity User) , E.SqlExpr (Maybe (Entity LmsUser)) + , E.SqlExpr (Maybe (Entity QualificationUserBlock)) ) -qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) = do +qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do + -- E.distinctOnOrderBy will not work: sorting with dbTable should work, except that columns contained in distinctOnOrderBy cannot be sorted inversely by user; but PostgreSQL leftJoin with distinct filters too many results, see SQL Example lead/lag under jost/misc DevOps + -- + E.on $ qualUser E.^. QualificationUserId E.=?. qualBlock E.?. QualificationUserBlockQualificationUser E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser - E.where_ $ fltr qualUser E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) + E.where_ $ fltr qualUser + E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) + E.&&. E.notExists (E.from $ \earlierBlock -> + E.where_ $ earlierBlock E.^. QualificationUserBlockId E.!=. qualBlock E.^. QualificationUserBlockId + E.&&. earlierBlock E.^. QualificationUserBlockFrom E.>. qualBlock E.^. QualificationUserBlockFrom + ) return (qualUser, user, lmsUser) diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index bffbad258..af3b1fd75 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -33,11 +33,28 @@ isValidQualification d q = d `inBetween` (q ^. hasQualificationUser . _qualifica ------------------ -- TODO: consider replacing `nowaday` by `Database.Esqueleto.PostgreSQL.now_` or better `day(now_)` cast as date +-- 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.&&. E.isNothing (qualUser E.^. QualificationUserBlockedDue) -- not blocked + + 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.&&. E.isNothing (qualUser E.^. QualificationUserBlockedDue) -- not blocked + E.&&. (E.notExists $ E.from $ \qualUserBlock -> do + E.where_ $ E.not (qualUserBlock E.^. QualificationUserBlockUnblock) + E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.<=. E.val nowaday + E.&&. qualUserBlock E.^. QualificationUserBlockQualificationUser E.==. qualUser E.^. QualificationUserId + E.&&. E.notExists $ E.from $ \qualUserUnblock -> do + E.where_ (qualUserUnblock E.^. QualificationUserBlockUnblock) + E.&&. qualUserUnblock E.^. QualificationUserBlockFrom E.<=. E.val nowaday + E.&&. qualUserUnblock E.^. QualificationUserBlockFrom E.>=. qualUserBlock E.^. QualificationUserBlockFrom + E.&&. qualUserUnBlock E.^. QualificationUserBlockQualificationUser E.==. qualUser E.^. QualificationUserId + ) + validQualification' :: Day -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool) validQualification' nowaday qualUser = From f22252ecc3adec761a0fb6f45f35d3dfa044ab9c Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 22 Jun 2023 16:10:06 +0000 Subject: [PATCH 05/85] refactor(qualifications): update basic qualification blocking routines (WIP) --- src/Database/Esqueleto/Utils.hs | 2 +- src/Handler/Utils/Qualification.hs | 204 +++++++++++++++-------------- src/Jobs/Handler/LMS.hs | 2 +- 3 files changed, 111 insertions(+), 97 deletions(-) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 78cf1ab1d..a0c5cb6f5 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index af3b1fd75..d569a1d5c 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -1,7 +1,8 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later +{-# LANGUAGE TypeApplications #-} module Handler.Utils.Qualification ( module Handler.Utils.Qualification @@ -10,58 +11,66 @@ module Handler.Utils.Qualification import Import -- import Data.Time.Calendar (CalendarDiffDays(..)) -import Database.Persist.Sql (updateWhereCount) +-- import Database.Persist.Sql (updateWhereCount) import qualified Database.Esqueleto.Experimental as E -- might need TypeApplications Lang-Pragma import qualified Database.Esqueleto.Utils as E import Handler.Utils.DateTime (toMidnight) +-- needs refactoring, probbably no longer helpful +mkQualificationBlocked :: QualificationBlockStandardReason -> Day -> QualificationUserId -> QualificationUserBlock +mkQualificationBlocked reason qualificationUserBlockFrom qualificationUserBlockQualificationUser = QualificationUserBlock{..} + where + qualificationUserBlockReason = qualificationBlockedReasonText reason + qualificationUserBlockUnblock = False + qualificationUserBlockBlocker = Nothing -mkQualificationBlocked :: QualificationBlockStandardReason -> Day -> Maybe Day -> QualificationUserBlock -mkQualificationBlocked reason qualificationUserBlockFrom qualificationUserBlockUntil = QualificationUserBlock{..} - where - qualificationUserBlockReason = qualificationBlockedReasonText reason - - -isValidQualification :: HasQualificationUser a => Day -> a -> Bool -isValidQualification d q = d `inBetween` (q ^. hasQualificationUser . _qualificationUserFirstHeld - ,q ^. hasQualificationUser . _qualificationUserValidUntil) - && isNothing (q ^. hasQualificationUser . _qualificationUserBlockedDue) +-- No longer possible, needs all QualificationUserBlocks to decide! Easy to work without +-- isValidQualification :: HasQualificationUser a => Day -> a -> Bool +-- isValidQualification d q = d `inBetween` (q ^. hasQualificationUser . _qualificationUserFirstHeld +-- ,q ^. hasQualificationUser . _qualificationUserValidUntil) +-- && isNothing (q ^. hasQualificationUser . _qualificationUserBlockedDue) ------------------ -- SQL Snippets -- ------------------ -- TODO: consider replacing `nowaday` by `Database.Esqueleto.PostgreSQL.now_` or better `day(now_)` cast as date --- 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.&&. E.isNothing (qualUser E.^. QualificationUserBlockedDue) -- not blocked +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 + qualUserBlock <- E.from $ E.table @QualificationUserBlock + E.where_ $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock) + E.&&. (qualUserBlock E.^. QualificationUserBlockFrom E.<=. E.val nowaday) + 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.>. qualUserBlock E.^. QualificationUserBlockFrom + ) + +-- | 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)) + +-- | 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)) validQualification :: Day -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool) -validQualification nowaday = \qualUser -> +validQualification nowaday qualUser = (E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld ,qualUser E.^. QualificationUserValidUntil)) -- currently valid - E.&&. (E.notExists $ E.from $ \qualUserBlock -> do - E.where_ $ E.not (qualUserBlock E.^. QualificationUserBlockUnblock) - E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.<=. E.val nowaday - E.&&. qualUserBlock E.^. QualificationUserBlockQualificationUser E.==. qualUser E.^. QualificationUserId - E.&&. E.notExists $ E.from $ \qualUserUnblock -> do - E.where_ (qualUserUnblock E.^. QualificationUserBlockUnblock) - E.&&. qualUserUnblock E.^. QualificationUserBlockFrom E.<=. E.val nowaday - E.&&. qualUserUnblock E.^. QualificationUserBlockFrom E.>=. qualUserBlock E.^. QualificationUserBlockFrom - E.&&. qualUserUnBlock E.^. QualificationUserBlockQualificationUser E.==. qualUser E.^. QualificationUserId - ) - + E.&&. quserBlock False nowaday 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.&&. E.isNothing (E.joinV $ qualUser E.?. QualificationUserBlockedDue) -- not blocked - + E.&&. quserBlock' False nowaday qualUser selectValidQualifications :: QualificationId -> Maybe [UserId] -> Day -> DB [Entity QualificationUser] selectValidQualifications qid mbUids nowaday = @@ -80,7 +89,7 @@ selectValidQualifications qid mbUids nowaday = upsertQualificationUser :: QualificationId -> Day -> Day -> Maybe Bool -> Maybe (Day, 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 QualificationUser { qualificationUserFirstHeld = qualificationUserLastRefresh @@ -95,11 +104,13 @@ upsertQualificationUser qualificationUserQualification qualificationUserLastRef , QualificationUserLastRefresh =. qualificationUserLastRefresh ] ) - whenIsJust mbUnblockBecause $ \(qualificationUserBlockFrom, qualificationUserBlockReason, qualificationUserBlockBlocker) -> do - block <- selectFirst [ QualificationUserBlockQualificationUser ==. quid ] [ Desc QualificationUserBlackFrom ] - whenIsJust block $ \qub -> - unless (qub ^. _qualificationUserBlockUnblock) $ - insert QualificationUserBlock{ qualificationUserBlockQualificationUser = quid, qualificationUserBlockUnblock = True, ..} + + _ <- error "TODO: Continue here!" + -- whenIsJust mbUnblockBecause $ \(qualificationUserBlockFrom, qualificationUserBlockReason, qualificationUserBlockBlocker) -> do + -- block <- selectFirst [ QualificationUserBlockQualificationUser ==. quid ] [ Desc QualificationUserBlockFrom ] + -- whenIsJust block $ \qub -> + -- unless (qub ^. _qualificationUserBlockUnblock) $ -- TODO does not work like this anymore + -- insert_ QualificationUserBlock{ qualificationUserBlockQualificationUser = quid, qualificationUserBlockUnblock = True, ..} audit TransactionQualificationUserEdit { transactionQualificationUser = quid @@ -154,72 +165,75 @@ qualificationUserBlocking :: , Num n ) => QualificationId -> [UserId] -> Bool -> Text -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n -qualificationUserBlocking qid uids unblock reason notify qb = do +qualificationUserBlocking qid uids unblock reason notify = do authUsr <- liftHandler maybeAuthId now <- liftIO getCurrentTime let nowaday = utctDay now - -- TODO: filter by blocked selectList ??? + -- -- Code would work, but problematic + -- oks <- E.insertSelectCount . E.from $ \qualificationUser -> do + -- E.where_ $ qualificationUser E.^. QualificationUserQualification E.==. E.val qid + -- E.&&. qualificationUser E.^. QualificationUserUser E.in_ E.valList uid + -- E.&&. quserBlock (not unblock) nowaday qualificationUser -- only unblock blocked qualification and vice versa + -- return $ QualificationUserBlock + -- E.<# qualificationUser E.^. QualificationUserId + -- E.<&> E.val unblock + -- E.<&> E.val nowaday + -- E.<&> E.val reason + -- E.<&> E.val authUsr + toChange' <- E.select $ 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 + return (qualUser E.^. QualificationUserId, qualUser E.^. QualificationUserUser) + let toChange = E.unValue . fst <$> toChange' + E.insertMany_ $ map (\quid -> QualificationUserBlock + { qualificationUserBlockQualificationUser = quid + , qualificationUserBlockUnblock = unblock + , qualificationUserBlockFrom = nowaday + , qualificationUserBlockReason = reason + , qualificationUserBlockBlocker = authUsr + }) toChange - E.insertSelect . E.from $ \qualificationUser -> do - E.where_ $ qualificationUser E.^. QualificationUserQualification E.==. E.val qid - E.&&. qualificationUser E.^. QualificationUserUser E.in_ E.valList uid - E.&&. -- TODO: latest entry is just sql for - return $ QualificationUserBlock - E.<# qualificationUser E.^. QualificationUserId - E.<&> E.val unblock - E.<&> E.val nowaday - E.<&> E.val reason - E.<&> E.val authUsr + unless notify $ updateWhere [QualificationUserId <-. toChange] [QualificationUserLastNotified =. now] - - oks <- updateWhereCount -- prevents storage of transactionQualificatioUser - ( [ QualificationUserBlockedDue !=. Nothing | isNothing qb -- only unblock blocked qualification; allow overwrite for existing blocks - ] ++ - [ QualificationUserQualification ==. qid - , QualificationUserUser <-. uids - ] - ) - (guardMonoid (not notify) - [ QualificationUserLastNotified =. now - ] ++ - [ QualificationUserBlockedDue =. qb - ]) - forM_ uids $ \uid -> do + forM_ toChange' $ \(_, E.Value uid) -> do audit TransactionQualificationUserBlocking { -- transactionQualificationUser = quid transactionQualification = qid , transactionUser = uid - , transactionQualificationBlock = qb + , transactionQualificationBlock = error "TODO" -- CONTINUE HERE } - return $ fromIntegral oks + return $ fromIntegral $ length toChange -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 +-- 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 diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 1795167c0..f366630ec 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later From d5c345ef69e1ccb61fc409dca378a679fa41ccc6 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 23 Jun 2023 09:14:53 +0000 Subject: [PATCH 06/85] refactor(qualifications): working on lms background jobs (WIP) --- src/Handler/Utils/Qualification.hs | 18 +++++++------ src/Handler/Utils/Table/Cells.hs | 6 ++--- src/Jobs/Handler/LMS.hs | 42 ++++++++++++++++++++++-------- 3 files changed, 44 insertions(+), 22 deletions(-) diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index d569a1d5c..b46db0796 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -59,6 +59,9 @@ quserBlock negCond aday qualUser = quserBlockAux negCond aday (E.==. (qualUser E quserBlock' :: Bool -> Day -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool) quserBlock' negCond aday qualUser = quserBlockAux negCond aday (E.=?. (qualUser E.?. QualificationUserId)) +qualificationValid :: E.SqlExpr (Entity QualificationUser) -> Day -> 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 @@ -89,7 +92,7 @@ selectValidQualifications qid mbUids nowaday = upsertQualificationUser :: QualificationId -> Day -> Day -> Maybe Bool -> Maybe (Day, 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 QualificationUser { qualificationUserFirstHeld = qualificationUserLastRefresh @@ -104,13 +107,12 @@ upsertQualificationUser qualificationUserQualification qualificationUserLastRef , QualificationUserLastRefresh =. qualificationUserLastRefresh ] ) - - _ <- error "TODO: Continue here!" - -- whenIsJust mbUnblockBecause $ \(qualificationUserBlockFrom, qualificationUserBlockReason, qualificationUserBlockBlocker) -> do - -- block <- selectFirst [ QualificationUserBlockQualificationUser ==. quid ] [ Desc QualificationUserBlockFrom ] - -- whenIsJust block $ \qub -> - -- unless (qub ^. _qualificationUserBlockUnblock) $ -- TODO does not work like this anymore - -- insert_ QualificationUserBlock{ qualificationUserBlockQualificationUser = quid, qualificationUserBlockUnblock = True, ..} + + whenIsJust mbUnblockBecause $ \(qualificationUserBlockFrom, qualificationUserBlockReason, qualificationUserBlockBlocker) -> do + block <- selectFirst [ QualificationUserBlockQualificationUser ==. quid ] [ Desc QualificationUserBlockFrom ] + whenIsJust block $ \qub -> + unless (qub ^. _entityVal . _qualificationUserBlockUnblock) $ + insert_ QualificationUserBlock{ qualificationUserBlockQualificationUser = quid, qualificationUserBlockUnblock = True, ..} audit TransactionQualificationUserEdit { transactionQualificationUser = quid diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index e8e723bc8..ebab8107a 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -14,7 +14,7 @@ import Handler.Utils.DateTime import Handler.Utils.Widgets import Handler.Utils.Occurrences import Handler.Utils.LMS (lmsUserStatusWidget) -import Handler.Utils.Qualification (isValidQualification) +-- import Handler.Utils.Qualification (isValidQualification) type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with WithHoles ! @@ -326,8 +326,8 @@ qualificationValidUntilCell q = textCell (qsh <> ": ") <> dayCell vtd qsh = q ^. hasQualification . _qualificationShorthand . _CI vtd = q ^. hasQualificationUser . _qualificationUserValidUntil -qualificationValidIconCell :: (IsDBTable m c, HasQualificationUser a) => Day -> a -> DBCell m c -qualificationValidIconCell = (iconBoolCell .) . isValidQualification +-- qualificationValidIconCell :: (IsDBTable m c, HasQualificationUser a) => Day -> a -> DBCell m c +-- qualificationValidIconCell = (iconBoolCell .) . isValidQualification lmsShortCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c lmsShortCell (view hasQualification -> Qualification{..}) = anchorCell link name diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index f366630ec..9aaff6533 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -64,15 +64,14 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act case qualificationRefreshWithin quali of Nothing -> return () -- no automatic scheduling for this qid (Just renewalPeriod) -> do - let now_day = utctDay now - renewalDate = addGregorianDurationClip renewalPeriod now_day + let nowaday = utctDay now + renewalDate = addGregorianDurationClip renewalPeriod nowaday renewalUsers <- E.select $ do quser <- E.from $ E.table @QualificationUser E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid - E.&&. quser E.^. QualificationUserScheduleRenewal - E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val now_day + E.&&. quser E.^. QualificationUserScheduleRenewal E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate - E.&&. E.isNothing (quser E.^. QualificationUserBlockedDue) + E.&&. (quser `qualificationValid` nowaday) E.&&. E.notExists (do luser <- E.from $ E.table @LmsUser E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid @@ -161,12 +160,33 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act notifyInvalidDrivers <- E.select $ do quser <- E.from $ E.table @QualificationUser - E.where_ $ E.not_ (validQualification nowaday quser) - E.&&. (( E.isNothing (quser E.^. QualificationUserBlockedDue) - E.&&. (E.day (quser E.^. QualificationUserLastNotified) E.<. quser E.^. QualificationUserValidUntil) - ) E.||. ( - E.isJust (quser E.^. QualificationUserBlockedDue) - E.&&. (E.day (quser E.^. QualificationUserLastNotified) E.<. E.day' ((quser E.^. QualificationUserBlockedDue) E.->>. "day")) + 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 + ) )) pure (quser E.^. QualificationUserUser) From ff7675542ade0233e0d2998110f4b182be11c3df Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 23 Jun 2023 16:37:08 +0000 Subject: [PATCH 07/85] refactor(qualifications): update basic qualification blocking routines II (WIP) --- src/Handler/Utils/Qualification.hs | 100 ++++++++++++++++++----------- src/Jobs/Handler/LMS.hs | 41 +++--------- 2 files changed, 72 insertions(+), 69 deletions(-) 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 From a28fb720218257a625deb59bf86d163408b7c17f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 26 Jun 2023 10:07:41 +0000 Subject: [PATCH 08/85] 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 From 878f98604cc48eee92f509fddd63e2b887d7a50e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 26 Jun 2023 16:28:17 +0000 Subject: [PATCH 09/85] refactor(qualifications): suggestions for qualification view block acts (WIP) --- .../categories/qualification/de-de-formal.msg | 2 +- .../categories/qualification/en-eu.msg | 2 +- src/Handler/Qualification.hs | 110 ++++++++++-------- src/Handler/Tutorial/Form.hs | 2 +- src/Handler/Utils/Avs.hs | 5 +- src/Handler/Utils/Qualification.hs | 10 +- src/Handler/Utils/Table/Cells.hs | 47 +++++--- src/Jobs/Handler/LMS.hs | 8 +- .../Handler/SendNotification/Qualification.hs | 11 +- src/Utils.hs | 8 +- src/Utils/Lens.hs | 7 +- 11 files changed, 120 insertions(+), 92 deletions(-) diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 77f754e62..b77bd3416 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -24,7 +24,7 @@ TableQualificationLastNotified: Letzte Benachrichtigung TableQualificationFirstHeld: Erstmalig TableQualificationBlockedDue: Entzogen TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend außer Kraft gesetzt und warum wurde dies veranlasst? -TableQualificationBlockedTooltipSimple: Wann wurde die Qualifikation aus besonderem Grund wiederrufen? +TableQualificationBlockedTooltipSimple: Falls die Qualifikation aus besonderem Grund vorzeitig widerrufen wurde, so wird das Datum des Widerrufs angezeigt TableQualificationNoRenewal: Auslaufend TableQualificationNoRenewalTooltip: Es wird keine Benachrichtigung mehr versendet, wenn diese Qualifikation ablaufen sollte. Die Qualifikation kann noch weiterhin gültig sein. QualificationScheduleRenewalTooltip: Wird eine Benachrichtigung versendet, falls diese Qualikation bald ablaufen sollte? diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 57dcf853b..ada108cca 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -24,7 +24,7 @@ TableQualificationLastNotified: Last notified TableQualificationFirstHeld: First held TableQualificationBlockedDue: Revoked TableQualificationBlockedTooltip: Why and when was this qualification temporarily suspended? -TableQualificationBlockedTooltipSimple: When was this qualification revoked due to extraordinary reasons? +TableQualificationBlockedTooltipSimple: If a date is shown, this qualification has been revoked on that date due to extraordinary reasons TableQualificationNoRenewal: Discontinued TableQualificationNoRenewalTooltip: No renewal notifications will be send for this qualification upon expiry. The qualification may still be valid. QualificationScheduleRenewalTooltip: Will there be a notification, if this qualification is about to expire soon? diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 9f76a6c1e..c8a693e13 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -80,7 +80,7 @@ mkQualificationAllTable isAdmin = do Ex.where_ $ filterSvs quser cactive = Ex.subSelectCount $ do quser <- Ex.from $ Ex.table @QualificationUser - Ex.where_ $ filterSvs quser Ex.&&. validQualification (utctDay now) quser + Ex.where_ $ filterSvs quser Ex.&&. validQualification now quser return (quali, cactive, cusers) dbtRowKey = (Ex.^. QualificationId) dbtProj = dbtProjId @@ -152,7 +152,7 @@ data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc.. , qtcCompanyNumbers :: CsvSemicolonList Int , qtcValidUntil :: Day , qtcLastRefresh :: Day - , qtcBlocked :: Maybe Day + , qtcBlocked :: Maybe UTCTime , qtcScheduleRenewal:: Bool , qtcLmsStatusTxt :: Maybe Text , qtcLmsStatusDay :: Maybe Day @@ -225,7 +225,7 @@ queryLmsUser = $(sqlLOJproj 3 2) queryQualBlock :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock)) queryQualBlock = $(sqlLOJproj 3 3) -type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), [Entity UserCompany], Maybe (Entity LmsUser)) +type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), Maybe (Entity QualificationUserBlock), [Entity UserCompany]) resultQualUser :: Lens' QualificationTableData (Entity QualificationUser) resultQualUser = _dbrOutput . _1 @@ -236,11 +236,11 @@ resultUser = _dbrOutput . _2 resultLmsUser :: Traversal' QualificationTableData (Entity LmsUser) resultLmsUser = _dbrOutput . _3 . _Just -resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany] -resultCompanyUser = _dbrOutput . _4 - resultQualBlock :: Traversal' QualificationTableData (Entity QualificationUserBlock) -resultQualBlock = _dbrOutput . _5 . _Just +resultQualBlock = _dbrOutput . _4 . _Just + +resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany] +resultCompanyUser = _dbrOutput . _5 instance HasEntity QualificationTableData User where @@ -277,12 +277,10 @@ data QualificationTableActionData | QualificationActUnexpireData | QualificationActBlockSupervisorData | QualificationActBlockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool } - -- idea: implement some standard answers in addition to a free form answer - | QualificationActBlockData { qualTableActBlockStandard :: QualificationBlockStandardReason, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool } - | QualificationActUnblockData + | QualificationActUnblockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool} | QualificationActRenewData | QualificationActGrantData { qualTableActGrantUntil :: Day } - deriving (Eq, Ord, Read, Show, Generic) + deriving (Eq, Ord, Show, Generic) isExpiryAct :: QualificationTableActionData -> Bool isExpiryAct QualificationActExpireData = True @@ -292,7 +290,7 @@ isExpiryAct _ = False isBlockAct :: QualificationTableActionData -> Bool isBlockAct QualificationActBlockSupervisorData = True isBlockAct QualificationActBlockData{} = True -isBlockAct QualificationActUnblockData = True +isBlockAct QualificationActUnblockData{} = True isBlockAct _ = False blockActRemoveSupervisors :: QualificationTableActionData -> Bool @@ -328,10 +326,10 @@ qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` E.where_ $ fltr qualUser E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) E.&&. E.notExists (E.from $ \earlierBlock -> - E.where_ $ earlierBlock E.^. QualificationUserBlockId E.!=. qualBlock E.^. QualificationUserBlockId - E.&&. earlierBlock E.^. QualificationUserBlockFrom E.>. qualBlock E.^. QualificationUserBlockFrom + E.where_ $ earlierBlock E.^. QualificationUserBlockQualificationUser E.=?. qualBlock E.?. QualificationUserBlockQualificationUser + E.&&. E.just (earlierBlock E.^. QualificationUserBlockFrom) E.>. qualBlock E.?. QualificationUserBlockFrom ) - return (qualUser, user, lmsUser) + return (qualUser, user, lmsUser, qualBlock) mkQualificationTable :: @@ -360,14 +358,14 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs dbtSQLQuery = qualificationTableQuery qid fltrSvs dbtRowKey = queryUser >>> (E.^. UserId) - dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr) -> do + dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock) -> do -- cmps <- E.select . E.from $ \(usrComp `E.InnerJoin` comp) -> do -- E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId -- E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val (entityKey usr) -- E.orderBy [E.asc (comp E.^. CompanyName)] -- return (comp E.^. CompanyName, comp E.^. CompanyAvsId, usrComp E.^. UserCompanySupervisor) cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany] - return (qualUsr, usr, lmsUsr, cmpUsr) + return (qualUsr, usr, lmsUsr, qUsrBlock, cmpUsr) dbtColonnade = cols cmpMap dbtSorting = mconcat [ single $ sortUserNameLink queryUser @@ -376,7 +374,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) , single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified)) - , single ("blocked-due" , SortColumnNeverNull $ queryQualUser >>> (E.^. QualificationUserBlockedDue)) + , single ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom)) , single ("lms-status-plus",SortColumnNeverNull $ \row -> E.coalesce [E.explicitUnsafeCoerceSqlExprValue "timestamp" $ (queryLmsUser row E.?. LmsUserStatus) E.#>>. "{day}" , queryLmsUser row E.?. LmsUserStarted]) , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) @@ -386,7 +384,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do E.orderBy [E.asc (comp E.^. CompanyName)] return (comp E.^. CompanyName) ) - , single ("validity", SortColumn $ queryQualUser >>> validQualification nowaday) + -- , single ("validity", SortColumn $ queryQualUser >>> validQualification now) ] dbtFilter = mconcat [ single $ fltrUserNameEmail queryUser @@ -415,7 +413,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit ) - , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday)) + , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now)) , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> if | Just renewal <- mbRenewal , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal @@ -452,7 +450,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do <*> (view resultCompanyUser >>= getCompanyNos) <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) - <*> preview (resultQualUser . _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedDay) + <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom) <*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal) <*> getStatusPlusTxt <*> getStatusPlusDay @@ -510,32 +508,53 @@ postQualificationR sid qsh = do now <- liftIO getCurrentTime let nowaday = utctDay now ((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do - qent@Entity{entityVal=Qualification{ - qualificationAuditDuration=auditMonths - , qualificationValidDuration=validMonths + qent@Entity{ + entityKey=qid + , entityVal=Qualification{ + qualificationAuditDuration=auditMonths + , qualificationValidDuration=validMonths }} <- getBy404 $ SchoolQualificationShort sid qsh - let dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> validMonths + let getBlockReasons unblk = Ex.select $ do + (quser :& qblock) <- Ex.from $ Ex.table @QualificationUser + `Ex.innerJoin` Ex.table @QualificationUserBlock + `Ex.on` (\(quser :& qblock) -> quser Ex.^. QualificationUserId Ex.==. qblock Ex.^. QualificationUserBlockQualificationUser) + Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. Ex.val qid + Ex.&&. unblk (qblock Ex.^. QualificationUserBlockUnblock) + Ex.groupBy (qblock Ex.^. QualificationUserBlockReason) + let countRows' :: Ex.SqlExpr (Ex.Value Int64) = Ex.countRows + Ex.orderBy [Ex.desc countRows'] + Ex.limit 7 + pure (qblock Ex.^. QualificationUserBlockReason) + mkOption :: Ex.Value Text -> Option Text + mkOption (Ex.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t } + suggestionsBlock :: HandlerFor UniWorX (OptionList Text) + suggestionsBlock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons Ex.not_) + suggestionsUnblock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons id) + dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> validMonths acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData) acts = mconcat $ [ singletonMap QualificationActExpire $ pure QualificationActExpireData , singletonMap QualificationActUnexpire $ QualificationActUnexpireData <$ aformMessage msgUnexpire ] ++ bool - [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] -- nonAdmin actions, ie. Supervisor - [ singletonMap QualificationActUnblock $ pure QualificationActUnblockData -- Admin-only actions + -- nonAdmin actions, ie. Supervisor + [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] + -- Admin-only actions + [ singletonMap QualificationActUnblock $ QualificationActUnblockData + <$> apreq (textField & cfStrip & addDatalist suggestionsUnblock) (fslI MsgQualificationBlockReason) Nothing + <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) , singletonMap QualificationActBlock $ QualificationActBlockData - <$> apreq textField (fslI MsgQualificationBlockReason) Nothing - <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) - <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockRemoveSupervisor) (Just False) + <$> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationBlockReason) Nothing + <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) + <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockRemoveSupervisor) (Just False) , singletonMap QualificationActRenew $ pure QualificationActRenewData , singletonMap QualificationActGrant $ QualificationActGrantData <$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry <* aformMessage msgGrantWarning ] isAdmin linkLmsUser = toMaybe isAdmin LmsUserR - linkUserName = bool ForProfileR ForProfileDataR isAdmin - blockedDueCell = bool qualificationBlockedCellNoReason qualificationBlockedCell isAdmin + linkUserName = bool ForProfileR ForProfileDataR isAdmin colChoices cmpMap = mconcat [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) , colUserNameModalHdr MsgLmsUser linkUserName @@ -550,11 +569,11 @@ postQualificationR sid qsh = do (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs in wgtCell companies , guardMonoid isAdmin colUserMatriclenr - , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) + -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) (dayCell . view ( resultQualUser . _entityVal . _qualificationUserValidUntil)) , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d - , sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltipSimple - ) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> blockedDueCell b + , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row -> + qualificationValidReasonCell isAdmin nowaday (row ^. resultQualUser) (row ^? resultQualBlock) , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification , sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths)) @@ -571,7 +590,7 @@ postQualificationR sid qsh = do addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks reloadKeepGetParams $ QualificationR sid qsh (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do - runDB . forM_ selectedUsers $ upsertQualificationUser qid nowaday grantValidday Nothing + runDB . forM_ selectedUsers $ upsertQualificationUser qid nowaday grantValidday Nothing Nothing addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers reloadKeepGetParams $ QualificationR sid qsh (action, selectedUsers) | isExpiryAct action -> do @@ -585,29 +604,24 @@ postQualificationR sid qsh = do reloadKeepGetParams $ QualificationR sid qsh (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do let selUserIds = Set.toList selectedUsers - qubr = case action of - QualificationActUnblockData -> Nothing - QualificationActBlockSupervisorData -> Just $ mkQualificationBlocked QualificationBlockReturnedByCompany nowaday - QualificationActBlockData{..} -> Just $ QualificationBlocked - { qualificationBlockedDay = nowaday - , qualificationBlockedReason = qualTableActBlockReason - } - _ -> error "Handle.Qualification.isBlockAct returned non-block action" + (unblock, reason) = case action of + QualificationActBlockSupervisorData -> (False, Right QualificationBlockReturnedByCompany) + QualificationActBlockData{..} -> (False, Left qualTableActBlockReason) + QualificationActUnblockData{..} -> (True , Left qualTableActBlockReason) + _ -> error "Handle.Qualification.isBlockAct returned non-block action" -- cannot occur due to earlier checks notify = case action of QualificationActBlockData{qualTableActNotify} -> qualTableActNotify _ -> False oks <- runDB $ do when (blockActRemoveSupervisors action) $ deleteWhere [UserSupervisorUser <-. selUserIds] - qualificationUserBlocking qid selUserIds notify qubr + qualificationUserBlocking qid selUserIds unblock reason notify let nrq = length selectedUsers warnLevel = if | oks < 0 -> Error | oks == nrq -> Success | otherwise -> Warning - fbmsg = if - | isNothing qubr -> MsgQualificationStatusUnblock - | otherwise -> MsgQualificationStatusBlock + fbmsg = if unblock then MsgQualificationStatusUnblock else MsgQualificationStatusBlock addMessageI warnLevel $ fbmsg qsh oks nrq reloadKeepGetParams $ QualificationR sid qsh _ -> addMessageI Error MsgInvalidFormAction diff --git a/src/Handler/Tutorial/Form.hs b/src/Handler/Tutorial/Form.hs index 22ac01d81..6e4e608dd 100644 --- a/src/Handler/Tutorial/Form.hs +++ b/src/Handler/Tutorial/Form.hs @@ -90,7 +90,7 @@ tutorialForm cid template html = do <*> tutorForm where tutTypeDatalist :: HandlerFor UniWorX (OptionList (CI Text)) - tutTypeDatalist = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . runDB $ + tutTypeDatalist = fmap (mkOptionList . map (\t -> Option (CI.original t) t (toPathPiece $ CI.original t)) . Set.toAscList) . runDB $ fmap (setOf $ folded . _Value) . E.select . E.from $ \tutorial -> do E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid return $ tutorial E.^. TutorialType diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 550f4edd6..03d059561 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -259,8 +259,7 @@ getDifferingLicences (AvsResponseGetLicences licences) = do --let (vorfeld, nonvorfeld) = Set.partition (`avsPersonLicenceIs` AvsLicenceVorfeld) licences -- rollfeld = Set.filter (`avsPersonLicenceIs` AvsLicenceRollfeld) nonvorfeld -- Note: FRADrive users with 'R' also own 'F' qualification, but AvsGetResponseGetLicences yields only either - let nowaday = utctDay now - vorORrollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence) licences + let vorORrollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence) licences rollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsLicenceVorfeld) vorORrollfeld' vorORrollfeld = Set.map avsLicencePersonID vorORrollfeld' rollfeld = Set.map avsLicencePersonID rollfeld' @@ -275,7 +274,7 @@ getDifferingLicences (AvsResponseGetLicences licences) = do (quali E.^. QualificationId E.==. qualUser E.^. QualificationUserQualification) -- NOTE: filters on the innerJoin must be part of ON-condition in order for anti-join to work! E.&&. (quali E.^. QualificationAvsLicence E.==. E.justVal lic) -- correct type of licence - E.&&. (nowaday `validQualification` qualUser) -- currently valid and not blocked + E.&&. (now `validQualification` qualUser) -- currently valid and not blocked ) `E.innerJoin` E.table @UserAvs `E.on` (\(_ :& qualUser :& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser) diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index a59ac3bfe..6c27ba64f 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -25,11 +25,11 @@ mkQualificationBlocked reason qualificationUserBlockFrom qualificationUserBlockQ qualificationUserBlockUnblock = False qualificationUserBlockBlocker = Nothing --- No longer possible, needs all QualificationUserBlocks to decide! Easy to work without --- isValidQualification :: HasQualificationUser a => Day -> a -> Bool --- isValidQualification d q = d `inBetween` (q ^. hasQualificationUser . _qualificationUserFirstHeld --- ,q ^. hasQualificationUser . _qualificationUserValidUntil) --- && isNothing (q ^. hasQualificationUser . _qualificationUserBlockedDue) +-- somewhat dangerous, if not used with latest effective block +isValidQualification :: (HasQualificationUser a, HasQualificationUserBlock b) => Day -> a -> Maybe b -> Bool +isValidQualification d qu qb= d `inBetween` (qu ^. hasQualificationUser . _qualificationUserFirstHeld + ,qu ^. hasQualificationUser . _qualificationUserValidUntil) + && all (^. hasQualificationUserBlock . _qualificationUserBlockUnblock) qb ------------------ -- SQL Snippets -- diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 88abb91b7..879358cf2 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -14,7 +14,7 @@ import Handler.Utils.DateTime import Handler.Utils.Widgets import Handler.Utils.Occurrences import Handler.Utils.LMS (lmsUserStatusWidget) --- import Handler.Utils.Qualification (isValidQualification) +import Handler.Utils.Qualification (isValidQualification) type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with WithHoles ! @@ -151,6 +151,12 @@ csvCell route = anchorCell route iconFileCSV modalCell :: (IsDBTable m a, ToWidget UniWorX w) => w -> DBCell m a modalCell content = cell $ modal (toWidget $ hasComment True) (Right $ toWidget content) +-- | Show Text if it is small, create modal otherwise +modalCellLarge :: (IsDBTable m a, ToWidget UniWorX t, MonoFoldable t, Element t ~ Char) => t -> DBCell m a +modalCellLarge content + | length content > 32 = modalCell content + | otherwise = textCell content + markupCellLargeModal :: IsDBTable m a => StoredMarkup -> DBCell m a markupCellLargeModal mup | markupIsSmallish mup = cell $ toWidget mup @@ -326,8 +332,29 @@ qualificationValidUntilCell q = textCell (qsh <> ": ") <> dayCell vtd qsh = q ^. hasQualification . _qualificationShorthand . _CI vtd = q ^. hasQualificationUser . _qualificationUserValidUntil --- qualificationValidIconCell :: (IsDBTable m c, HasQualificationUser a) => Day -> a -> DBCell m c --- qualificationValidIconCell = (iconBoolCell .) . isValidQualification +qualificationValidIconCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Day -> a -> Maybe b -> DBCell m c +qualificationValidIconCell d qu qb = iconBoolCell $ isValidQualification d qu qb + +qualificationValidReasonCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Bool -> Day -> a -> Maybe b -> DBCell m c +qualificationValidReasonCell showReason d qu qb = ic <> foldMap blc qb + where + ic = iconBoolCell $ isValidQualification d qu qb + blc (view hasQualificationUserBlock -> QualificationUserBlock{..}) + | showReason = spacerCell <> dateCell qualificationUserBlockFrom <> spacerCell <> modalCellLarge qualificationUserBlockReason + -- TODO: add anchorLink to block history, if user is allowed + | qualificationUserBlockUnblock = mempty + | otherwise = spacerCell <> dateCell qualificationUserBlockFrom + +-- qualificationBlockedCellNoReason :: IsDBTable m a => QualificationUserBlock -> DBCell m a +-- qualificationBlockedCellNoReason QualificationUserBlock{qualificationUserBlockFrom=t, qualificationUserBlockUnblock=unblock} = +-- iconBoolCell unblock <> spacerCell <> dateCell d + +-- qualificationBlockedCell :: IsDBTable m a => QualificationUserBlock -> DBCell m a +-- qualificationBlockedCell QualificationUserBlock{..} +-- | 32 >= length qualificationUserBlockReason = mkCellWith textCell +-- | otherwise = mkCellWith modalCell +-- where +-- mkCellWith c = c qualificationUserBlockReason <> spacerCell <> iconCell IconBlocked <> spacerCell <> dayCell qualificationUserBlockFrom lmsShortCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c lmsShortCell (view hasQualification -> Qualification{..}) = anchorCell link name @@ -376,20 +403,6 @@ lmsStatusCell extendedInfo (Just toLink) lu = cell $ do uuid <- liftHandler $ encrypt $ lu ^. _lmsUserUser modal (lmsUserStatusWidget extendedInfo lu) (Left $ SomeRoute $ toLink uuid) --- 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 a633c983a..0a701784e 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -71,7 +71,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid E.&&. quser E.^. QualificationUserScheduleRenewal E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate - E.&&. (quser `qualificationValid` nowaday) + E.&&. (quser `qualificationValid` now) E.&&. E.notExists (do luser <- E.from $ E.table @LmsUser E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid @@ -151,7 +151,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act E.&&. luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification) E.where_ $ E.isNothing (luser E.^. LmsUserStatus) E.&&. E.isNothing (luser E.^. LmsUserEnded) - E.&&. E.not_ (validQualification nowaday quser) + E.&&. E.not_ (validQualification now quser) pure (luser E.^. LmsUserId) nrExpired <- E.updateCount $ \luser -> do E.set luser [LmsUserStatus E.=. E.justVal (LmsExpired nowaday)] @@ -160,9 +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.where_ $ E.not_ (quser `qualificationValid` now) -- currently invalid E.&&. quser E.^. QualificationUserQualification E.==. E.val qid -- correct qualification - E.&&. quser `quserToNotify` nowaday -- recently became invalid or blocked + E.&&. quser `quserToNotify` now -- recently became invalid or blocked pure (quser E.^. QualificationUserUser) forM_ notifyInvalidDrivers $ \(E.Value uid) -> diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index 1f0435857..22dadc99d 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -54,10 +54,10 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do 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 + qub_entry <- entityVal <<$>> runDB (selectRelevantBlock now quId) + let block = filterMaybe (not . qualificationUserBlockUnblock) qub_entry urender <- getUrlRender - let expDay = maybe qualificationUserValidUntil (min qualificationUserValidUntil . qualificationUserBlockFrom) block + let expDay = maybe qualificationUserValidUntil (min qualificationUserValidUntil . utctDay . qualificationUserBlockFrom) block qname = CI.original qualificationName qshort = CI.original qualificationShorthand letter = LetterExpireQualificationF @@ -76,8 +76,7 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do then do notifyOk <- sendEmailOrLetter jRecipient letter if notifyOk - then do - now <- liftIO getCurrentTime + then do runDB $ update quId [QualificationUserLastNotified =. now] $logInfoS "LMS" $ "Notified " <> tshow encRecipient <> " about expired qualification " <> qname else diff --git a/src/Utils.hs b/src/Utils.hs index 9357d32cd..9b3390c5c 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -870,10 +870,10 @@ 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 +-- 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 () diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 92e76ee4b..9c3791c30 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -162,8 +162,11 @@ instance HasQualification a => HasQualification (a,b) where instance HasQualificationUser a => HasQualificationUser (Entity a) where hasQualificationUser = _entityVal . hasQualificationUser -instance HasQualificationUser a => HasQualificationUser (b,a) where - hasQualificationUser = _2 . hasQualificationUser +-- instance HasQualificationUser a => HasQualificationUser (b,a) where +-- hasQualificationUser = _2 . hasQualificationUser + +instance HasQualificationUserBlock a => HasQualificationUserBlock (Entity a) where + hasQualificationUser = _entityVal . hasQualificationUserBlock instance HasLmsUser a => HasLmsUser (Entity a) where hasLmsUser = _entityVal . hasLmsUser From 9abf8b69bf3149cce6eac6a01fba95801b3bc9ee Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 27 Jun 2023 15:15:32 +0000 Subject: [PATCH 10/85] refactor(qualification): rework lms view and user lms modal --- .../categories/qualification/de-de-formal.msg | 3 + .../categories/qualification/en-eu.msg | 3 + src/Handler/LMS.hs | 150 ++++++++++-------- src/Handler/Qualification.hs | 34 ++-- src/Handler/Utils/Qualification.hs | 32 ++-- src/Handler/Utils/Table/Cells.hs | 19 +-- src/Utils.hs | 9 +- src/Utils/Icon.hs | 6 + src/Utils/Lens.hs | 2 +- templates/lms-user.hamlet | 31 +++- 10 files changed, 173 insertions(+), 116 deletions(-) diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index b77bd3416..39f4286d6 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -25,6 +25,8 @@ TableQualificationFirstHeld: Erstmalig TableQualificationBlockedDue: Entzogen TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend außer Kraft gesetzt und warum wurde dies veranlasst? TableQualificationBlockedTooltipSimple: Falls die Qualifikation aus besonderem Grund vorzeitig widerrufen wurde, so wird das Datum des Widerrufs angezeigt +InfoQualificationBlockStatus: Besteht aktuell ein Entzug? Falsch bedeutet, dass ein Entzug zuletzt aufgehoben wurde +InfoQualificationBlockFrom: Datum der letzten Änderungen eines Entzugs oder der Aufhebung eines Entzugs TableQualificationNoRenewal: Auslaufend TableQualificationNoRenewalTooltip: Es wird keine Benachrichtigung mehr versendet, wenn diese Qualifikation ablaufen sollte. Die Qualifikation kann noch weiterhin gültig sein. QualificationScheduleRenewalTooltip: Wird eine Benachrichtigung versendet, falls diese Qualikation bald ablaufen sollte? @@ -96,6 +98,7 @@ QualificationActGrant: Qualifikation vergeben QualificationActGrantWarning: Diese Funktion ist nur für seltene Ausnahmefälle vorgesehen! Ein Entzug wird ggf. aufgehoben. QualificationStatusBlock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} entzogen QualificationStatusUnblock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} reaktiviert +LmsInactive: Aktuell kein E‑Learning aktiv LmsRenewalInstructions: Weitere Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF mit dem im FRADrive hinterlegten PDF-Passwort des Prüflings verschlüsselt. Falls kein PDF-Passwort manuell hinterlegt wurde, ist das PDF-Passwort die Flughafen Ausweisnummer, inklusive Punkt und der Ziffer danach. LmsNoRenewal: Leider kann diese Qualifikation nicht alleine durch E‑Learning verlängert werden. LmsActNotify: Benachrichtigung E‑Learning erneut per Post oder E-Mail versenden diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index ada108cca..587f18d11 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -26,6 +26,8 @@ TableQualificationBlockedDue: Revoked TableQualificationBlockedTooltip: Why and when was this qualification temporarily suspended? TableQualificationBlockedTooltipSimple: If a date is shown, this qualification has been revoked on that date due to extraordinary reasons TableQualificationNoRenewal: Discontinued +InfoQualificationBlockStatus: Is the qualification currently revoked? False indicates, that a revocation had been lifted +InfoQualificationBlockFrom: Date of last revocation or lifting of a revocation TableQualificationNoRenewalTooltip: No renewal notifications will be send for this qualification upon expiry. The qualification may still be valid. QualificationScheduleRenewalTooltip: Will there be a notification, if this qualification is about to expire soon? QualificationUserNoRenewal: Expires without further notification @@ -96,6 +98,7 @@ QualificationActGrant: Grant qualification QualificationActGrantWarning: Use with caution in rare exceptional cases only! Any revocation will be undone. QualificationStatusBlock l n m: #{n}/#{m} #{l} revoked QualificationStatusUnblock l n m: #{n}/#{m} #{l} reactivated +LmsInactive: Currently no active e‑learning LmsRenewalInstructions: Instruction on how to accomplish the renewal are enclosed in the attached PDF. In order to avoid misuse, the PDF is encrypted with the FRADrive PDF-password of the examinee. If no PDF-password had been chosen yet, then the password is the Fraport id card number of the examinee, including the punctuation mark and the digit thereafter. LmsNoRenewal: Unfortunately, this particular qualification cannot be renewed through E-learning only. LmsActNotify: Resend e‑learning notification by post or email diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index b08c16cce..e6513ccd4 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -207,11 +207,12 @@ data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc.. , ltcValidUntil :: Day , ltcLastRefresh :: Day , ltcFirstHeld :: Day - , ltcBlockedDue :: Maybe QualificationBlocked - , ltcLmsIdent :: Maybe LmsIdent + , ltcBlockStatus :: Maybe Bool + , ltcBlockFrom :: Maybe UTCTime + , ltcLmsIdent :: LmsIdent , ltcLmsStatus :: Maybe LmsStatus - , ltcLmsStarted :: Maybe UTCTime - , ltcLmsDatePin :: Maybe UTCTime + , ltcLmsStarted :: UTCTime + , ltcLmsDatePin :: UTCTime , ltcLmsReceived :: Maybe UTCTime , ltcLmsNotified :: Maybe UTCTime , ltcLmsEnded :: Maybe UTCTime @@ -228,11 +229,12 @@ ltcExample = LmsTableCsv , ltcValidUntil = compDay , ltcLastRefresh = compDay , ltcFirstHeld = compDay - , ltcBlockedDue = Nothing - , ltcLmsIdent = Nothing + , ltcBlockStatus = Nothing + , ltcBlockFrom = Nothing + , ltcLmsIdent = LmsIdent "abcdefgh" , ltcLmsStatus = Nothing - , ltcLmsStarted = Just compTime - , ltcLmsDatePin = Nothing + , ltcLmsStarted = compTime + , ltcLmsDatePin = compTime , ltcLmsReceived = Nothing , ltcLmsNotified = Nothing , ltcLmsEnded = Nothing @@ -269,6 +271,8 @@ instance CsvColumnsExplained LmsTableCsv where , ('ltcValidUntil , SomeMessage MsgLmsQualificationValidUntil) , ('ltcLastRefresh , SomeMessage MsgTableQualificationLastRefresh) , ('ltcFirstHeld , SomeMessage MsgTableQualificationFirstHeld) + , ('ltcBlockStatus , SomeMessage MsgInfoQualificationBlockStatus) + , ('ltcBlockFrom , SomeMessage MsgInfoQualificationBlockFrom) , ('ltcLmsIdent , SomeMessage MsgTableLmsIdent) , ('ltcLmsStatus , SomeMessage MsgTableLmsStatus) , ('ltcLmsStarted , SomeMessage MsgTableLmsStarted) @@ -278,21 +282,25 @@ instance CsvColumnsExplained LmsTableCsv where ] -type LmsTableExpr = E.SqlExpr (Entity QualificationUser) - `E.InnerJoin` E.SqlExpr (Entity User) - `E.InnerJoin` E.SqlExpr (Entity LmsUser) +type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser) + `E.InnerJoin` E.SqlExpr (Entity User) + `E.InnerJoin` E.SqlExpr (Entity LmsUser) + ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock)) queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser) -queryQualUser = $(sqlIJproj 3 1) +queryQualUser = $(sqlIJproj 3 1) . $(sqlLOJproj 2 1) queryUser :: LmsTableExpr -> E.SqlExpr (Entity User) -queryUser = $(sqlIJproj 3 2) +queryUser = $(sqlIJproj 3 2) . $(sqlLOJproj 2 1) queryLmsUser :: LmsTableExpr -> E.SqlExpr (Entity LmsUser) -queryLmsUser = $(sqlIJproj 3 3) +queryLmsUser = $(sqlIJproj 3 3) . $(sqlLOJproj 2 1) + +queryQualBlock :: LmsTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock)) +queryQualBlock = $(sqlLOJproj 2 2) -type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, E.Value (Maybe [Maybe UTCTime]), [Entity UserCompany]) +type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, Maybe (Entity QualificationUserBlock), E.Value (Maybe [Maybe UTCTime]), [Entity UserCompany]) resultQualUser :: Lens' LmsTableData (Entity QualificationUser) resultQualUser = _dbrOutput . _1 @@ -303,11 +311,14 @@ resultUser = _dbrOutput . _2 resultLmsUser :: Lens' LmsTableData (Entity LmsUser) resultLmsUser = _dbrOutput . _3 +resultQualBlock :: Traversal' LmsTableData (Entity QualificationUserBlock) +resultQualBlock = _dbrOutput . _4 . _Just + resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime] -resultPrintAck = _dbrOutput . _4 . _unValue . _Just +resultPrintAck = _dbrOutput . _5 . _unValue . _Just resultCompanyUser :: Lens' LmsTableData [Entity UserCompany] -resultCompanyUser = _dbrOutput . _5 +resultCompanyUser = _dbrOutput . _6 instance HasEntity LmsTableData User where hasEntity = resultUser @@ -315,6 +326,12 @@ instance HasEntity LmsTableData User where instance HasUser LmsTableData where hasUser = resultUser . _entityVal +instance HasEntity LmsTableData QualificationUser where + hasEntity = resultQualUser + +instance HasQualificationUser LmsTableData where + hasQualificationUser = resultQualUser . _entityVal + data LmsTableAction = LmsActNotify | LmsActRenewNotify | LmsActRenewPin @@ -333,6 +350,7 @@ data LmsTableActionData = LmsActNotifyData | LmsActRestartData { lmsActRestartExtend :: Maybe Integer , lmsActRestartUnblock :: Maybe Bool + , lmsActRestartNotify :: Maybe Bool } deriving (Eq, Ord, Read, Show, Generic) @@ -350,18 +368,20 @@ lmsTableQuery :: QualificationId -> LmsTableExpr -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) , E.SqlExpr (Entity User) , E.SqlExpr (Entity LmsUser) + , E.SqlExpr (Maybe (Entity QualificationUserBlock)) , E.SqlExpr (E.Value (Maybe [Maybe UTCTime])) -- outer maybe indicates, whether a printJob exists, inner maybe indicates all acknowledged printJobs ) -lmsTableQuery qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser) = do +lmsTableQuery qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do -- RECALL: another outer join on PrintJob did not work out well, since -- - E.distinctOn [E.don $ printJob E.?. PrintJobLmsUser] $ do -- types, but destroys the ability to sort interactively, since distinctOn requires sorting; - -- - using notExists on printJob join condition works, but only deliver single value, aggregation can deliver all; + -- - using notExists on printJob join condition works, but only delivers single value, while aggregation can deliver all; -- experiments with separate sub-query showed that we would need two subqueries to learn whether the request was indeed the latest + E.on $ qualUser E.^. QualificationUserId E.=?. qualBlock E.?. QualificationUserBlockQualificationUser E.on $ user E.^. UserId E.==. lmsUser E.^. LmsUserUser E.&&. E.val qid E.==. lmsUser E.^. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification - -- TODO: decide whether to use subSelect or LeftOuterJoin and delete the other! + E.&&. qualBlock `isLatestBlockBefore` E.now_ -- Letztes Datum anzeigen, wenn mehrere, dann diese in klickbaren Tooltip verstecken! let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do E.where_ $ E.isJust (pj E.^. PrintJobLmsUser) @@ -369,7 +389,7 @@ lmsTableQuery qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser) = do let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on! pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted typr of subSelect does not seem to support this! E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder - return (qualUser, user, lmsUser, printAcknowledged) + return (qualUser, user, lmsUser, qualBlock, printAcknowledged) mkLmsTable :: ( Functor h, ToSortable h @@ -395,20 +415,20 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do dbtIdent = "lms" dbtSQLQuery = lmsTableQuery qid dbtRowKey = queryUser >>> (E.^. UserId) - dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, printAcks) -> do + dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock, printAcks) -> do cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany] - return (qualUsr, usr, lmsUsr, printAcks, cmpUsr) + return (qualUsr, usr, lmsUsr, qUsrBlock, printAcks, cmpUsr) dbtColonnade = cols cmpMap dbtSorting = mconcat [ single $ sortUserNameLink queryUser , single $ sortUserEmail queryUser , single $ sortUserMatriclenr queryUser - , single ("valid-until" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserValidUntil)) - , single ("validity" , SortColumn $ queryQualUser >>> validQualification nowaday) - , single ("last-refresh" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) - , single ("first-held" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) - , single ("blocked-due" , SortColumnNeverNull$ queryQualUser >>> (E.^. QualificationUserBlockedDue)) - , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) + , single ("valid-until" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserValidUntil)) + -- , single ("validity" , SortColumn $ queryQualUser >>> validQualification nowaday) + , single ("last-refresh" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) + , single ("first-held" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) + , single ("blocked" , SortColumnNeverNull$ queryQualBlock >>> (E.?. QualificationUserBlockFrom)) + , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) , single ("ident" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserIdent)) , single ("pin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserPin)) , single ("status" , SortColumnNullsInv $ views (to queryLmsUser) (E.^. LmsUserStatus)) @@ -417,7 +437,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do , single ("received" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserReceived)) , single ("notified" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserNotified)) -- cannot include printJob acknowledge date , single ("ended" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserEnded)) - , single ( "user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do + , single ("user-company", SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.orderBy [E.asc (comp E.^. CompanyName)] @@ -429,7 +449,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do , single ("ident" , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsUser) (E.^. LmsUserIdent)) -- , single ("status" , FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) ((E.>=. E.val nowaday) . (E.^. LmsUserStatus))) -- LmsStatus cannot be filtered easily within the DB -- , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil))) - , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday)) + , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now)) -- , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> -- if | Just renewal <- mbRenewal -- , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal @@ -496,14 +516,15 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) <*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld) - <*> view (resultQualUser . _entityVal . _qualificationUserBlockedDue) - <*> preview (resultLmsUser . _entityVal . _lmsUserIdent) - <*> (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) - <*> preview (resultLmsUser . _entityVal . _lmsUserStarted) - <*> preview (resultLmsUser . _entityVal . _lmsUserDatePin) - <*> (join . preview (resultLmsUser . _entityVal . _lmsUserReceived)) - <*> (join . preview (resultLmsUser . _entityVal . _lmsUserNotified)) -- TODO: only exports last email date / print job sending date, not print acknowledge - <*> (join . preview (resultLmsUser . _entityVal . _lmsUserEnded)) + <*> preview (resultQualBlock . _entityVal . _qualificationUserBlockUnblock . _not) + <*> preview (resultQualBlock . _entityVal . _qualificationUserBlockFrom) + <*> view (resultLmsUser . _entityVal . _lmsUserIdent) + <*> view (resultLmsUser . _entityVal . _lmsUserStatus) + <*> view (resultLmsUser . _entityVal . _lmsUserStarted) + <*> view (resultLmsUser . _entityVal . _lmsUserDatePin) + <*> view (resultLmsUser . _entityVal . _lmsUserReceived) + <*> view (resultLmsUser . _entityVal . _lmsUserNotified) -- TODO: only exports last email date / print job sending date, not print acknowledge + <*> view (resultLmsUser . _entityVal . _lmsUserEnded) getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of [] -> pure Nothing somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps @@ -560,12 +581,13 @@ postLmsR sid qsh = do , singletonMap LmsActRestart $ LmsActRestartData <$> aopt intField (fslI MsgLmsActRestartExtend) Nothing <*> aopt checkBoxField (fslI MsgLmsActRestartUnblock) Nothing + <*> aopt checkBoxField (fslI MsgLmsActNotify) Nothing -- <*> aopt (commentField MsgQualificationActBlockSupervisor) (fslI MsgMessageWarning) Nothing <* aformMessage msgRestartWarning ] -- lmsStatusLink = toMaybe isAdmin LmsUserR colChoices cmpMap = mconcat - [ if not isAdmin then mempty else dbSelectIf (applying _2) id (return . view (resultUser . _entityKey)) (\r -> isJust $ r ^? resultLmsUser) -- TODO: refactor using function "is" + [ if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultUser . _entityKey)) , colUserNameModalHdr MsgLmsUser AdminUserR , colUserEmail , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) -> @@ -578,12 +600,12 @@ postLmsR sid qsh = do (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs in wgtCell companies , colUserMatriclenr - , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) + -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d - , sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip - ) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> qualificationBlockedCell b + , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltip) $ \row -> + qualificationValidReasonCell isAdmin nowaday row (row ^? resultQualBlock) , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification , sortable (Just "ident") (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> textCell lid @@ -650,34 +672,26 @@ postLmsR sid qsh = do (LmsActRestartData{..}, selectedUsers) -> do let usersList = Set.toList selectedUsers + numUsers = Set.size selectedUsers delUsers <- runDB $ do - when (lmsActRestartUnblock == Just True && ) $ do - authBy <- maybeAuthId - TODO - let unblock = toMaybe (lmsActRestartUnblock == Just True) (nowaday, "Manueller LMS Neustart", authBy) - unblockUsers <- view (_entityVal . _qualificationUserUser) <<$>> selectList - [ QualificationUserQualification ==. qid - , QualificationUserUser <-. usersList - , QualificationUserBlockedDue !=. Nothing - ] [] - void $ qualificationUserBlocking qid unblockUsers False Nothing + when (lmsActRestartUnblock == Just True) $ do + oks <- qualificationUserBlocking qid usersList True (Left "Manueller LMS Neustart") (fromMaybe True lmsActRestartNotify) + addMessageI Success $ MsgQualificationStatusUnblock qsh oks numUsers whenIsJust lmsActRestartExtend $ \extDays -> do let cutoff = addDays extDays nowaday shortUsers <- view (_entityVal . _qualificationUserUser) <<$>> selectList [ QualificationUserQualification ==. qid - , QualificationUserUser <-. usersList - , QualificationUserBlockedDue ==. Nothing + , QualificationUserUser <-. usersList , QualificationUserValidUntil <. cutoff ] [] - forM_ shortUsers $ upsertQualificationUser qid nowaday cutoff Nothing Nothing + forM_ shortUsers $ upsertQualificationUser qid nowaday cutoff Nothing fromIntegral <$> deleteWhereCount [LmsUserQualification ==. qid, LmsUserUser <-. usersList] runDBJobs $ forM_ selectedUsers $ \uid -> queueDBJob $ JobLmsEnqueueUser { jQualification = qid, jUser = uid } - let numUsers = length selectedUsers - mStatus = bool Success Warning $ delUsers < numUsers + let mStatus = bool Success Warning $ delUsers < numUsers addMessageI mStatus $ MsgLmsActRestartFeedback delUsers numUsers reloadKeepGetParams $ LmsR sid qsh @@ -714,7 +728,7 @@ getLmsUserR uuid = do uid <- decrypt uuid now <- liftIO getCurrentTime let nowaday = utctDay now - (user@User{userDisplayName}, quals) <- runDB $ do + (user@User{userDisplayName}, quals, qblocks) <- runDB $ do usr <- get404 uid qs <- Ex.select $ do (qual :& qualUsr :& lmsUsr) <- @@ -730,9 +744,21 @@ getLmsUserR uuid = do Ex.where_ $ E.isJust (qualUsr E.?. QualificationUserUser) E.||. E.isJust ( lmsUsr E.?. LmsUserUser) Ex.orderBy [Ex.asc $ qual E.^. QualificationShorthand] - pure (qual, qualUsr, lmsUsr, validQualification' nowaday qualUsr) - return (usr,qs) - + pure (qual, qualUsr, lmsUsr, validQualification' now qualUsr) + bs :: Map.Map QualificationUserId [(Entity QualificationUserBlock, Ex.Value (Maybe UserDisplayName), Ex.Value (Maybe UserSurname))] + <- foldMapM (\(_, mbqu, _, _) -> case mbqu of + Nothing -> pure mempty + Just (Entity quid _) -> do + blocks <- Ex.select $ do + (qBlock :& qbUsr) <- Ex.from $ Ex.table @QualificationUserBlock + `Ex.leftJoin` Ex.table @User + `Ex.on` (\(qBlock :& qbUsr) -> qBlock Ex.^. QualificationUserBlockBlocker Ex.==. qbUsr Ex.?. UserId) + Ex.where_ $ qBlock Ex.^. QualificationUserBlockQualificationUser Ex.==. Ex.val quid + Ex.orderBy [Ex.desc (qBlock Ex.^. QualificationUserBlockFrom)] + pure (qBlock, qbUsr Ex.?. UserDisplayName, qbUsr Ex.?. UserSurname) + return $ Map.singleton quid blocks + ) qs + return (usr,qs,bs) let heading = [whamlet|_{MsgMenuLmsUser} ^{userWidget user}|] siteLayout heading $ do setTitle $ toHtml userDisplayName diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index c8a693e13..0e19a441c 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -30,7 +30,7 @@ import Database.Persist.Sql (updateWhereCount) import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Legacy as E --- import qualified Database.Esqueleto.PostgreSQL as E +import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH @@ -152,7 +152,8 @@ data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc.. , qtcCompanyNumbers :: CsvSemicolonList Int , qtcValidUntil :: Day , qtcLastRefresh :: Day - , qtcBlocked :: Maybe UTCTime + , qtcBlockStatus :: Maybe Bool + , qtcBlockFrom :: Maybe UTCTime , qtcScheduleRenewal:: Bool , qtcLmsStatusTxt :: Maybe Text , qtcLmsStatusDay :: Maybe Day @@ -168,7 +169,8 @@ qtcExample = QualificationTableCsv , qtcCompanyNumbers = CsvSemicolonList [27,69] , qtcValidUntil = compDay , qtcLastRefresh = compDay - , qtcBlocked = Nothing + , qtcBlockStatus = Nothing + , qtcBlockFrom = Nothing , qtcScheduleRenewal= True , qtcLmsStatusTxt = Just "Success" , qtcLmsStatusDay = Just compDay @@ -201,7 +203,9 @@ instance CsvColumnsExplained QualificationTableCsv where , ('qtcCompany , SomeMessage MsgTableCompanies) , ('qtcCompanyNumbers , SomeMessage MsgTableCompanyNos) , ('qtcValidUntil , SomeMessage MsgLmsQualificationValidUntil) - , ('qtcLastRefresh , SomeMessage MsgTableQualificationLastRefresh) + , ('qtcLastRefresh , SomeMessage MsgTableQualificationLastRefresh) + , ('qtcBlockStatus , SomeMessage MsgInfoQualificationBlockStatus) + , ('qtcBlockFrom , SomeMessage MsgInfoQualificationBlockFrom) , ('qtcScheduleRenewal, SomeMessage MsgQualificationScheduleRenewalTooltip) , ('qtcLmsStatusTxt , SomeMessage MsgTableLmsStatus) , ('qtcLmsStatusDay , SomeMessage MsgTableLmsStatusDay) @@ -249,6 +253,16 @@ instance HasEntity QualificationTableData User where instance HasUser QualificationTableData where hasUser = resultUser . _entityVal +instance HasEntity QualificationTableData QualificationUser where + hasEntity = resultQualUser + +instance HasQualificationUser QualificationTableData where + hasQualificationUser = resultQualUser . _entityVal + +-- instance HasEntity QualificationUserBlock where +-- hasQualificationUserBlock = resultQualBlock + + data QualificationTableAction = QualificationActExpire | QualificationActUnexpire @@ -325,10 +339,7 @@ qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser E.where_ $ fltr qualUser E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) - E.&&. E.notExists (E.from $ \earlierBlock -> - E.where_ $ earlierBlock E.^. QualificationUserBlockQualificationUser E.=?. qualBlock E.?. QualificationUserBlockQualificationUser - E.&&. E.just (earlierBlock E.^. QualificationUserBlockFrom) E.>. qualBlock E.?. QualificationUserBlockFrom - ) + E.&&. qualBlock `isLatestBlockBefore` E.now_ return (qualUser, user, lmsUser, qualBlock) @@ -378,7 +389,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do , single ("lms-status-plus",SortColumnNeverNull $ \row -> E.coalesce [E.explicitUnsafeCoerceSqlExprValue "timestamp" $ (queryLmsUser row E.?. LmsUserStatus) E.#>>. "{day}" , queryLmsUser row E.?. LmsUserStarted]) , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) - , single ( "user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do + , single ("user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.orderBy [E.asc (comp E.^. CompanyName)] @@ -450,6 +461,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do <*> (view resultCompanyUser >>= getCompanyNos) <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) + <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockUnblock . _not) <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom) <*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal) <*> getStatusPlusTxt @@ -573,7 +585,7 @@ postQualificationR sid qsh = do , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) (dayCell . view ( resultQualUser . _entityVal . _qualificationUserValidUntil)) , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row -> - qualificationValidReasonCell isAdmin nowaday (row ^. resultQualUser) (row ^? resultQualBlock) + qualificationValidReasonCell isAdmin nowaday row (row ^? resultQualBlock) , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification , sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths)) @@ -590,7 +602,7 @@ postQualificationR sid qsh = do addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks reloadKeepGetParams $ QualificationR sid qsh (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do - runDB . forM_ selectedUsers $ upsertQualificationUser qid nowaday grantValidday Nothing Nothing + runDB . forM_ selectedUsers $ upsertQualificationUser qid nowaday grantValidday Nothing addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers reloadKeepGetParams $ QualificationR sid qsh (action, selectedUsers) | isExpiryAct action -> do diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index 6c27ba64f..821679e27 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -65,31 +65,37 @@ quserToNotify quser cutoff = ) ) +-- condition to ensure that the lastes QualificationUserBlock was picked +isLatestBlockBefore :: E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool) +isLatestBlockBefore qualBlock cutoff = E.notExists $ do + newerBlock <- E.from $ E.table @QualificationUserBlock + E.where_ $ newerBlock E.^. QualificationUserBlockFrom E.<=. cutoff + E.&&. E.just (newerBlock E.^. QualificationUserBlockFrom) E.>. qualBlock E.?. QualificationUserBlockFrom + E.&&. newerBlock E.^. QualificationUserBlockQualificationUser E.=?. qualBlock E.?. QualificationUserBlockQualificationUser --- TODO: consider replacing `cutoff` by `Database.Esqueleto.PostgreSQL.now_`? - -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) +-- cutoff can be `E.val now` or even `Database.Esqueleto.PostgreSQL.now_` +quserBlockAux :: Bool -> E.SqlExpr (E.Value 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 cutoff) + E.&&. (qualUserBlock E.^. QualificationUserBlockFrom E.<=. 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 cutoff + E.&&. qualUserUnblock E.^. QualificationUserBlockFrom E.<=. 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 -> UTCTime -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool) -quserBlock negCond cutoff qualUser = quserBlockAux negCond cutoff (E.==. (qualUser E.^. QualificationUserId)) Nothing +quserBlock negCond cutoff qualUser = quserBlockAux negCond (E.val cutoff) (E.==. (qualUser E.^. QualificationUserId)) Nothing -- | Variant of `isBlocked` for outer joins 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 +quserBlock' negCond cutoff qualUser = quserBlockAux negCond (E.val cutoff) (E.=?. (qualUser E.?. QualificationUserId)) Nothing qualificationValid :: E.SqlExpr (Entity QualificationUser) -> UTCTime -> E.SqlExpr (E.Value Bool) qualificationValid = flip validQualification @@ -127,8 +133,8 @@ selectRelevantBlock cutoff quid = ------------------------ -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 :: QualificationId -> Day -> Day -> Maybe Bool -> UserId -> DB () -- ignores blocking +upsertQualificationUser qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal qualificationUserUser = do Entity quid _ <- upsert QualificationUser { qualificationUserFirstHeld = qualificationUserLastRefresh @@ -144,12 +150,6 @@ upsertQualificationUser qualificationUserQualification qualificationUserLastRef ] ) - whenIsJust mbUnblockBecause $ \(qualificationUserBlockFrom, qualificationUserBlockReason, qualificationUserBlockBlocker) -> do - block <- selectFirst [ QualificationUserBlockQualificationUser ==. quid ] [ Desc QualificationUserBlockFrom ] - whenIsJust block $ \qub -> - unless (qub ^. _entityVal . _qualificationUserBlockUnblock) $ - insert_ QualificationUserBlock{ qualificationUserBlockQualificationUser = quid, qualificationUserBlockUnblock = True, ..} - audit TransactionQualificationUserEdit { transactionQualificationUser = quid , transactionQualification = qualificationUserQualification @@ -264,6 +264,6 @@ qualificationUserUnblockByReason qid uids (qualificationBlockReasonText -> reaso 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 now (E.==. (quser E.^. QualificationUserId)) (Just (\qblock -> (qblock E.^. QualificationUserBlockReason) E.==. E.val reason)) + E.&&. quserBlockAux True (E.val 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 879358cf2..5b3da66ed 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -333,29 +333,20 @@ qualificationValidUntilCell q = textCell (qsh <> ": ") <> dayCell vtd vtd = q ^. hasQualificationUser . _qualificationUserValidUntil qualificationValidIconCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Day -> a -> Maybe b -> DBCell m c -qualificationValidIconCell d qu qb = iconBoolCell $ isValidQualification d qu qb +qualificationValidIconCell d qu qb = blockIcon $ isValidQualification d qu qb + where + blockIcon = cell . toWidget . iconQualificationBlock qualificationValidReasonCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Bool -> Day -> a -> Maybe b -> DBCell m c qualificationValidReasonCell showReason d qu qb = ic <> foldMap blc qb - where - ic = iconBoolCell $ isValidQualification d qu qb + where + ic = cell . toWidget . iconQualificationBlock $ isValidQualification d qu qb blc (view hasQualificationUserBlock -> QualificationUserBlock{..}) | showReason = spacerCell <> dateCell qualificationUserBlockFrom <> spacerCell <> modalCellLarge qualificationUserBlockReason -- TODO: add anchorLink to block history, if user is allowed | qualificationUserBlockUnblock = mempty | otherwise = spacerCell <> dateCell qualificationUserBlockFrom --- qualificationBlockedCellNoReason :: IsDBTable m a => QualificationUserBlock -> DBCell m a --- qualificationBlockedCellNoReason QualificationUserBlock{qualificationUserBlockFrom=t, qualificationUserBlockUnblock=unblock} = --- iconBoolCell unblock <> spacerCell <> dateCell d - --- qualificationBlockedCell :: IsDBTable m a => QualificationUserBlock -> DBCell m a --- qualificationBlockedCell QualificationUserBlock{..} --- | 32 >= length qualificationUserBlockReason = mkCellWith textCell --- | otherwise = mkCellWith modalCell --- where --- mkCellWith c = c qualificationUserBlockReason <> spacerCell <> iconCell IconBlocked <> spacerCell <> dayCell qualificationUserBlockFrom - lmsShortCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c lmsShortCell (view hasQualification -> Qualification{..}) = anchorCell link name where diff --git a/src/Utils.hs b/src/Utils.hs index 9b3390c5c..226b84bbc 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1209,11 +1209,12 @@ partitionM crit = ofoldlM dist mempty | okay -> acc `mappend` (opoint x, mempty) | otherwise -> acc `mappend` (mempty, opoint x) -mconcatMapM :: (Monoid b, Monad m, Foldable f) => (a -> m b) -> f a -> m b -mconcatMapM f = foldM (\x my -> mappend x <$> my) mempty . map f . Fold.toList +-- use `foldMapM` instead +-- mconcatMapM :: (Monoid b, Monad m, Foldable f) => (a -> m b) -> f a -> m b +-- mconcatMapM f = foldM (\x my -> mappend x <$> my) mempty . map f . Fold.toList -mconcatForM :: (Monoid b, Monad m, Foldable f) => f a -> (a -> m b) -> m b -mconcatForM = flip mconcatMapM +-- mconcatForM :: (Monoid b, Monad m, Foldable f) => f a -> (a -> m b) -> m b +-- mconcatForM = flip mconcatMapM findM :: (Monad m, Foldable f) => (a -> MaybeT m b) -> f a -> m (Maybe b) findM f = runMaybeT . Fold.foldr (\x as -> f x <|> as) mzero diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index eda59372c..260e0e03b 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -104,6 +104,7 @@ data Icon | IconRemoveUser | IconReset | IconBlocked + | IconCertificate | IconPrintCenter | IconLetter | IconAt @@ -191,6 +192,7 @@ iconText = \case IconSubmissionNoUsers -> "user-slash" IconReset -> "undo" -- From fontawesome v6 onwards: "arrow-rotate-left" IconBlocked -> "ban" + IconCertificate -> "badge-check" IconPrintCenter -> "mail-bulk" -- From fontawesome v6 onwards: "envelope-bulk" IconLetter -> "mail-bulk" -- Problem "envelope" already used for email as well IconAt -> "at" @@ -295,6 +297,10 @@ iconLetterOrEmail :: Bool -> Markup iconLetterOrEmail True = icon IconLetter iconLetterOrEmail False = icon IconAt +iconQualificationBlock :: Bool -> Markup +iconQualificationBlock True = icon IconCertificate +iconQualificationBlock False = icon IconBlocked + ---------------- -- For documentation on how to avoid these unneccessary functions -- we implement them here just once for the first icon: diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 9c3791c30..9bab8bda5 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -166,7 +166,7 @@ instance HasQualificationUser a => HasQualificationUser (Entity a) where -- hasQualificationUser = _2 . hasQualificationUser instance HasQualificationUserBlock a => HasQualificationUserBlock (Entity a) where - hasQualificationUser = _entityVal . hasQualificationUserBlock + hasQualificationUserBlock = _entityVal . hasQualificationUserBlock instance HasLmsUser a => HasLmsUser (Entity a) where hasLmsUser = _entityVal . hasLmsUser diff --git a/templates/lms-user.hamlet b/templates/lms-user.hamlet index 842013fc4..c039d4c93 100644 --- a/templates/lms-user.hamlet +++ b/templates/lms-user.hamlet @@ -11,19 +11,33 @@ $else

- #{qualificationShorthand quali} - #{qualificationName quali} (#{qualificationSchool quali})   #{boolSymbol (E.unValue validity)} + #{qualificationShorthand quali} - #{qualificationName quali} (#{qualificationSchool quali})   + + #{iconQualificationBlock (E.unValue validity)}
- $maybe (Entity _ qualUsr) <- mbQualUsr + $maybe (Entity quid qualUsr) <- mbQualUsr
_{MsgLmsQualificationValidUntil}
^{formatTimeW SelFormatDate (qualificationUserValidUntil qualUsr)} $if not (qualificationUserScheduleRenewal qualUsr) \ #{icon IconNoNotification} - $maybe (qblock) <- qualificationUserBlockedDue qualUsr + $maybe qblock <- Map.lookup quid qblocks
_{MsgTableQualificationBlockedDue} -
^{formatTimeW SelFormatDate (qualificationBlockedDay qblock)} - \ #{icon IconBlocked} - \ #{qualificationBlockedReason qblock} +
+