refactor(lms): lms results and blocked processing reworked
This commit is contained in:
Steffen Jost
parent
d1e81c16c6
commit
20af976357
@ -4,7 +4,7 @@ Qualification
|
||||
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
|
||||
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
|
||||
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
|
||||
@ -97,7 +97,7 @@ LmsUser
|
||||
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; 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
|
||||
started UTCTime default=now()
|
||||
received UTCTime Maybe -- last acknowledgement by LMS
|
||||
|
||||
@ -12,7 +12,8 @@ module Handler.Utils.DateTime
|
||||
, getTimeLocale, getDateTimeFormat
|
||||
, getDateTimeFormatter
|
||||
, validDateTimeFormats, dateTimeFormatOptions
|
||||
, addLocalDays, addDiffDays, addMonths
|
||||
, addLocalDays, addDiffDays
|
||||
, addMonths, addMonthsDay
|
||||
, addOneWeek, addWeeks
|
||||
, fromMonths
|
||||
, weeksToAdd
|
||||
@ -271,6 +272,9 @@ addDiffDays = over _utctDay . addGregorianDurationClip
|
||||
addMonths :: Word -> UTCTime -> UTCTime
|
||||
addMonths = addDiffDays . fromMonths
|
||||
|
||||
addMonthsDay :: Word -> Day -> Day
|
||||
addMonthsDay = addGregorianMonthsClip . toInteger
|
||||
|
||||
weeksToAdd :: UTCTime -> UTCTime -> Integer
|
||||
-- ^ Number of weeks needed to add so that first
|
||||
-- time occurs later than second time
|
||||
|
||||
@ -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.Utils as E
|
||||
|
||||
import Handler.Utils.DateTime (fromMonths, addMonths)
|
||||
import Handler.Utils.DateTime
|
||||
import Handler.Utils.LMS (randomLMSIdent, randomLMSpw, maxLmsUserIdentRetries)
|
||||
|
||||
-- import qualified Data.CaseInsensitive as CI
|
||||
|
||||
|
||||
dispatchJobLmsQualificationsEnqueue :: JobHandler UniWorX
|
||||
dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsEnqueue
|
||||
@ -119,15 +121,16 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
|
||||
quali <- getJust qid -- may throw an error, aborting the job
|
||||
case qualificationRefreshWithin quali of
|
||||
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
|
||||
let renewalDate = addGregorianDurationClip renewalPeriod now_day
|
||||
let _renewalDate = addGregorianDurationClip renewalPeriod now_day
|
||||
|
||||
-- CONTINUE HERE: TODO
|
||||
-- select users that need renewal due to success
|
||||
-- CONTINUE HERE: TODO
|
||||
-- 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
|
||||
`E.on` (\(quser E.:& luser) -> quser E.^. QualificationUserUser E.==. luser E.^. LmsUserUser
|
||||
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.&&. 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.&&. 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)
|
||||
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 qid = JobHandlerAtomic act
|
||||
where
|
||||
-- act :: YesodJobDB UniWorX ()
|
||||
act = hoist lift $ do
|
||||
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
|
||||
(luser E.:& lresult) <- E.from $
|
||||
E.table @LmsUser `E.innerJoin` E.table @LmsResult
|
||||
`E.on` (\(luser E.:& lresult) -> luser E.^. LmsUserIdent E.==. lresult E.^. LmsResultIdent
|
||||
E.&&. luser E.^. LmsUserQualification E.==. lresult E.^. LmsResultQualification)
|
||||
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
|
||||
E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners
|
||||
return (luser, lresult)
|
||||
forM_ results $ \(Entity luid luser, Entity lrid lresult) -> do
|
||||
(quser E.:& luser E.:& lresult) <- E.from $
|
||||
E.table @QualificationUser -- table not needed if renewal from lms completion day is used TODO: decide!
|
||||
`E.innerJoin` E.table @LmsUser
|
||||
`E.on` (\(quser E.:& luser) ->
|
||||
luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
|
||||
E.&&. luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification)
|
||||
`E.innerJoin` E.table @LmsResult
|
||||
`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.
|
||||
let lreceived = lmsResultTimestamp lresult
|
||||
newStatus = lmsResultSuccess lresult & LmsSuccess
|
||||
oldStatus = lmsUserStatus luser
|
||||
saneDate = lmsResultSuccess lresult `inBetween` (utctDay $ lmsUserStarted luser, utctDay now)
|
||||
-- always log success, since this is only transmitted once
|
||||
if saneDate
|
||||
then
|
||||
update luid [ LmsUserStatus =. (oldStatus <> Just newStatus)
|
||||
, LmsUserReceived =. Just lreceived
|
||||
let saneDate = lmsResultSuccess `inBetween` (utctDay lmsUserStarted, utctDay now)
|
||||
newStatus = LmsSuccess lmsResultSuccess
|
||||
newValidTo = -- addMonthsDay renewalMonths qualificationUserValidUntil -- renew from old validUntil onwards
|
||||
addMonthsDay renewalMonths lmsResultSuccess -- renew from completion onwards
|
||||
if saneDate && isLmsSuccess newStatus
|
||||
then do
|
||||
update quid [ QualificationUserValidUntil =. newValidTo
|
||||
, QualificationUserLastRefresh =. lmsResultSuccess
|
||||
]
|
||||
update luid [ LmsUserStatus =. Just newStatus
|
||||
, LmsUserReceived =. Just lmsResultTimestamp
|
||||
]
|
||||
else
|
||||
$logErrorS "LmsResult" [st|LMS success with insane date #{tshow (lmsResultSuccess lresult)} received|]
|
||||
insert_ $ LmsAudit qid (lmsUserIdent luser) newStatus lreceived now
|
||||
delete lrid
|
||||
$logInfoS "LmsResult" [st|Processed #{tshow (length results)} LMS results|]
|
||||
$logErrorS "LmsResult" [st|LMS success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent}|]
|
||||
insert_ $ LmsAudit qid lmsUserIdent newStatus lmsResultTimestamp now -- always log success, since this is only transmitted once
|
||||
delete lrid
|
||||
$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 qid = JobHandlerAtomic act
|
||||
where
|
||||
@ -219,7 +227,9 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
|
||||
oldStatus = lmsUserStatus luser
|
||||
update luid [ LmsUserStatus =. (oldStatus <> toMaybe isBlocked newStatus)
|
||||
, 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
|
||||
|
||||
$logInfoS "LmsUserlist" [st|Processed LMS Userlist with ${tshow (length results)} entries|]
|
||||
|
||||
@ -38,6 +38,7 @@ 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!
|
||||
instance Semigroup LmsStatus where
|
||||
a <> b | a >= b = a
|
||||
| otherwise = b
|
||||
|
||||
@ -283,6 +283,10 @@ stripCI = CI.mk . Text.strip
|
||||
citext2lower :: CI Text -> Text
|
||||
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
|
||||
-- This function definition is mainly for documentation purposes
|
||||
text2Html :: Text -> Html
|
||||
|
||||
Loading…
Reference in New Issue
Block a user