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

fix(lms): mark expired learners as ended with status expired

Browse Source
This commit is contained in:
Steffen Jost 2023-03-24 17:32:28 +00:00
parent 3664c1988c
commit db9ffa1830
6 changed files with 42 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
src/Handler/Qualification.hs
View File

@ -380,6 +380,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
getStatusPlusTxt =
(join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case
Just LmsBlocked{} -> return $ Just "Failed"
Just LmsExpired{} -> return $ Just "Expired"
Just LmsSuccess{} -> return $ Just "Success"
Nothing -> maybeM (return Nothing) (const $ return $ Just "Open") $
preview (resultLmsUser . _entityVal . _lmsUserStarted)

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

@ -20,7 +20,7 @@ module Handler.Utils.LMS
, lmsDeletionDate
, lmsUserToDelete, _lmsUserToDelete
, lmsUserToDeleteExpr
, lmsUserStatusWidget
, lmsStatusIcon, lmsUserStatusWidget
, randomLMSIdent, randomLMSIdentBut
, randomLMSpw, maxLmsUserIdentRetries
) where
@ -164,12 +164,16 @@ randomLMSpw = randomText extra lengthPassword
where
extra = "+=!?" -- you cannot distinguish ;: and ., in printed letters
lmsStatusIcon :: LmsStatus -> Icon
lmsStatusIcon LmsSuccess{} = IconOK
lmsStatusIcon LmsExpired{} = IconExpired
lmsStatusIcon _other = IconNotOK
lmsUserStatusWidget :: LmsUser -> Widget
lmsUserStatusWidget LmsUser{lmsUserStatus=Just lStat} =
[whamlet|$newline never
^{formatTimeW SelFormatDate (lmsStatusDay lStat)}
\ ^{boolSymbol (isLmsSuccess lStat)}
\ ^{icon (lmsStatusIcon lStat)}
|]
lmsUserStatusWidget LmsUser{lmsUserStarted} =
[whamlet|$newline never

7
src/Handler/Utils/Table/Cells.hs
View File

@ -12,7 +12,7 @@ import Handler.Utils.Table.Pagination
import Handler.Utils.DateTime
import Handler.Utils.Widgets
import Handler.Utils.Occurrences
import Handler.Utils.LMS (lmsUserStatusWidget)
import Handler.Utils.LMS (lmsUserStatusWidget, lmsStatusIcon)
type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with WithHoles !
@ -347,10 +347,7 @@ cryptoidCell :: (IsDBTable m a, PathPiece cid) => cid -> DBCell m a
cryptoidCell = addCellClass ("cryptoid" :: Text) . textCell . toPathPiece
lmsStatusCell :: IsDBTable m a => LmsStatus -> DBCell m a
lmsStatusCell ls = iconCell ic <> spacerCell <> dayCell (lmsStatusDay ls)
where
ic | isLmsSuccess ls = IconOK
| otherwise = IconNotOK
lmsStatusCell ls = iconCell (lmsStatusIcon ls) <> spacerCell <> dayCell (lmsStatusDay ls)
lmsStatusPlusCell :: IsDBTable m a => LmsUser -> DBCell m a
lmsStatusPlusCell LmsUser{lmsUserStatus=Just lStat} = lmsStatusCell lStat

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

@ -77,6 +77,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
luser <- E.from $ E.table @LmsUser
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
E.&&. E.isNothing (luser E.^. LmsUserEnded)
)
pure quser
let usr_job :: Entity QualificationUser -> Job
@ -131,7 +132,7 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
(Just _) -> return () -- lmsUser started, but not yet notified
-- purge LmsIdent adter QualificationAuditDuration expired
-- purge LmsIdent after QualificationAuditDuration expired
dispatchJobLmsDequeue :: QualificationId -> JobHandler UniWorX
dispatchJobLmsDequeue qid = JobHandlerAtomic act
where
@ -140,19 +141,37 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
let qshort = CI.original $ qualificationShorthand quali
$logInfoS "LMS" $ "Processing e-learning results for qualification " <> qshort
now <- liftIO getCurrentTime
let nowaday = utctDay now
-- end users that expired by doing nothing
expiredLearners <- E.select $ do
(quser :& luser) <- E.from $
E.table @QualificationUser
`E.innerJoin` E.table @LmsUser
`E.on` (\(quser :& luser) ->
luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
E.&&. luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification)
E.where_ $ E.isNothing (luser E.^. LmsUserStatus)
E.&&. E.isNothing (luser E.^. LmsUserEnded)
E.&&. E.not_ (validQualification nowaday quser)
pure (luser E.^. LmsUserId)
nrExpired <- E.updateCount $ \luser -> do
E.set luser [LmsUserStatus E.=. E.justVal (LmsExpired nowaday)]
E.where_ $ (luser E.^. LmsUserId) `E.in_` E.valList (E.unValue <$> expiredLearners)
$logInfoS "LMS" $ "Expired lms users " <> tshow nrExpired <> " for qualification " <> qshort
-- TODO: notify expired used
-- let nowaday = utctDay now
-- forM_ (E.unValue . snd <$> delusersVals) $ \uid ->
--
-- forM_ expiredLearners $ \uid ->
-- queueDBJob JobSendNotification
-- { jRecipient = uid
-- , jNotification = NotificationQualificationExpired { nQualification = qid, nExpiry = nowaday }
-- }
-- purge outdated LmsUsers
case qualificationAuditDuration quali of
Nothing -> return () -- no automatic removal
(Just auditDuration) -> do
let auditCutoff = addDiffDaysRollOver (fromMonths $ negate auditDuration) now
$logInfoS "LMS" $ "Audit Cuttoff at " <> tshow auditCutoff <> " for Audit Duration " <> tshow auditDuration
$logInfoS "LMS" $ "Audit Cuttoff at " <> tshow auditCutoff <> " for Audit Duration " <> tshow auditDuration <> " for qualification " <> qshort
delusersVals <- E.select $ do
luser <- E.from $ E.table @LmsUser
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid

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

