chore(lms): proper lms dequeueing now implemented; whole process checked
This commit is contained in:
Steffen Jost
parent
86fd7423b8
commit
157d2f7970
@ -1,11 +1,11 @@
|
||||
Qualification
|
||||
-- INVARIANT: 2*refreshWithin < validDuration
|
||||
-- INVARIANT: 2*refreshWithin < validDuration
|
||||
school SchoolId --TODO: Ansprechpartner der Schule in Briefe erwähnen
|
||||
shorthand (CI Text)
|
||||
name (CI Text)
|
||||
description StoredMarkup Maybe -- user-defined large Html, ought to contain full description
|
||||
validDuration Word Maybe -- qualification is valid indefinitely or for a specified number of months, use with addMonthsDay
|
||||
auditDuration Word Maybe -- number of month to keep audit log; or indefinitely
|
||||
auditDuration Word Maybe -- number of months to keep audit log and LmsUserIdents; or indefinitely (dangerous, since LmsIdents may run out)
|
||||
refreshWithin CalendarDiffDays Maybe -- notify users about renewal within this number of month/days before expiry; to be used with addGregorianDurationClip
|
||||
elearningStart Bool -- automatically schedule e-refresher
|
||||
-- elearningOnly Bool -- successful E-learing automatically increases validity. NO!
|
||||
@ -18,9 +18,9 @@ Qualification
|
||||
-- TODOs:
|
||||
-- - Enstehen Kosten, wenn Teilnehmer für KnowHow eingereiht werden, aber nicht am Kurs teilnehmen?
|
||||
-- Falls ja, so sollte bei automatischem refresher vorher der Kunde durch FRADrive befragt werden?!
|
||||
-- A: Der Inhaber per Email informieren!
|
||||
-- A: Der Inhaber per Email informieren!
|
||||
-- A: Es kann gleich eine LMS Pin generiert und verschickt werden!
|
||||
-- - Aufteilung Qualification "R" in zwei Teile: "R e-learning" und "R praxis" okay?
|
||||
-- - Aufteilung Qualification "R" in zwei Teile: "R e-learning" und "R praxis" okay?
|
||||
|
||||
-- Besonderheiten:
|
||||
-- - LmsIdent muss für alle Qualificationen einzigartig sein!
|
||||
@ -33,7 +33,7 @@ Qualification
|
||||
|
||||
QualificationPrecondition
|
||||
qualification QualificationId OnDeleteCascade OnUpdateCascade -- AND: not unique, ie. qualification can have multiple required preconditions
|
||||
required [QualificationId] -- OR : alternatives, any one will suffice
|
||||
required [QualificationId] -- OR : alternatives, any one will suffice
|
||||
continuous Bool -- expiring precondition removes qualification
|
||||
deriving Generic
|
||||
|
||||
@ -53,17 +53,17 @@ QualificationUser
|
||||
firstHeld Day -- first time the qualification was earned, should never change
|
||||
blockedDue QualificationBlocked Maybe -- isJust means that the qualification is currently revoked
|
||||
-- temporärer Entzug vorsehen
|
||||
-- Begründungsfeld vorsehen
|
||||
-- Begründungsfeld vorsehen
|
||||
UniqueQualificationUser qualification user
|
||||
deriving Generic
|
||||
|
||||
-- LMS Interface Tables, need regular processing by background jobs, per QualificationId:
|
||||
--
|
||||
-- 1. Daily Job: Add to LmsUser daily all qualification holders with
|
||||
-- QualificationUserValidUntil >= now
|
||||
--
|
||||
-- 1. Daily Job: Add to LmsUser daily all qualification holders with
|
||||
-- QualificationUserValidUntil >= now
|
||||
-- /\ QualificationUserValudUntil <= now + QualificationRefreshWithin (time to schedule refresher)
|
||||
-- /\ not already enlisted
|
||||
--
|
||||
-- /\ not already enlisted
|
||||
--
|
||||
-- 2. REST GET User.csv:
|
||||
-- - where LmsUserReceived == Nothing \/ (LmsUserResetPin /\ LmsUserEnded == Nothing)
|
||||
-- - delete-flag: isJust LmsUserStatus
|
||||
@ -77,60 +77,61 @@ QualificationUser
|
||||
-- - For all LmsUser:
|
||||
-- + if contained:
|
||||
-- set LmsUserReceived to Just now()
|
||||
-- if LmsUserlistFailed: set LmsUserStatus to Just Day
|
||||
-- if LmsUserlistFailed: set LmsUserStatus to Just LmsBlocked now
|
||||
-- + not contained, by LmsUserReceived is set: set LmsUserEnded to Just now()
|
||||
-- - move row to LmsAudit
|
||||
--
|
||||
-- 6. When received: Daily Job LmsResult:
|
||||
-- - set LmsUserReceived to Just now()
|
||||
-- - set LmsUserStatus to Just Day -- always
|
||||
-- - set LmsUserReceived to Just now() -- always
|
||||
-- - set LmsUserStatus to Just LmsSuccess now -- conditional
|
||||
-- - and renew QualificationValidTo
|
||||
-- - move row to LmsAudit
|
||||
--
|
||||
-- 7. Daily Job: dequeue LMS Users
|
||||
-- - renew qualification, if passed
|
||||
-- - remove from LmsUser after audit Period has passed
|
||||
|
||||
LmsUser
|
||||
qualification QualificationId OnDeleteCascade OnUpdateCascade
|
||||
user UserId OnDeleteCascade OnUpdateCascade
|
||||
ident LmsIdent -- must be unique accross all LMS courses!
|
||||
user UserId OnDeleteCascade OnUpdateCascade
|
||||
ident LmsIdent -- must be unique accross all LMS courses!
|
||||
pin Text
|
||||
resetPin Bool default=false -- should pin be reset?
|
||||
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
|
||||
resetPin Bool default=false -- should pin be reset?
|
||||
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
|
||||
--toDelete encoded by Handler.Utils.LMS.lmsUserToDelete
|
||||
started UTCTime default=now()
|
||||
received UTCTime Maybe -- last acknowledgement by LMS
|
||||
notified UTCTime Maybe -- last notified by FRADrive
|
||||
ended UTCTime Maybe -- ident was deleted from LMS
|
||||
started UTCTime default=now()
|
||||
received UTCTime Maybe -- last acknowledgement by LMS
|
||||
notified UTCTime Maybe -- last notified by FRADrive
|
||||
ended UTCTime Maybe -- ident was deleted from LMS
|
||||
-- Primary ident -- newtype Key LmsUserId = LmsUserKey { unLmsUser :: Text } -- change LmsIdent -> Text. Do we want this?
|
||||
UniqueLmsIdent ident -- idents must be unique accross all qualifications, since idents are global within LMS!
|
||||
UniqueLmsQualificationUser qualification user -- each user may be enrolled at most once per course
|
||||
UniqueLmsIdent ident -- idents must be unique accross all qualifications, since idents are global within LMS!
|
||||
UniqueLmsQualificationUser qualification user -- each user may be enrolled at most once per course
|
||||
deriving Generic
|
||||
|
||||
-- LmsUserlist stores LMS upload for later processing only
|
||||
-- LmsUserlist stores LMS upload for later processing only
|
||||
LmsUserlist
|
||||
qualification QualificationId OnDeleteCascade OnUpdateCascade
|
||||
ident LmsIdent
|
||||
qualification QualificationId OnDeleteCascade OnUpdateCascade
|
||||
ident LmsIdent
|
||||
failed Bool
|
||||
timestamp UTCTime default=now()
|
||||
timestamp UTCTime default=now()
|
||||
UniqueLmsUserlist qualification ident
|
||||
deriving Generic
|
||||
|
||||
-- LmsResult stores LMS upload for later processing only
|
||||
-- LmsResult stores LMS upload for later processing only
|
||||
LmsResult
|
||||
qualification QualificationId OnDeleteCascade OnUpdateCascade
|
||||
ident LmsIdent
|
||||
ident LmsIdent
|
||||
success Day
|
||||
timestamp UTCTime default=now()
|
||||
timestamp UTCTime default=now()
|
||||
UniqueLmsResult qualification ident -- required by DBTable
|
||||
deriving Generic
|
||||
|
||||
-- Logs all processed rows from LmsUserlist and LmsResult
|
||||
LmsAudit
|
||||
LmsAudit
|
||||
qualification QualificationId OnDeleteCascade OnUpdateCascade
|
||||
ident LmsIdent
|
||||
notificationType LmsStatus -- LmsBlocked Day | LmsSuccess Day
|
||||
notificationType LmsStatus -- LmsBlocked Day | LmsSuccess Day
|
||||
note Text Maybe
|
||||
received UTCTime -- timestamp from LmsUserlist/LmsResult
|
||||
processed UTCTime default=now()
|
||||
processed UTCTime default=now()
|
||||
deriving Generic
|
||||
|
||||
@ -274,8 +274,8 @@ postLmsResultDirectR sid qsh = do
|
||||
return (badRequest400, "Exception: " <> tshow e)
|
||||
Right nr -> do
|
||||
let msg = "Success. LMS Result upload file " <> fileName file <> " containing " <> tshow nr <> " rows for header " <> fhead
|
||||
$logWarnS "LMS" msg -- TODO: change to Info Level in the future
|
||||
queueDBJob $ JobLmsResults qid
|
||||
$logInfoS "LMS" msg
|
||||
when (nr > 0) $ queueDBJob $ JobLmsResults qid
|
||||
return (ok200, msg)
|
||||
[] -> do
|
||||
let msg = "Result upload file missing."
|
||||
|
||||
@ -270,8 +270,8 @@ postLmsUserlistDirectR sid qsh = do
|
||||
return (badRequest400, "Exception: " <> tshow e)
|
||||
Right nr -> do
|
||||
let msg = "Success. LMS Userlist upload file " <> fileName file <> " containing " <> tshow nr <> " rows for header " <> fhead
|
||||
$logWarnS "LMS" msg -- TODO: change to Info Level in the future
|
||||
queueDBJob $ JobLmsUserlist qid
|
||||
$logInfoS "LMS" msg
|
||||
when (nr > 0) $ queueDBJob $ JobLmsUserlist qid
|
||||
return (ok200, msg)
|
||||
[] -> do
|
||||
let msg = "Userlist upload file missing."
|
||||
|
||||
@ -12,10 +12,10 @@ module Handler.Utils.DateTime
|
||||
, getTimeLocale, getDateTimeFormat
|
||||
, getDateTimeFormatter
|
||||
, validDateTimeFormats, dateTimeFormatOptions
|
||||
, addLocalDays, addDiffDays
|
||||
, addMonths, addMonthsDay
|
||||
, addLocalDays
|
||||
, addDiffDaysClip, addDiffDaysRollOver
|
||||
, addOneWeek, addWeeks
|
||||
, fromMonths
|
||||
, fromDays, fromMonths
|
||||
, weeksToAdd
|
||||
, setYear, getYear
|
||||
, firstDayOfWeekOnAfter
|
||||
@ -265,18 +265,17 @@ addLocalDays n utct = localTimeToUTCTZ appTZ newLocal
|
||||
-- CalendarDiffDays --
|
||||
----------------------
|
||||
|
||||
fromMonths :: Word -> CalendarDiffDays
|
||||
fromMonths m = scaleCalendarDiffDays (toInteger m) calendarMonth
|
||||
-- fromMonths m = CalendarDiffDays { cdMonths = m, cdDays = 0 } -- above is equivalent
|
||||
fromMonths :: Integral a => a -> CalendarDiffDays
|
||||
fromMonths (toInteger -> m) = CalendarDiffDays { cdMonths = m, cdDays = 0 } -- above is equivalent
|
||||
|
||||
addDiffDays :: CalendarDiffDays -> UTCTime -> UTCTime
|
||||
addDiffDays = over _utctDay . addGregorianDurationClip
|
||||
fromDays :: Integral a => a -> CalendarDiffDays
|
||||
fromDays (toInteger -> d) = CalendarDiffDays { cdMonths = 0, cdDays = d }
|
||||
|
||||
addMonths :: Word -> UTCTime -> UTCTime
|
||||
addMonths = addDiffDays . fromMonths
|
||||
addDiffDaysClip :: CalendarDiffDays -> UTCTime -> UTCTime
|
||||
addDiffDaysClip = over _utctDay . addGregorianDurationClip
|
||||
|
||||
addMonthsDay :: Word -> Day -> Day
|
||||
addMonthsDay = addGregorianMonthsClip . toInteger
|
||||
addDiffDaysRollOver :: CalendarDiffDays -> UTCTime -> UTCTime
|
||||
addDiffDaysRollOver = over _utctDay . addGregorianDurationRollOver
|
||||
|
||||
weeksToAdd :: UTCTime -> UTCTime -> Integer
|
||||
-- ^ Number of weeks needed to add so that first
|
||||
|
||||
@ -21,7 +21,7 @@ import qualified Database.Esqueleto.Utils as E
|
||||
import Handler.Utils.DateTime
|
||||
import Handler.Utils.LMS (randomLMSIdent, randomLMSpw, maxLmsUserIdentRetries)
|
||||
|
||||
-- import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
|
||||
dispatchJobLmsQualificationsEnqueue :: JobHandler UniWorX
|
||||
@ -47,9 +47,10 @@ dispatchJobLmsEnqueue :: QualificationId -> JobHandler UniWorX
|
||||
dispatchJobLmsEnqueue qid = JobHandlerAtomic act
|
||||
where
|
||||
-- act :: YesodJobDB UniWorX ()
|
||||
act = do
|
||||
$logInfoS "lms" $ "Notifying about exipiring qualification " <> tshow qid <> "."
|
||||
act = do
|
||||
quali <- getJust qid -- may throw an error, aborting the job
|
||||
let qshort = CI.original $ qualificationShorthand quali
|
||||
$logInfoS "lms" $ "Notifying about exipiring qualification " <> qshort
|
||||
now <- liftIO getCurrentTime
|
||||
case qualificationRefreshWithin quali of
|
||||
Nothing -> return () -- no automatic scheduling for this qid
|
||||
@ -101,95 +102,45 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
|
||||
startLmsUser = E.insertUniqueEntity =<< (mkLmsUser <$> randomLMSIdent <*> randomLMSpw)
|
||||
inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser
|
||||
case inserted of
|
||||
Nothing -> $logErrorS "LMS" $ "Generating and inserting fresh LmsIdent failed for uid " <> tshow uid <> " and qid " <> tshow qid <> "!"
|
||||
Nothing -> do
|
||||
uuid :: CryptoUUIDUser <- encrypt uid
|
||||
$logErrorS "LMS" $ "Generating and inserting fresh LmsIdent failed for uuid " <> tshow uuid <> " and qid " <> tshow qid <> "!"
|
||||
(Just _) -> return () -- lmsUser started, but not yet notified
|
||||
|
||||
|
||||
-- process all received input and renew or block qualifications
|
||||
-- purge LmsIdent adter QualificationAuditDuration expired
|
||||
dispatchJobLmsDequeue :: QualificationId -> JobHandler UniWorX
|
||||
dispatchJobLmsDequeue qid = JobHandlerAtomic act
|
||||
-- wenn Aufbewahrungszeit abgelaufen: LmsIdent löschen (verhindert verfrühten neustart)
|
||||
dispatchJobLmsDequeue qid = JobHandlerAtomic act
|
||||
where
|
||||
act = do
|
||||
$logInfoS "lms" $ "Processing e-learning results for qualification " <> tshow qid <> "."
|
||||
act = do
|
||||
quali <- getJust qid -- may throw an error, aborting the job
|
||||
let qshort = CI.original $ qualificationShorthand quali
|
||||
$logInfoS "lms" $ "Processing e-learning results for qualification " <> qshort
|
||||
now <- liftIO getCurrentTime
|
||||
-- purge LmsUsers
|
||||
case qualificationAuditDuration quali of
|
||||
Nothing -> return () -- no automatic removal
|
||||
(Just auditDuration) ->
|
||||
let auditCutoff = addDiffDaysRollover (fromMonths $ negate auditDuration) now
|
||||
delusers <- fmap E.unValue $ E.select $ do
|
||||
(Just auditDuration) -> do
|
||||
let auditCutoff = addDiffDaysRollOver (fromMonths $ negate auditDuration) now
|
||||
delusersVals <- E.select $ do
|
||||
luser <- E.from $ E.table @LmsUser
|
||||
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
|
||||
E.&&. luser E.^. LmsUserEnded E.<. E.just (E.val auditCutoff)
|
||||
E.&&. E.isJust (luser E.^. LmsUserEnded)
|
||||
E.&&. E.notExists (do
|
||||
audit <- E.from $ E.table @LmsAudit
|
||||
E.where_ $ audit E.^. LmsAuditQualification E.==. E.val qid
|
||||
E.&&. audit E.^. LmsAuditIdent E.==. luser E.^. LmsUserIdent
|
||||
E.&&. audit E.^. LmsAuditProcessed E.>=. E.val auditCutoff
|
||||
laudit <- E.from $ E.table @LmsAudit
|
||||
E.where_ $ laudit E.^. LmsAuditQualification E.==. E.val qid
|
||||
E.&&. laudit E.^. LmsAuditIdent E.==. luser E.^. LmsUserIdent
|
||||
E.&&. laudit E.^. LmsAuditProcessed E.>=. E.val auditCutoff
|
||||
)
|
||||
pure (luser E.^. LmsUserIdent)
|
||||
let numdel = length delusers
|
||||
delusers = E.unValue <$> delusersVals
|
||||
when (numdel > 0) $ $logInfoS "lms" $ "Deleting " <> tshow numdel <> " LmsIdents due to audit duration expiry for qualification " <> qshort
|
||||
deleteWhere [LmsUserQualification ==. qid, LmsUserIdent <-. delusers]
|
||||
deleteWhere [LmsUserlistQualification ==. qid, LmsUserlistIdent <-. delusers]
|
||||
deleteWhere [LmsResult ==. qid, LmsResultIdent <-. delusers]
|
||||
deleteWhere [LmsAudit ==. qid, LmsAuditIdent <-. delusers]
|
||||
|
||||
|
||||
|
||||
deleteWhere [LmsUserQualification ==. qid, LmsUserEnded !=. Nothing, LmsUserEnded <. Just lmsCutoff]
|
||||
-- purge LmsAudit
|
||||
|
||||
in E.delete $ do
|
||||
audit <- E.from $ E.table @LmsAudit
|
||||
E.where_ $ audit E.^. LmsAuditQualification E.==. E.val qid
|
||||
E.&&. E.notExists (do
|
||||
luser <- E.from $ E.table @LmsUser
|
||||
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
|
||||
E.&&. luser E.^. LmsUserIdent E.==. audit E.^. LmsAuditIdent
|
||||
)
|
||||
E.groupBy $ audit E.^. LmsAuditIdent
|
||||
E.having $ E.val auditCutoff E.<. E.max_ (audit E.^. LmsAuditProcessed)
|
||||
|
||||
|
||||
|
||||
in deleteWhere [LmsAuditQualification ==. qid, LmsAuditProcessed >. Just deleteDate]
|
||||
|
||||
|
||||
|
||||
let auditCutoff =
|
||||
|
||||
nowadayP1 = succ $ utctDay now -- add one day to account for time synch problems
|
||||
renewalMonths :: Word = fromMaybe (error ("Cannot renew qualification " <> citext2string (qualificationShorthand quali) <> " without specified validDuration!"))
|
||||
(qualificationValidDuration quali)
|
||||
|
||||
|
||||
case qualificationRefreshWithin quali of
|
||||
Nothing -> return () -- no automatic deletion
|
||||
(Just auditDuration) ->
|
||||
return () -- TODO
|
||||
|
||||
deleteWhere [LmsUserEnded >. ]
|
||||
{- do
|
||||
now_day <- utctDay <$> liftIO getCurrentTime
|
||||
let _renewalDate = addGregorianDurationClip renewalPeriod now_day
|
||||
|
||||
-- CONTINUE HERE: TODO
|
||||
-- delete users after audit period has expired!!!
|
||||
|
||||
_renewalUsers <- E.select $ do
|
||||
(quser E.:& luser) <- E.from $ E.table @QualificationUser `E.innerJoin` E.table @LmsUser
|
||||
`E.on` (\(quser E.:& luser) -> quser E.^. QualificationUserUser E.==. luser E.^. LmsUserUser
|
||||
E.&&. quser E.^. QualificationUserQualification E.==. luser E.^. LmsUserQualification
|
||||
)
|
||||
E.where_ $ E.val qid E.==. quser E.^. QualificationUserQualification
|
||||
E.&&. E.val qid E.==. luser E.^. LmsUserQualification
|
||||
E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val now_day -- still valid
|
||||
-- E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate -- due to renewal
|
||||
E.&&. E.isJust (luser E.^. LmsUserStatus) -- TODO: should check for success -- result already known
|
||||
pure (quser, luser)
|
||||
-}
|
||||
deleteWhere [LmsResultQualification ==. qid, LmsResultIdent <-. delusers]
|
||||
deleteWhere [LmsAuditQualification ==. qid, LmsAuditIdent <-. delusers]
|
||||
|
||||
|
||||
-- processes received results and lengthen qualifications, if applicable
|
||||
@ -226,7 +177,7 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
|
||||
saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil nowadayP1)
|
||||
&& qualificationUserLastRefresh <= lmsUserStartedDay
|
||||
newStatus = LmsSuccess lmsResultSuccess
|
||||
newValidTo = addGregorianMonthsRollover (toIntger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards
|
||||
newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards
|
||||
note <- if saneDate && isLmsSuccess newStatus
|
||||
then do
|
||||
update quid [ QualificationUserValidUntil =. newValidTo
|
||||
|
||||
@ -59,7 +59,7 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
|
||||
let entRecipient = Entity jRecipient recipient
|
||||
qname = CI.original qualificationName
|
||||
|
||||
$logDebugS "LMS" $ "Notify " <> tshow encRecipient <> " for renewal of qualification " <> qname
|
||||
$logInfoS "LMS" $ "Notify " <> tshow encRecipient <> " for renewal of qualification " <> qname
|
||||
|
||||
now <- liftIO getCurrentTime
|
||||
letterDate <- formatTimeUser SelFormatDate now $ Just entRecipient
|
||||
|
||||
@ -31,17 +31,23 @@ deriveJSON defaultOptions
|
||||
-- ...also see similar type QualificationBlocked
|
||||
data LmsStatus = LmsBlocked { lmsStatusDay :: Day }
|
||||
| LmsSuccess { lmsStatusDay :: Day }
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable, NFData)
|
||||
deriving (Eq, Read, Show, Generic, Typeable, NFData)
|
||||
|
||||
instance Ord LmsStatus where
|
||||
compare a b
|
||||
| daycmp <- compare (lmsStatusDay a) (lmsStatusDay b)
|
||||
, daycmp /= EQ = daycmp
|
||||
compare LmsSuccess{} LmsBlocked{} = GT
|
||||
compare LmsBlocked{} LmsSuccess{} = LT
|
||||
compare _ _ = EQ
|
||||
|
||||
isLmsSuccess :: LmsStatus -> Bool
|
||||
isLmsSuccess LmsSuccess{} = True
|
||||
isLmsSuccess _other = False
|
||||
|
||||
-- Entscheidung 08.04.22: LmsSuccess gewinnt immer über LmsBlocked oder umgekehrt; siehe Model.TypesSpec
|
||||
-- Entscheidung 16.09.22: Es gewinnt was zuerst gemeldet wurde. Das verhindert, dass eine Qualifikation doppelt verlängert wird!
|
||||
-- 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 | a >= b = a
|
||||
| otherwise = b
|
||||
a <> b = min a b -- earliest date, otherwise LmsBlocked before LmsSuccess
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece' 1 -- remove lms from constructor, since the object is tagged with lms already
|
||||
|
||||
@ -620,10 +620,8 @@ spec = do
|
||||
showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 1, byDeficit = 0 } CorrectorMissing `shouldBe` "[1.0 - D]"
|
||||
showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 1, byDeficit = 0 } CorrectorExcused `shouldBe` "{1.0 - D}"
|
||||
describe "Semigroup LmsStatus" $ do
|
||||
it "LmsSuccess supersedes LmsBlocked" . property $
|
||||
\p1 p2 -> (isLmsSuccess p1 || isLmsSuccess p2) == isLmsSuccess (p1 <> p2)
|
||||
it "lmsStatusDay merges to latest" . property $
|
||||
\p1 p2 -> (isLmsSuccess p1 == isLmsSuccess p2) ==> lmsStatusDay (p1 <> p2) == max (lmsStatusDay p1) (lmsStatusDay p2)
|
||||
it "lmsStatusDay merges to earliest" . property $
|
||||
\p1 p2 -> lmsStatusDay (p1 <> p2) == min (lmsStatusDay p1) (lmsStatusDay p2)
|
||||
|
||||
|
||||
termExample :: (TermIdentifier, Text) -> Expectation
|
||||
|
||||
Loading…
Reference in New Issue
Block a user