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

refactor(lms): fix #75 by splitting lmsStatus

Browse Source
This commit is contained in:
Steffen Jost 2023-07-03 16:45:16 +00:00
parent 3d595271d9
commit 2d62acea5e
10 changed files with 65 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
models/lms.model
View File

@ -117,6 +117,7 @@ LmsUser
datePin UTCTime default=now() -- time pin was created datePin UTCTime default=now() -- time pin was created
status LmsStatus Maybe -- open, success or failure; status should never change unless isNothing; isJust indicates lms is finished and user shall be deleted from LMS status LmsStatus Maybe -- open, success or failure; status should never change unless isNothing; isJust indicates lms is finished and user shall be deleted from LMS
--toDelete encoded by Handler.Utils.LMS.lmsUserToDelete --toDelete encoded by Handler.Utils.LMS.lmsUserToDelete
statusDay Day Maybe -- date of status change; should be isJust iff isJust status; modelling as a separate table too bothersome, unlike qualification block
started UTCTime default=now() started UTCTime default=now()
received UTCTime Maybe -- last acknowledgement by LMS received UTCTime Maybe -- last acknowledgement by LMS
notified UTCTime Maybe -- last notified by FRADrive notified UTCTime Maybe -- last notified by FRADrive
@ -130,7 +131,7 @@ LmsUser
-- lmsUser LmsUserId OnDeleteCascade OnUpdateCascade -- lmsUser LmsUserId OnDeleteCascade OnUpdateCascade
-- result LmsStatus -- data LmsStatus = LmsBlocked | LmsExpired | LmsSuccess -- result LmsStatus -- data LmsStatus = LmsBlocked | LmsExpired | LmsSuccess
-- day Day -- day Day
-- UniqueLmsUserStatus lmsUser -- UniqueLmsUserStatus lmsUser -- enforcing uniqueness prohibits history
-- deriving Generic -- deriving Generic
-- LmsUserlist stores LMS upload for later processing only -- LmsUserlist stores LMS upload for later processing only

10
src/Handler/LMS.hs
View File

