chore(lms): fix #2605

- Implement a mechanism that deletes those users after a short while
- Never delete numerical LMS logins
- Allow admins to terminate an E-Learning manually
- Option to terminate E-Learning upon longtime renewal
- Detection of unnecessary E-Learning (i.e. long valid durations)

messages/uniworx/categories/qualification/de-de-formal.msg

@@ -120,7 +120,7 @@ QualificationActBlock: Entziehen
 QualificationActUnblock: Entzug aufheben
 QualificationActRenew: Qualifikation regulär verlängern
 QualificationActGrant: Qualifikation vergeben
-QualificationActGrantWarning: Diese Funktion ist nur für seltene Ausnahmefälle vorgesehen! Ein Entzug wird ggf. aufgehoben.
+QualificationActGrantWarning: Diese Funktion ist nur für seltene Ausnahmefälle vorgesehen! Ein Entzug wird ggf. aufgehoben; E‑Learning wird ggf. beendet.
 QualificationActStartELearning: E‑Learning für gültige Inhaber (neu) starten
 QualificationActStartELearningStatus l@QualificationShorthand n@Int m@Int: E‑Learning #{l} für #{n}/#{m} Teilnehmer (neu) gestartet. Hinweis: Es kann länger dauern, bis das LMS tatsächlich startet.
 QualificationStatusBlock   l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} entzogen
@@ -142,6 +142,7 @@ LmsActRestartUnblock: Entzug ggf. aufheben
 LmsActTerminate: E‑Learning abbrechen
 LmsActTerminateInfo: Ein späterer automatischer Neustart des E‑Learning wird dadurch nicht verhindert, wenn eine gültige Qualifikation bald abläuft und E‑Learning für diese Qualifikation generell automatisch startet.
 LmsActTerminateFeedback n@Int m@Int: #{n}/#{m} E‑Learning Nutzer wurden zur Löschung freigegeben. 
+LmsActTerminated n@Int: E‑Learning für #{n} Nutzer wurde beendet.
 LmsActTerminateWarning: ACHTUNG: Ein Ergebnis würde ohne Warnung verworfen, sollte ein Nutzer sein E‑Learning absolvieren, bevor die Löschung beim E‑learning Server effektiv wurde.
 LmsStateOpen: E‑Learning offen
 LmsStatusLocked: E‑Learning gesperrt, wird ggf. bald geöffnet

messages/uniworx/categories/qualification/en-eu.msg

@@ -120,7 +120,7 @@ QualificationActBlock: Revoke
 QualificationActUnblock: Clear revocation
 QualificationActRenew: Renew qualification
 QualificationActGrant: Grant qualification
-QualificationActGrantWarning: Use with caution in rare exceptional cases only! Any revocation will be undone.
+QualificationActGrantWarning: Use with caution in rare exceptional cases only! Any revocation will be undone; any e‑learning terminated
 QualificationActStartELearning: Manually (re)start e‑learning for valid qualification holders
 QualificationActStartELearningStatus l n m: E‑learning #{l} (re)started for #{n}/#{m} users. Note: It may take a while, until the e‑learning is activated.
 QualificationStatusBlock   l n m: #{n}/#{m} #{l} revoked
@@ -142,6 +142,7 @@ LmsActRestartFeedback n m: #{n}/#{m} e-learnings were completely restarted with
 LmsActTerminate: Abort e‑learning
 LmsActTerminateInfo: E‑learning may restart later, if a valid qualification is about to expire and e-learning starting automatically for this qualification.
 LmsActTerminateFeedback n m: #{n}/#{m} e‑learnings marked for termination.
+LmsActTerminated n: #{n} e‑learnings were terminated. 
 LmsActTerminateWarning: WARNING: Results will be discarded without warning if a user completes their e-learning in the meantime, before the deletion became effective on the e‑learning server.
 LmsStateOpen: E‑learning open
 LmsStatusLocked: E‑learning locked, may be opened soon

src/Handler/LMS.hs

@@ -16,7 +16,7 @@ module Handler.LMS
   , getLmsReportUploadR   , postLmsReportUploadR  , postLmsReportDirectR
   , getLmsOrphansR
   --
-  , getLmsFakeR           , postLmsFakeR
+  -- , getLmsFakeR           , postLmsFakeR
   , getLmsUserR
   , getLmsUserSchoolR
   , getLmsUserAllR
