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

refactor(lms): lms results and blocked processing reworked

Browse Source
This commit is contained in:
Steffen Jost 2022-09-16 17:01:02 +02:00
parent d1e81c16c6
commit 20af976357
5 changed files with 63 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
models/lms.model
View File

@ -4,7 +4,7 @@ Qualification
shorthand (CI Text) shorthand (CI Text)
name (CI Text) name (CI Text)
description StoredMarkup Maybe -- user-defined large Html, ought to contain full description 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 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 month to keep audit log; or indefinitely
refreshWithin CalendarDiffDays Maybe -- notify users about renewal within this number of month/days before expiry; to be used with addGregorianDurationClip 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 elearningStart Bool -- automatically schedule e-refresher
@ -97,7 +97,7 @@ LmsUser
pin Text pin Text
resetPin Bool default=false -- should pin be reset? resetPin Bool default=false -- should pin be reset?
datePin UTCTime default=now() -- time pin was created datePin UTCTime default=now() -- time pin was created
status LmsStatus Maybe -- open, success or failure; isJust indicates user will 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
started UTCTime default=now() started UTCTime default=now()
received UTCTime Maybe -- last acknowledgement by LMS received UTCTime Maybe -- last acknowledgement by LMS

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

@ -12,7 +12,8 @@ module Handler.Utils.DateTime
, getTimeLocale, getDateTimeFormat , getTimeLocale, getDateTimeFormat
, getDateTimeFormatter , getDateTimeFormatter
, validDateTimeFormats, dateTimeFormatOptions , validDateTimeFormats, dateTimeFormatOptions
, addLocalDays, addDiffDays, addMonths , addLocalDays, addDiffDays
, addMonths, addMonthsDay
, addOneWeek, addWeeks , addOneWeek, addWeeks
, fromMonths , fromMonths
, weeksToAdd , weeksToAdd
@ -271,6 +272,9 @@ addDiffDays = over _utctDay . addGregorianDurationClip
addMonths :: Word -> UTCTime -> UTCTime addMonths :: Word -> UTCTime -> UTCTime
addMonths = addDiffDays . fromMonths addMonths = addDiffDays . fromMonths
addMonthsDay :: Word -> Day -> Day
addMonthsDay = addGregorianMonthsClip . toInteger
weeksToAdd :: UTCTime -> UTCTime -> Integer weeksToAdd :: UTCTime -> UTCTime -> Integer
-- ^ Number of weeks needed to add so that first -- ^ Number of weeks needed to add so that first
-- time occurs later than second time -- time occurs later than second time

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