@ -34,7 +34,8 @@ 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?
-- ...also see similar type QualificationBlocked
data LmsStatus = LmsBlocked { lmsStatusDay :: Day }
data LmsStatus = LmsBlocked { lmsStatusDay :: Day }
| LmsExpired { lmsStatusDay :: Day }
| LmsSuccess { lmsStatusDay :: Day }
deriving (Eq, Read, Show, Generic, NFData)
@ -43,7 +44,11 @@ instance Ord LmsStatus where
| daycmp <- compare (lmsStatusDay a) (lmsStatusDay b)
, daycmp /= EQ = daycmp
compare LmsSuccess{} LmsBlocked{} = GT
compare LmsBlocked{} LmsSuccess{} = LT
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
@ -66,6 +71,7 @@ derivePersistFieldJSON ''LmsStatus
instance Csv.ToField LmsStatus where
toField (LmsBlocked d) = "Failure: " <> Csv.toField d
toField (LmsExpired d) = "Expired: " <> Csv.toField d
toField (LmsSuccess d) = "Success: " <> Csv.toField d
data QualificationBlocked = QualificationBlocked { qualificationBlockedDay :: Day

2
src/Utils/Icon.hs
View File

@ -107,6 +107,7 @@ data Icon
| IconAt
| IconSupervisor
| IconWaitingForUser
| IconExpired
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
deriving anyclass (Universe, Finite, NFData)
@ -192,6 +193,7 @@ iconText = \case
IconAt -> "at"
IconSupervisor -> "head-side" -- must be notably different to user
IconWaitingForUser -> "user-cog" -- Waiting on a user to do something
IconExpired -> "hourglass-end"
nullaryPathPiece ''Icon $ camelToPathPiece' 1
deriveLift ''Icon