@ -213,6 +213,7 @@ data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc..
, ltcBlockFrom :: Maybe UTCTime , ltcBlockFrom :: Maybe UTCTime
, ltcLmsIdent :: LmsIdent , ltcLmsIdent :: LmsIdent
, ltcLmsStatus :: Maybe LmsStatus , ltcLmsStatus :: Maybe LmsStatus
, ltcLmsStatusDay :: Maybe Day
, ltcLmsStarted :: UTCTime , ltcLmsStarted :: UTCTime
, ltcLmsDatePin :: UTCTime , ltcLmsDatePin :: UTCTime
, ltcLmsReceived :: Maybe UTCTime , ltcLmsReceived :: Maybe UTCTime
@ -228,13 +229,14 @@ ltcExample = LmsTableCsv
, ltcEmail = "m.mustermann@example.com" , ltcEmail = "m.mustermann@example.com"
, ltcCompany = Just "Example Brothers LLC, SecondaryJobs Inc" , ltcCompany = Just "Example Brothers LLC, SecondaryJobs Inc"
, ltcCompanyNumbers = CsvSemicolonList [27,69] , ltcCompanyNumbers = CsvSemicolonList [27,69]
, ltcValidUntil = compDay , ltcValidUntil = succ compDay
, ltcLastRefresh = compDay , ltcLastRefresh = compDay
, ltcFirstHeld = compDay , ltcFirstHeld = pred $ pred compDay
, ltcBlockStatus = Nothing , ltcBlockStatus = Nothing
, ltcBlockFrom = Nothing , ltcBlockFrom = Nothing
, ltcLmsIdent = LmsIdent "abcdefgh" , ltcLmsIdent = LmsIdent "abcdefgh"
, ltcLmsStatus = Nothing , ltcLmsStatus = Just LmsSuccess
, ltcLmsStatusDay = Just $ pred compDay
, ltcLmsStarted = compTime , ltcLmsStarted = compTime
, ltcLmsDatePin = compTime , ltcLmsDatePin = compTime
, ltcLmsReceived = Nothing , ltcLmsReceived = Nothing
@ -277,6 +279,7 @@ instance CsvColumnsExplained LmsTableCsv where
, ('ltcBlockFrom , SomeMessage MsgInfoQualificationBlockFrom) , ('ltcBlockFrom , SomeMessage MsgInfoQualificationBlockFrom)
, ('ltcLmsIdent , SomeMessage MsgTableLmsIdent) , ('ltcLmsIdent , SomeMessage MsgTableLmsIdent)
, ('ltcLmsStatus , SomeMessage MsgTableLmsStatus) , ('ltcLmsStatus , SomeMessage MsgTableLmsStatus)
, ('ltcLmsStatusDay , SomeMessage MsgTableLmsStatusDay)
, ('ltcLmsStarted , SomeMessage MsgTableLmsStarted) , ('ltcLmsStarted , SomeMessage MsgTableLmsStarted)
, ('ltcLmsDatePin , SomeMessage MsgTableLmsDatePin) , ('ltcLmsDatePin , SomeMessage MsgTableLmsDatePin)
, ('ltcLmsReceived , SomeMessage MsgTableLmsReceived) , ('ltcLmsReceived , SomeMessage MsgTableLmsReceived)
@ -520,6 +523,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
<*> preview (resultQualBlock . _entityVal . _qualificationUserBlockFrom) <*> preview (resultQualBlock . _entityVal . _qualificationUserBlockFrom)
<*> view (resultLmsUser . _entityVal . _lmsUserIdent) <*> view (resultLmsUser . _entityVal . _lmsUserIdent)
<*> view (resultLmsUser . _entityVal . _lmsUserStatus) <*> view (resultLmsUser . _entityVal . _lmsUserStatus)
<*> view (resultLmsUser . _entityVal . _lmsUserStatusDay)
<*> view (resultLmsUser . _entityVal . _lmsUserStarted) <*> view (resultLmsUser . _entityVal . _lmsUserStarted)
<*> view (resultLmsUser . _entityVal . _lmsUserDatePin) <*> view (resultLmsUser . _entityVal . _lmsUserDatePin)
<*> view (resultLmsUser . _entityVal . _lmsUserReceived) <*> view (resultLmsUser . _entityVal . _lmsUserReceived)

2
src/Handler/PrintCenter.hs
View File

@ -400,7 +400,7 @@ postPrintAckR ackDay numAck chksm = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
E.updateCount $ \pj -> do E.updateCount $ \pj -> do
let pjDay = E.day $ pj E.^. PrintJobCreated let pjDay = E.day $ pj E.^. PrintJobCreated
E.set pj [ PrintJobAcknowledged E.=. E.just (E.val now) ] E.set pj [ PrintJobAcknowledged E.=. E.justVal now ]
E.where_ $ E.isNothing (pj E.^. PrintJobAcknowledged) E.where_ $ E.isNothing (pj E.^. PrintJobAcknowledged)
E.&&. (pjDay E.==. E.val ackDay) E.&&. (pjDay E.==. E.val ackDay)
-- Ex.updateCount $ do -- Ex.updateCount $ do

4
src/Handler/Qualification.hs
View File

@ -489,8 +489,8 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
Nothing -> maybeM (return Nothing) (const $ return $ Just "Open") $ Nothing -> maybeM (return Nothing) (const $ return $ Just "Open") $
preview (resultLmsUser . _entityVal . _lmsUserStarted) preview (resultLmsUser . _entityVal . _lmsUserStarted)
getStatusPlusDay = getStatusPlusDay =
(join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case (join . preview (resultLmsUser . _entityVal . _lmsUserStatusDay)) >>= \case
Just ls -> return $ Just $ lmsStatusDay ls lsd@(Just _) -> return lsd
Nothing -> utctDay <<$>> preview (resultLmsUser . _entityVal . _lmsUserStarted) Nothing -> utctDay <<$>> preview (resultLmsUser . _entityVal . _lmsUserStarted)
dbtCsvDecode = Nothing dbtCsvDecode = Nothing

11
src/Handler/Utils/LMS.hs
View File

@ -114,12 +114,13 @@ lmsDeletionDate = do
-- | Decide whether LMS platform should delete an identifier -- | Decide whether LMS platform should delete an identifier
lmsUserToDeleteExpr :: Day -> E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool) lmsUserToDeleteExpr :: Day -> E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool)
lmsUserToDeleteExpr cutoff lmslist = E.isNothing (lmslist E.^. LmsUserEnded) lmsUserToDeleteExpr cutoff lmslist = E.isNothing (lmslist E.^. LmsUserEnded)
E.&&. E.not_ (E.isNothing $ lmslist E.^. LmsUserStatus) E.&&. E.isJust (lmslist E.^. LmsUserStatus)
E.&&. E.explicitUnsafeCoerceSqlExprValue "timestamp" ((lmslist E.^. LmsUserStatus) E.#>>. "{day}") E.<=. E.val cutoff E.&&. E.isJust (lmslist E.^. LmsUserStatusDay)
E.&&. lmslist E.^. LmsUserStatusDay E.<=. E.justVal cutoff
-- | Is everything since cutoff day or before? -- | Is everything since cutoff day or before?
lmsUserToDelete :: Day -> LmsUser -> Bool lmsUserToDelete :: Day -> LmsUser -> Bool
lmsUserToDelete cutoff LmsUser{lmsUserEnded=Nothing, lmsUserStatus= Just lstat} = lmsStatusDay lstat < cutoff lmsUserToDelete cutoff LmsUser{lmsUserEnded=Nothing, lmsUserStatusDay= Just lstat} = lstat < cutoff
lmsUserToDelete _ _ = False lmsUserToDelete _ _ = False
_lmsUserToDelete :: Day -> Getter LmsUser Bool _lmsUserToDelete :: Day -> Getter LmsUser Bool
@ -194,9 +195,9 @@ lmsStatusIcon LmsExpired{} = IconExpired
lmsStatusIcon _other = IconNotOK lmsStatusIcon _other = IconNotOK
lmsUserStatusWidget :: Bool -> LmsUser -> Widget lmsUserStatusWidget :: Bool -> LmsUser -> Widget
lmsUserStatusWidget _ LmsUser{lmsUserStatus=Just lStat} = lmsUserStatusWidget _ LmsUser{lmsUserStatus=Just lStat, lmsUserStatusDay=Just aday} =
[whamlet|$newline never [whamlet|$newline never
^{formatTimeW SelFormatDate (lmsStatusDay lStat)} ^{formatTimeW SelFormatDate aday}
\ ^{icon (lmsStatusIcon lStat)} \ ^{icon (lmsStatusIcon lStat)}
|] |]
-- previously: IconWaitingForUser for lmsUserStatus==Nothing -- previously: IconWaitingForUser for lmsUserStatus==Nothing

20
src/Jobs/Handler/LMS.hs
View File

@ -141,6 +141,7 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
, lmsUserResetPin = False , lmsUserResetPin = False
, lmsUserDatePin = now , lmsUserDatePin = now
, lmsUserStatus = Nothing , lmsUserStatus = Nothing
, lmsUserStatusDay = Nothing
, lmsUserStarted = now , lmsUserStarted = now
, lmsUserReceived = Nothing , lmsUserReceived = Nothing
, lmsUserNotified = Nothing , lmsUserNotified = Nothing
@ -183,7 +184,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
E.&&. E.not_ (validQualification now quser) E.&&. E.not_ (validQualification now quser)
pure (luser E.^. LmsUserId) pure (luser E.^. LmsUserId)
nrExpired <- E.updateCount $ \luser -> do nrExpired <- E.updateCount $ \luser -> do
E.set luser [LmsUserStatus E.=. E.justVal (LmsExpired nowaday)] E.set luser [LmsUserStatus E.=. E.justVal LmsExpired, LmsUserStatusDay E.=. E.justVal nowaday]
E.where_ $ (luser E.^. LmsUserId) `E.in_` E.valList (E.unValue <$> expiredLearners) E.where_ $ (luser E.^. LmsUserId) `E.in_` E.valList (E.unValue <$> expiredLearners)
E.&&. luser E.^. LmsUserQualification E.==. E.val qid E.&&. luser E.^. LmsUserQualification E.==. E.val qid
$logInfoS "LMS" $ "Expired lms users " <> tshow nrExpired <> " for qualification " <> qshort $logInfoS "LMS" $ "Expired lms users " <> tshow nrExpired <> " for qualification " <> qshort
@ -211,7 +212,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
delusersVals <- E.select $ do delusersVals <- E.select $ do
luser <- E.from $ E.table @LmsUser luser <- E.from $ E.table @LmsUser
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
E.&&. luser E.^. LmsUserEnded E.<. E.just (E.val auditCutoff) E.&&. luser E.^. LmsUserEnded E.<. E.justVal auditCutoff
E.&&. E.isJust (luser E.^. LmsUserEnded) E.&&. E.isJust (luser E.^. LmsUserEnded)
-- E.&&. E.notExists (do -- E.&&. E.notExists (do
-- laudit <- E.from $ E.table @LmsAudit -- laudit <- E.from $ E.table @LmsAudit
@ -257,10 +258,9 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
-- three separate DB operations per result is not so nice. All within one transaction though. -- three separate DB operations per result is not so nice. All within one transaction though.
let lmsUserStartedDay = localDay $ TZ.utcToLocalTimeTZ appTZ lmsUserStarted let lmsUserStartedDay = localDay $ TZ.utcToLocalTimeTZ appTZ lmsUserStarted
saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil locDay) saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil locDay)
-- && qualificationUserLastRefresh <= utctDay lmsUserStarted NOTE: not always true due to manual intervention; also renewValidQualificationUsers prevents double renewals anyway -- && qualificationUserLastRefresh <= utctDay lmsUserStarted NOTE: not always true due to manual intervention; also renewValidQualificationUsers prevents double renewals anyway
newStatus = Just $ LmsSuccess lmsResultSuccess
-- newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards -- newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards
note <- if saneDate && replaceLmsStatus lmsUserStatus newStatus note <- if saneDate && (lmsUserStatus /= Just LmsSuccess)
then do 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 -- 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_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning
@ -271,8 +271,9 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
-- 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 -- 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 update luid
[ LmsUserStatus =. newStatus [ LmsUserStatus =. Just LmsSuccess
, LmsUserReceived =. Just lmsResultTimestamp , LmsUserStatusDay =. Just lmsResultSuccess
, LmsUserReceived =. Just lmsResultTimestamp
] ]
return Nothing return Nothing
else do else do
@ -328,10 +329,9 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
let isBlocked = lmsUserlistFailed lulist let isBlocked = lmsUserlistFailed lulist
oldStatus = lmsUserStatus luser oldStatus = lmsUserStatus luser
newStatus = bool Nothing (Just $ LmsBlocked lmsMsgDay) isBlocked updateStatus = isBlocked && oldStatus /= Just LmsSuccess
updateStatus = replaceLmsStatus oldStatus newStatus
when updateStatus $ do when updateStatus $ do
update luid [LmsUserStatus =. newStatus] update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. Just lmsMsgDay]
ok <- qualificationUserBlocking qid [lmsUserUser luser] False (Right QualificationBlockFailedELearning) True ok <- qualificationUserBlocking qid [lmsUserUser luser] False (Right QualificationBlockFailedELearning) True
when (ok /= 1) $ do when (ok /= 1) $ do
uuid :: CryptoUUIDUser <- encrypt $ lmsUserUser luser uuid :: CryptoUUIDUser <- encrypt $ lmsUserUser luser

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

