diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg
index 4ec8764fb..bcf9d71e1 100644
--- a/messages/uniworx/categories/qualification/de-de-formal.msg
+++ b/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
diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg
index 5707f3e8e..96686cb37 100644
--- a/messages/uniworx/categories/qualification/en-eu.msg
+++ b/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
diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs
index 7ffe0f542..b8e72abd7 100644
--- a/src/Handler/LMS.hs
+++ b/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
- 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
- ++ ([LmsUserStatus ==. Just LmsBlocked] ||. [LmsUserStatus ==. Just LmsExpired])) [LmsUserResetTries =. True]
- else deleteWhereCount [LmsUserQualification ==. qid, LmsUserUser <-. usersList]
- )
+ if isReset
+ 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]
+ 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 (isNotifyAct action) $ addMessageI mstat $ MsgLmsNotificationSend numExaminees
- when (diffSelected /= 0) $ addMessageI Warning $ MsgLmsActionFailed diffSelected
+ when isRenewPinAct $ addMessageI mstat $ MsgLmsPinRenewal numExaminees
+ addMessageI mstat $ MsgLmsNotificationSend numExaminees
+ when (diffSelected /= 0) $ addMessageI Warning $ MsgLmsActionFailed diffSelected
reloadKeepGetParams $ LmsR sid qsh
_ -> addMessageI Error MsgUnauthorized -- should not happen
diff --git a/src/Handler/LMS/Fake.hs b/src/Handler/LMS/Fake.hs
index 4383f6e00..ee48a96cf 100644
--- a/src/Handler/LMS/Fake.hs
+++ b/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
diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs
index 7b75e3b7e..94cf19cba 100644
--- a/src/Handler/Profile.hs
+++ b/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|^{messageTooltip =<< messageI Error emsg} _{emsg}|]
+ in [whamlet|
^{messageTooltip =<< messageI Warning emsg} _{emsg}|]
in case mc of
Nothing -> mempty
(Just sfid@(unCompanyKey -> sfsh))
diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs
index 05c6c84fd..10989ea5c 100644
--- a/src/Handler/Qualification.hs
+++ b/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 ->
diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs
index deddc1de9..317674162 100644
--- a/src/Handler/Tutorial/Users.hs
+++ b/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")
diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs
index 718061741..8921c8936 100644
--- a/src/Handler/Utils/Qualification.hs
+++ b/src/Handler/Utils/Qualification.hs
@@ -376,17 +376,19 @@ qualOpt (Entity qualId qual) = do
data LmsOrphanReason
= LmsOrphanReasonManualTermination
- | LmsOrphanReasonB
- | LmsOrphanReasonC
- deriving (Eq, Ord, Enum, Bounded, Generic)
- deriving anyclass (Universe, Finite, NFData)
+ | LmsOrphanReasonManualRestart
+ | LmsOrphanReasonManualRenewal { orphanManualReason :: Text }
+ | LmsOrphanReasonManualGrant { orphanManualReason :: Text }
+ 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 LmsOrphanReasonC = "C"
+ show LmsOrphanReasonManualRestart = "Manuell neugestartet"
+ 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