diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index e75457de9..d6308e771 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -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) diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index 7a9483779..05c410486 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -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 diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index b01fa44f9..374f92844 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -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 diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index cc5b17ff2..1368ba81b 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -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 diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index 279173b65..3563d252c 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -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 diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 41ae7e335..ce035510f 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -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