@ -93,6 +93,7 @@ data ManualMigration
| Migration20210318CrontabSubmissionRatedNotification | Migration20210318CrontabSubmissionRatedNotification
| Migration20210608SeparateTermActive | Migration20210608SeparateTermActive
| Migration20230524QualificationUserBlock | Migration20230524QualificationUserBlock
| Migration20230703LmsUserStatus
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
deriving anyclass (Universe, Finite) deriving anyclass (Universe, Finite)
@ -868,9 +869,9 @@ customMigrations = mapF $ \case
, "from" timestamp with time zone NOT NULL , "from" timestamp with time zone NOT NULL
, "reason" character varying NOT NULL , "reason" character varying NOT NULL
, "blocker" bigint , "blocker" bigint
, CONSTRAINT qualification_user_block_qualification_user_fkey FOREIGN KEY ("qualification_user") REFERENCES "qualification_user"(id) ON DELETE CASCADE , CONSTRAINT qualification_user_block_qualification_user_fkey FOREIGN KEY ("qualification_user") REFERENCES "qualification_user"(id) ON DELETE CASCADE ON UPDATE CASCADE
, CONSTRAINT qualification_user_block_blocker_fkey FOREIGN KEY ("blocker") REFERENCES "user"(id) , CONSTRAINT qualification_user_block_blocker_fkey FOREIGN KEY ("blocker") REFERENCES "user"(id)
) );
|] |]
let getBlocks = [queryQQ|SELECT "id", "blocked_due" FROM "qualification_user" WHERE "blocked_due" IS NOT NULL|] let getBlocks = [queryQQ|SELECT "id", "blocked_due" FROM "qualification_user" WHERE "blocked_due" IS NOT NULL|]
@ -883,6 +884,16 @@ customMigrations = mapF $ \case
ALTER TABLE "qualification_user" DROP COLUMN "blocked_due"; ALTER TABLE "qualification_user" DROP COLUMN "blocked_due";
|] |]
Migration20230703LmsUserStatus ->
unlessM (columnExists "lms_user" "status_day") $ do
[executeQQ|
ALTER TABLE "lms_user" ADD COLUMN "status_day" date;
UPDATE "lms_user"
SET "status_day" = CAST("status"->>'day' AS date)
, "status" = "status"->'lms-status'
;
|]
tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool
tableExists table = do tableExists table = do

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

