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

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)

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

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)
+lmsStatusCell ls = iconCell (lmsStatusIcon ls) <> spacerCell <> dayCell (lmsStatusDay ls)
-  where 
-    ic | isLmsSuccess ls = IconOK
-       | otherwise       = IconNotOK
 
 lmsStatusPlusCell :: IsDBTable m a => LmsUser -> DBCell m a
 lmsStatusPlusCell LmsUser{lmsUserStatus=Just lStat} = lmsStatusCell lStat

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

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

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