@ -18,9 +18,11 @@ import qualified Database.Esqueleto.Experimental as E
-- import qualified Database.Esqueleto.PostgreSQL as E -- for insertSelect variant -- import qualified Database.Esqueleto.PostgreSQL as E -- for insertSelect variant
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
import Handler.Utils.DateTime (fromMonths, addMonths) import Handler.Utils.DateTime
import Handler.Utils.LMS (randomLMSIdent, randomLMSpw, maxLmsUserIdentRetries) import Handler.Utils.LMS (randomLMSIdent, randomLMSpw, maxLmsUserIdentRetries)
-- import qualified Data.CaseInsensitive as CI
dispatchJobLmsQualificationsEnqueue :: JobHandler UniWorX dispatchJobLmsQualificationsEnqueue :: JobHandler UniWorX
dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsEnqueue dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsEnqueue
@ -119,15 +121,16 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
quali <- getJust qid -- may throw an error, aborting the job quali <- getJust qid -- may throw an error, aborting the job
case qualificationRefreshWithin quali of case qualificationRefreshWithin quali of
Nothing -> return () -- no automatic scheduling for this qid (usually job is not scheduled for these qualifications, see above) Nothing -> return () -- no automatic scheduling for this qid (usually job is not scheduled for these qualifications, see above)
(Just renewalPeriod) -> do (Just _renewalPeriod) ->
return () -- TODO
{- do
now_day <- utctDay <$> liftIO getCurrentTime now_day <- utctDay <$> liftIO getCurrentTime
let renewalDate = addGregorianDurationClip renewalPeriod now_day let _renewalDate = addGregorianDurationClip renewalPeriod now_day
-- CONTINUE HERE: TODO -- CONTINUE HERE: TODO
-- select users that need renewal due to success
-- delete users after audit period has expired!!! -- delete users after audit period has expired!!!
renewalUsers <- E.select $ do _renewalUsers <- E.select $ do
(quser E.:& luser) <- E.from $ E.table @QualificationUser `E.innerJoin` E.table @LmsUser (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.on` (\(quser E.:& luser) -> quser E.^. QualificationUserUser E.==. luser E.^. LmsUserUser
E.&&. quser E.^. QualificationUserQualification E.==. luser E.^. LmsUserQualification E.&&. quser E.^. QualificationUserQualification E.==. luser E.^. LmsUserQualification
@ -135,56 +138,61 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
E.where_ $ E.val qid E.==. quser E.^. QualificationUserQualification E.where_ $ E.val qid E.==. quser E.^. QualificationUserQualification
E.&&. E.val qid E.==. luser E.^. LmsUserQualification 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 now_day -- still valid
E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate -- due to renewal -- 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 E.&&. E.isJust (luser E.^. LmsUserStatus) -- TODO: should check for success -- result already known
pure (quser, luser) pure (quser, luser)
let usr_job (quser, luser) = -}
let vold = quser ^. _entityVal . _qualificationUserValidUntil
pmonth = fromMonths $ fromMaybe 0 $ qualificationValidDuration quali -- TODO: decide how to deal with qualifications that have infinite validity?!
vnew = addGregorianDurationClip pmonth vold
lmsstatus = luser ^. _entityVal . _lmsUserStatus
in case lmsstatus of
Just (LmsSuccess refreshDay) -> update (quser ^. _entityKey) [QualificationUserValidUntil =. vnew, QualificationUserLastRefresh =. refreshDay]
_ -> return ()
forM_ renewalUsers usr_job
-- just processes received input, but does not affect any exisitng qualifications yet -- processes received results and lengthen qualifications, if applicable
dispatchJobLmsResults :: QualificationId -> JobHandler UniWorX dispatchJobLmsResults :: QualificationId -> JobHandler UniWorX
dispatchJobLmsResults qid = JobHandlerAtomic act dispatchJobLmsResults qid = JobHandlerAtomic act
where where
-- act :: YesodJobDB UniWorX () -- act :: YesodJobDB UniWorX ()
act = hoist lift $ do act = hoist lift $ do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
-- result :: [(Entity LmsUser, Entity LmsResult)] quali <- getJust qid
let renewalMonths :: Word = fromMaybe (error ("Cannot renew qualification " <> citext2string (qualificationShorthand quali) <> " without specified validDuration!"))
(qualificationValidDuration quali)
-- result :: [(Entity QualificationUser, Entity LmsUser, Entity LmsResult)]
results <- E.select $ do results <- E.select $ do
(luser E.:& lresult) <- E.from $ (quser E.:& luser E.:& lresult) <- E.from $
E.table @LmsUser `E.innerJoin` E.table @LmsResult E.table @QualificationUser -- table not needed if renewal from lms completion day is used TODO: decide!
`E.on` (\(luser E.:& lresult) -> luser E.^. LmsUserIdent E.==. lresult E.^. LmsResultIdent `E.innerJoin` E.table @LmsUser
E.&&. luser E.^. LmsUserQualification E.==. lresult E.^. LmsResultQualification) `E.on` (\(quser E.:& luser) ->
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners E.&&. luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification)
return (luser, lresult) `E.innerJoin` E.table @LmsResult
forM_ results $ \(Entity luid luser, Entity lrid lresult) -> do `E.on` (\(_ E.:& luser E.:& lresult) ->
luser E.^. LmsUserIdent E.==. lresult E.^. LmsResultIdent
E.&&. luser E.^. LmsUserQualification E.==. lresult E.^. LmsResultQualification)
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
E.&&. luser E.^. LmsUserQualification E.==. E.val qid
E.&&. E.isNothing (luser E.^. LmsUserStatus) -- do not process learners already having a result
E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners
return (quser, luser, lresult)
forM_ results $ \(Entity quid QualificationUser{}, Entity luid LmsUser{..}, Entity lrid LmsResult{..}) -> do
-- 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 lreceived = lmsResultTimestamp lresult let saneDate = lmsResultSuccess `inBetween` (utctDay lmsUserStarted, utctDay now)
newStatus = lmsResultSuccess lresult & LmsSuccess newStatus = LmsSuccess lmsResultSuccess
oldStatus = lmsUserStatus luser newValidTo = -- addMonthsDay renewalMonths qualificationUserValidUntil -- renew from old validUntil onwards
saneDate = lmsResultSuccess lresult `inBetween` (utctDay $ lmsUserStarted luser, utctDay now) addMonthsDay renewalMonths lmsResultSuccess -- renew from completion onwards
-- always log success, since this is only transmitted once if saneDate && isLmsSuccess newStatus
if saneDate then do
then update quid [ QualificationUserValidUntil =. newValidTo
update luid [ LmsUserStatus =. (oldStatus <> Just newStatus) , QualificationUserLastRefresh =. lmsResultSuccess
, LmsUserReceived =. Just lreceived
] ]
update luid [ LmsUserStatus =. Just newStatus
, LmsUserReceived =. Just lmsResultTimestamp
]
else else
$logErrorS "LmsResult" [st|LMS success with insane date #{tshow (lmsResultSuccess lresult)} received|] $logErrorS "LmsResult" [st|LMS success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent}|]
insert_ $ LmsAudit qid (lmsUserIdent luser) newStatus lreceived now insert_ $ LmsAudit qid lmsUserIdent newStatus lmsResultTimestamp now -- always log success, since this is only transmitted once
delete lrid delete lrid
$logInfoS "LmsResult" [st|Processed #{tshow (length results)} LMS results|] $logInfoS "LmsResult" [st|Processed #{tshow (length results)} LMS results|]
-- just processes received input, but does not affect any exisitng qualifications yet -- processes received input and block qualifications, if applicable
dispatchJobLmsUserlist :: QualificationId -> JobHandler UniWorX dispatchJobLmsUserlist :: QualificationId -> JobHandler UniWorX
dispatchJobLmsUserlist qid = JobHandlerAtomic act dispatchJobLmsUserlist qid = JobHandlerAtomic act
where where
@ -219,7 +227,9 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
oldStatus = lmsUserStatus luser oldStatus = lmsUserStatus luser
update luid [ LmsUserStatus =. (oldStatus <> toMaybe isBlocked newStatus) update luid [ LmsUserStatus =. (oldStatus <> toMaybe isBlocked newStatus)
, LmsUserReceived =. Just lReceived ] , LmsUserReceived =. Just lReceived ]
when isBlocked . insert_ $ LmsAudit qid (lmsUserIdent luser) newStatus lReceived now -- always log blocked when isBlocked $ do
updateBy (UniqueQualificationUser qid (lmsUserUser luser)) [QualificationUserBlockedDue =. Just (QualificationBlockedLms (utctDay lReceived))]
insert_ $ LmsAudit qid (lmsUserIdent luser) newStatus lReceived now -- always log blocked
delete lulid delete lulid
$logInfoS "LmsUserlist" [st|Processed LMS Userlist with ${tshow (length results)} entries|] $logInfoS "LmsUserlist" [st|Processed LMS Userlist with ${tshow (length results)} entries|]

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

@ -38,6 +38,7 @@ isLmsSuccess LmsSuccess{} = True
isLmsSuccess _other = False isLmsSuccess _other = False
-- Entscheidung 08.04.22: LmsSuccess gewinnt immer über LmsBlocked oder umgekehrt; siehe Model.TypesSpec -- 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!
instance Semigroup LmsStatus where instance Semigroup LmsStatus where
a <> b | a >= b = a a <> b | a >= b = a
| otherwise = b | otherwise = b

4
src/Utils.hs
View File

@ -283,6 +283,10 @@ stripCI = CI.mk . Text.strip
citext2lower :: CI Text -> Text citext2lower :: CI Text -> Text
citext2lower = Text.toLower . CI.original citext2lower = Text.toLower . CI.original
-- avoids unnecessary imports
citext2string :: CI Text -> String
citext2string = Text.unpack . CI.original
-- | Convert text as it is to Html, may prevent ambiguous types -- | Convert text as it is to Html, may prevent ambiguous types
-- This function definition is mainly for documentation purposes -- This function definition is mainly for documentation purposes
text2Html :: Text -> Html text2Html :: Text -> Html