@ -34,57 +34,25 @@ deriveJSON defaultOptions
-- TODO: Is this a good idea? An ordinary Enum and a separate Day column in the DB would be better, e.g. allowing use of insertSelect in Jobs.Handler.LMS? -- TODO: Is this a good idea? An ordinary Enum and a separate Day column in the DB would be better, e.g. allowing use of insertSelect in Jobs.Handler.LMS?
-- ...also see similar type QualificationBlocked -- ...also see similar type QualificationBlocked
data LmsStatus = LmsBlocked { lmsStatusDay :: Day } data LmsStatus = LmsExpired
| LmsExpired { lmsStatusDay :: Day } | LmsBlocked
| LmsSuccess { lmsStatusDay :: Day } | LmsSuccess
deriving (Eq, Read, Show, Generic, NFData) deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, NFData)
deriving anyclass (Universe, Finite)
instance Ord LmsStatus where
compare a b
| daycmp <- compare (lmsStatusDay a) (lmsStatusDay b)
, daycmp /= EQ = daycmp
compare LmsSuccess{} LmsBlocked{} = GT
compare LmsSuccess{} LmsExpired{} = GT
compare LmsBlocked{} LmsSuccess{} = LT
compare LmsExpired{} LmsSuccess{} = LT
compare LmsBlocked{} LmsExpired{} = GT
compare LmsExpired{} LmsBlocked{} = LT
compare _ _ = EQ
isLmsSuccess :: LmsStatus -> Bool
isLmsSuccess LmsSuccess{} = True
isLmsSuccess _other = False
isLmsExpired :: LmsStatus -> Bool
isLmsExpired LmsExpired{} = True
isLmsExpired _other = False
-- | What to do if LMS sends multiple responses and whether an oldStatus should be overwritten
replaceLmsStatus :: Maybe LmsStatus -> Maybe LmsStatus -> Bool
replaceLmsStatus _ Nothing = False
replaceLmsStatus Nothing _ = True
replaceLmsStatus (Just LmsSuccess{}) _ = False
replaceLmsStatus (Just LmsExpired{}) (Just newStat) = not $ isLmsExpired newStat
replaceLmsStatus (Just LmsBlocked{}) (Just newStat) = isLmsSuccess newStat
makeLenses_ ''LmsStatus
-- Entscheidung 16.09.22: Es gewinnt was zuerst gemeldet wurde. Das verhindert, dass eine Qualifikation doppelt verlängert wird! Siehe Model.TypesSpec
instance Semigroup LmsStatus where
a <> b = min a b -- earliest date, otherwise LmsBlocked before LmsSuccess
deriveJSON defaultOptions deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 1 -- remove lms from constructor, since the object is tagged with lms already { constructorTagModifier = camelToPathPiece' 1 -- remove lms from constructor
, fieldLabelModifier = camelToPathPiece' 2 -- just day suffices for the day field , fieldLabelModifier = camelToPathPiece' 1
, omitNothingFields = True , sumEncoding = UntaggedValue
, sumEncoding = TaggedObject "lms-status" "lms-result"
} ''LmsStatus } ''LmsStatus
derivePersistFieldJSON ''LmsStatus derivePersistFieldJSON ''LmsStatus
nullaryPathPiece ''LmsStatus $ camelToPathPiece' 1
instance Csv.ToField LmsStatus where instance Csv.ToField LmsStatus where
toField (LmsBlocked d) = "Failure: " <> Csv.toField d toField = Csv.toField . toPathPiece
toField (LmsExpired d) = "Expired: " <> Csv.toField d
toField (LmsSuccess d) = "Success: " <> Csv.toField d
-- | Default Block/Unblock reasons -- | Default Block/Unblock reasons
data QualificationBlockStandardReason data QualificationBlockStandardReason