@@ -44,11 +44,11 @@ import qualified Database.Esqueleto.Legacy as E
 import qualified Database.Esqueleto.PostgreSQL as E
 import qualified Database.Esqueleto.Utils as E
 import Database.Esqueleto.Utils.TH
-import Database.Persist.Sql (deleteWhereCount, updateWhereCount)
+import Database.Persist.Sql (updateWhereCount) -- deleteWhereCount
 -- V2
 import Handler.LMS.Learners as Handler.LMS
 import Handler.LMS.Report   as Handler.LMS
-import Handler.LMS.Fake     as Handler.LMS -- TODO: remove in production!
+-- import Handler.LMS.Fake     as Handler.LMS -- TODO: remove in production!
 
 
 -- Button only needed here
@@ -384,10 +384,6 @@ isNotifyAct LmsActNotifyData      = True
 isNotifyAct LmsActRenewNotifyData = True
 isNotifyAct _                     = False
 
-isRenewPinAct :: LmsTableActionData -> Bool
-isRenewPinAct LmsActRenewNotifyData = True
-isRenewPinAct _                     = False
-
 isResetAct :: LmsTableActionData -> Bool
 isResetAct LmsActResetData{}    = True
 isResetAct _                    = False
@@ -742,20 +738,19 @@ postLmsR sid qsh = do
             , QualificationUserUser <-. usersList
             , QualificationUserValidUntil <. cutoff
             ] []
-          forM_ shortUsers $ upsertQualificationUser qid now cutoff Nothing "E-Learning Reset"
+          forM_ shortUsers $ upsertQualificationUser qid now cutoff Nothing "E-Learning Reset" -- do not terminate LMS here , since it is expected to continue
 
-        fromIntegral <$> (if isReset
+        if isReset
-            then updateWhereCount ([LmsUserQualification ==. qid, LmsUserUser <-. usersList, LmsUserResetTries ==. False, LmsUserEnded ==. Nothing] -- , LmsUserLocked ==. True] -- needs to be locked for reset, but this is counter-intuitive for users; should be harmles, but delays reset until lock is effective
+          then fromIntegral <$> updateWhereCount ([LmsUserQualification ==. qid, LmsUserUser <-. usersList, LmsUserResetTries ==. False, LmsUserEnded ==. Nothing] -- , LmsUserLocked ==. True] -- needs to be locked for reset, but this is counter-intuitive for users; should be harmles, but delays reset until lock is effective
-                                    ++ ([LmsUserStatus ==. Just LmsBlocked] ||. [LmsUserStatus ==. Just LmsExpired]))     [LmsUserResetTries =. True]
+                                              ++ ([LmsUserStatus ==. Just LmsBlocked] ||. [LmsUserStatus ==. Just LmsExpired]))     [LmsUserResetTries =. True]
-            else deleteWhereCount  [LmsUserQualification ==. qid, LmsUserUser <-. usersList]
+          else terminateLms LmsOrphanReasonManualRestart qid usersList
-          )
 
       unless isReset $
         forM_ selectedUsers $ \uid ->
           queueJob' $ JobLmsEnqueueUser { jQualification = qid, jUser = uid }
 
       runDB $ forM_ selectedUsers $ \uid ->
