fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactor(qualification): WIP db migration implemented

Browse Source
This commit is contained in:
Steffen Jost 2023-05-24 16:25:34 +00:00
parent 00d406dd13
commit d377d717d2
8 changed files with 64 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
models/lms.model
View File

@ -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

4
src/Audit/Types.hs
View File

@ -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)

6
src/Handler/Utils/Qualification.hs
View File

@ -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)

6
src/Model.hs
View File

@ -243,3 +243,9 @@ instance IsFileReference MaterialFile where
fileReferenceTitleField = MaterialFileTitle
fileReferenceContentField = MaterialFileContent
fileReferenceModifiedField = MaterialFileModified
deriveJSON defaultOptions
{ tagSingleConstructors = False
, fieldLabelModifier = camelToPathPiece' 2
, omitNothingFields = True
} ''QualificationUserBlock

18
src/Model/Migration/Definitions.hs
View File

@ -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

15
src/Model/Migration/Types.hs
View File

@ -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

25
src/Model/Types/Lms.hs
View File

@ -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)

2
src/Utils/Lens.hs
View File

@ -122,7 +122,9 @@ makeClassyFor_ ''StudySubTerms
makeClassyFor_ ''Qualification
makeClassyFor_ ''QualificationUser
makeClassyFor_ ''QualificationUserBlock
makeClassyFor_ ''LmsUser
-- makeClassyFor_ ''LmsUserStatus
makeClassyFor_ ''LmsUserlist
makeClassyFor_ ''LmsResult
makeClassyFor_ ''UserAvs