refactor(qualification): WIP db migration implemented

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

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)
 

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)

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

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

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 

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)

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