From d377d717d2f374a19f8ed837b8bb84b308eb3b60 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 24 May 2023 16:25:34 +0000 Subject: [PATCH] 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