6
src/Model/Types/Security.hs
View File

@ -63,9 +63,9 @@ instance Hashable AuthenticationMode
instance NFData AuthenticationMode instance NFData AuthenticationMode
deriveJSON defaultOptions deriveJSON defaultOptions
{ constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel { constructorTagModifier = camelToPathPiece' 1
, fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel , fieldLabelModifier = camelToPathPiece' 1
, sumEncoding = UntaggedValue , sumEncoding = UntaggedValue
} ''AuthenticationMode } ''AuthenticationMode
derivePersistFieldJSON ''AuthenticationMode derivePersistFieldJSON ''AuthenticationMode

16
test/Database/Fill.hs
View File

@ -731,12 +731,12 @@ fillDb = do
void . insert' $ LmsUserlist qid_f (LmsIdent "hijklmn") False now void . insert' $ LmsUserlist qid_f (LmsIdent "hijklmn") False now
void . insert' $ LmsUserlist qid_f (LmsIdent "abcdefg") True now void . insert' $ LmsUserlist qid_f (LmsIdent "abcdefg") True now
void . insert' $ LmsUserlist qid_f (LmsIdent "ijk" ) False now void . insert' $ LmsUserlist qid_f (LmsIdent "ijk" ) False now
void . insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False now Nothing now Nothing (Just $ n_day' (-7)) (Just $ n_day' (-5)) void . insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False now Nothing Nothing now Nothing (Just $ n_day' (-7)) (Just $ n_day' (-5))
void . insert' $ LmsUser qid_f svaupel (LmsIdent "abcdefg") "abc" False now (Just $ LmsSuccess $ n_day 1) (n_day' (-1)) (Just now) (Just $ n_day' 0) Nothing void . insert' $ LmsUser qid_f svaupel (LmsIdent "abcdefg") "abc" False now (Just LmsSuccess) (Just $ n_day 1) (n_day' (-1)) (Just now) (Just $ n_day' 0) Nothing
void . insert' $ LmsUser qid_f gkleen (LmsIdent "hijklmn") "@#!" True now (Just $ LmsBlocked $ utctDay now) (n_day' (-2)) (Just now) (Just $ n_day' (-4)) Nothing void . insert' $ LmsUser qid_f gkleen (LmsIdent "hijklmn") "@#!" True now (Just LmsBlocked) (Just $ utctDay now) (n_day' (-2)) (Just now) (Just $ n_day' (-4)) Nothing
void . insert' $ LmsUser qid_f tinaTester (LmsIdent "qwvu") "45678" True now (Just $ LmsSuccess $ n_day (-22)) (n_day' (-3)) (Just $ n_day' (-1)) (Just $ n_day' (-1)) Nothing void . insert' $ LmsUser qid_f tinaTester (LmsIdent "qwvu") "45678" True now (Just LmsSuccess) (Just $ n_day (-22)) (n_day' (-3)) (Just $ n_day' (-1)) (Just $ n_day' (-1)) Nothing
void . insert' $ LmsUser qid_f maxMuster (LmsIdent "xyz") "a1b2c3" False now (Just $ LmsBlocked $ n_day (-11)) (n_day' (-4)) (Just $ n_day' (-2)) (Just $ n_day' (-2)) Nothing void . insert' $ LmsUser qid_f maxMuster (LmsIdent "xyz") "a1b2c3" False now (Just LmsBlocked) (Just $ n_day (-11)) (n_day' (-4)) (Just $ n_day' (-2)) (Just $ n_day' (-2)) Nothing
void . insert' $ LmsUser qid_f fhamann (LmsIdent "123") "456" False now Nothing now Nothing Nothing Nothing void . insert' $ LmsUser qid_f fhamann (LmsIdent "123") "456" False now Nothing Nothing now Nothing Nothing Nothing
void . insert $ PrintJob "TestJob1" "AckTestJob1" "job1" "No Text herein." (n_day' (-1)) Nothing Nothing (Just svaupel) Nothing (Just qid_f) Nothing void . insert $ PrintJob "TestJob1" "AckTestJob1" "job1" "No Text herein." (n_day' (-1)) Nothing Nothing (Just svaupel) Nothing (Just qid_f) Nothing
void . insert $ PrintJob "TestJob2" "AckTestJob2" "job2" "No Text herein." (n_day' (-3)) (Just $ n_day' (-1)) (Just jost) (Just svaupel) Nothing (Just qid_f) (Just $ LmsIdent "ijk") void . insert $ PrintJob "TestJob2" "AckTestJob2" "job2" "No Text herein." (n_day' (-3)) (Just $ n_day' (-1)) (Just jost) (Just svaupel) Nothing (Just qid_f) (Just $ LmsIdent "ijk")
@ -1100,7 +1100,7 @@ fillDb = do
, exceptEnd = TimeOfDay 16 20 0 , exceptEnd = TimeOfDay 16 20 0
} }
, ExceptOccur , ExceptOccur
{ exceptDay = succ $ succ $ secondDay { exceptDay = succ $ succ secondDay
, exceptStart = TimeOfDay 10 12 0 , exceptStart = TimeOfDay 10 12 0
, exceptEnd = TimeOfDay 12 13 0 , exceptEnd = TimeOfDay 12 13 0
} }
@ -1112,7 +1112,7 @@ fillDb = do
, tutorialDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight , tutorialDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight
, tutorialLastChanged = now , tutorialLastChanged = now
, tutorialTutorControlled = True , tutorialTutorControlled = True
, tutorialFirstDay = Just $ succ $ succ $ firstDay , tutorialFirstDay = Just $ succ $ succ firstDay
} }
when (odd tyear) $ when (odd tyear) $
void . insert' $ Exam void . insert' $ Exam