-        audit $ TransactionLmsReset
+        audit $ TransactionLmsReset                            -- NOTE: double audit, if isRestart; double audit if actRestartExtend
           { transactionQualification   = qid
           , transactionLmsUser         = uid
           , transactionLmsReset        = isReset
@@ -768,7 +763,8 @@ postLmsR sid qsh = do
       addMessageI mStatus $ bool MsgLmsActRestartFeedback MsgLmsActResetFeedback isReset chgUsers numUsers
       reloadKeepGetParams $ LmsR sid qsh
 
-    (action, selectedUsers) | isRenewPinAct action || isNotifyAct action -> do
+    (action, selectedUsers) | isNotifyAct action -> do
+      let isRenewPinAct = action == LmsActRenewNotifyData
       numExaminees <- runDB $ do
         okUsers <- selectList [ LmsUserQualification  ==. qid                       -- matching qualification
                               , LmsUserEnded          ==. Nothing                   -- not yet deleted
@@ -776,18 +772,17 @@ postLmsR sid qsh = do
                               , LmsUserUser           <-. Set.toList selectedUsers  -- selected
                               ] []
         forM_ okUsers $ \(Entity lid LmsUser {lmsUserUser = uid, lmsUserQualification = qid'}) -> do
-          when (isRenewPinAct action) $ do
+          when isRenewPinAct $ do
             newPin <- liftIO randomLMSpw
             update lid [LmsUserPin =. newPin, LmsUserDatePin =. now, LmsUserResetPin =. True]
-          when (isNotifyAct action) $
+          queueJob' $ JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal qid' False }
-            queueJob' $ JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal qid' False }
         return $ length okUsers
       let numSelected  = length selectedUsers
           diffSelected = numSelected - numExaminees
           mstat        = bool Success Warning $ diffSelected /= 0
-      when (isRenewPinAct action) $ addMessageI mstat   $ MsgLmsPinRenewal       numExaminees
+      when isRenewPinAct $ addMessageI mstat $ MsgLmsPinRenewal       numExaminees
-      when (isNotifyAct action)   $ addMessageI mstat   $ MsgLmsNotificationSend numExaminees
+      addMessageI mstat $ MsgLmsNotificationSend numExaminees
-      when (diffSelected /= 0)    $ addMessageI Warning $ MsgLmsActionFailed     diffSelected
+      when (diffSelected /= 0) $ addMessageI Warning $ MsgLmsActionFailed     diffSelected
       reloadKeepGetParams $ LmsR sid qsh
     _ -> addMessageI Error MsgUnauthorized -- should not happen
 

src/Handler/LMS/Fake.hs

@@ -2,6 +2,9 @@
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
+
+-- For testing and debugging only, not to be used in production
+
 module Handler.LMS.Fake
   ( getLmsFakeR, postLmsFakeR
   ) where

src/Handler/Profile.hs

@@ -1264,7 +1264,7 @@ mkReceiversTable uid usrCmps receivers = dbTableDB' validator DBTable{..}
             let ruid = row ^. resultReceiver . _entityKey
                 rcmp = row ^? resultReceiverSupervisor . _entityVal . _userSupervisorCompany . _Just . to unCompanyKey
                 errWgt fsh = let emsg = MsgCompanySupervisorCompanyMissing fsh
-                             in [whamlet|^{messageTooltip =<< messageI Error emsg} _{emsg}|]
+                             in [whamlet|^{messageTooltip =<< messageI Warning emsg} _{emsg}|]
             cmps <- wgtCompanies' ruid
             return $ case (cmps, rcmp) of
               (Just (cwgt, cmpsData), Just svcsh)
@@ -1282,7 +1282,7 @@ mkReceiversTable uid usrCmps receivers = dbTableDB' validator DBTable{..}
         , sortable (Just "cshort")      (i18nCell MsgUserSupervisorCompany) $ \row ->
             let mc = row ^? resultReceiverSupervisor . _entityVal . _userSupervisorCompany . _Just
                 errWgt fsh = let emsg = MsgCompanySuperviseeCompanyMissing fsh
-                             in [whamlet|<p>^{messageTooltip =<< messageI Error emsg} _{emsg}|]
+                             in [whamlet|<p>^{messageTooltip =<< messageI Warning emsg} _{emsg}|]
             in case mc of
                 Nothing -> mempty
                 (Just sfid@(unCompanyKey -> sfsh))

src/Handler/Qualification.hs

@@ -610,12 +610,19 @@ postQualificationR sid qsh = do
 
   formResult lmsRes $ \case
     (QualificationActRenewData renewReason, selectedUsers) | isAdmin -> do
-      noks <- runDB $ renewValidQualificationUsers qid (canonical $ Just $ Left renewReason) Nothing $ Set.toList selectedUsers
+      let selUsrs = Set.toList selectedUsers
+      (noks,nterm) <- runDB $ (,)
+        <$> renewValidQualificationUsers qid (canonical $ Just $ Left renewReason) Nothing selUsrs
+        <*> terminateLms (LmsOrphanReasonManualRenewal renewReason) qid selUsrs
       addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
+      when (nterm >0) $ addMessageI Warning $ MsgLmsActTerminated nterm
       reloadKeepGetParams $ QualificationR sid qsh
     (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do
-      runDB . forM_ selectedUsers $ upsertQualificationUser qid now grantValidday Nothing "Admin"
+      nterm <- runDB $ do
+        forM_ selectedUsers $ upsertQualificationUser qid now grantValidday Nothing "Admin"
+        terminateLms (LmsOrphanReasonManualGrant $ "bis " <> tshow grantValidday) qid $ Set.toList selectedUsers
       addMessageI  (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
+      when (nterm > 0) $ addMessageI Warning $ MsgLmsActTerminated nterm
       reloadKeepGetParams $ QualificationR sid qsh
     (QualificationActStartELearningData, Set.toList -> selectedUsers) | isAdmin -> do
       -- whenIsJust mbExpDay $ \expDay ->

src/Handler/Tutorial/Users.hs

@@ -111,7 +111,8 @@ mkGenTutForm fltr html = do
 getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler TypedContent
 getTUsersR = postTUsersR
 postTUsersR tid ssh csh tutn = do
-  let croute  = CTutorialR tid ssh csh tutn TUsersR
+  let heading = prependCourseTitle tid ssh csh $ CI.original tutn
+      croute  = CTutorialR tid ssh csh tutn TUsersR
   now <- liftIO getCurrentTime
   isAdmin <- hasReadAccessTo AdminR
   (Entity tutid tut@Tutorial{..}, (participantRes, participantTable), qualifications, dbegin, hasExams, exmFltr, exOccs) <- runDB do
@@ -204,13 +205,22 @@ postTUsersR tid ssh csh tutn = do
         -- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
         today <- liftIO getCurrentTime
         let reason = "Kurs " <> CI.original (unSchoolKey ssh) <> "-" <> CI.original csh <> "-" <> CI.original tutn
-        runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing reason
+            selUsrs = Set.toList selectedUsers
+        nterm <- runDB $ do
+          forM_ selUsrs $ upsertQualificationUser tuQualification today tuValidUntil Nothing reason
+          terminateLms (LmsOrphanReasonManualGrant [st|bis #{tshow tuValidUntil}, #{reason}|]) tuQualification selUsrs
         addMessageI  (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
+        when (nterm > 0) $ addMessageI Warning $ MsgLmsActTerminated nterm
         reloadKeepGetParams croute
     (TutorialUserRenewQualificationData{..}, selectedUsers)
       | tuQualification `Set.member` courseQids -> do
-        noks <- runDB $ renewValidQualificationUsers tuQualification Nothing Nothing $ Set.toList selectedUsers
+        let selUsrs = Set.toList selectedUsers
+        mr <- getMessageRender
+        (noks,nterm) <- runDB $ (,)
+          <$> renewValidQualificationUsers tuQualification Nothing Nothing selUsrs
+          <*> terminateLms (LmsOrphanReasonManualGrant $ mr heading) tuQualification selUsrs
         addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
+        when (nterm > 0) $ addMessageI Warning $ MsgLmsActTerminated nterm
         reloadKeepGetParams croute
     (TutorialUserSendMailData, selectedUsers) -> do
         cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
@@ -281,7 +291,6 @@ postTUsersR tid ssh csh tutn = do
                   E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
                   return user
       --   $(i18nWidgetFile "exam-missing")
-      let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName
       html <- siteLayoutMsg heading do
         setTitleI heading
         $(widgetFile "tutorial-participants")

src/Handler/Utils/Qualification.hs

@@ -376,17 +376,19 @@ qualOpt (Entity qualId qual) = do
 
 data LmsOrphanReason
   = LmsOrphanReasonManualTermination
-  | LmsOrphanReasonB
+  | LmsOrphanReasonManualRestart
-  | LmsOrphanReasonC
+  | LmsOrphanReasonManualRenewal { orphanManualReason :: Text }
-  deriving (Eq, Ord, Enum, Bounded, Generic)
+  | LmsOrphanReasonManualGrant   { orphanManualReason :: Text }
-  deriving anyclass (Universe, Finite, NFData)
+  deriving (Eq, Ord, Generic)
+--  deriving anyclass (NFData)
 
 -- NOTE: it is intentional not to have an embedRenderMessage here; within the DB, we allow arbitrary text, but we do match on these ones to recognise certain functions
 --       so do not change values here without a proper migration
 instance Show LmsOrphanReason where
   show LmsOrphanReasonManualTermination = "Manuell abgebrochen"
-  show LmsOrphanReasonB = "B"
+  show LmsOrphanReasonManualRestart     = "Manuell neugestartet"
-  show LmsOrphanReasonC = "C"
+  show LmsOrphanReasonManualRenewal{..} = "Qualifikation manuell verlängert: " <> Text.unpack orphanManualReason
+  show LmsOrphanReasonManualGrant  {..} = "Qualifikation manuell vergeben: "   <> Text.unpack orphanManualReason
 
 -- | Remove user from e-learning for given qualification and add to LmsOrphan dated back for immediate deletion. Calls audit
 terminateLms :: LmsOrphanReason -> QualificationId -> [UserId] -> DB Int