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)
This commit is contained in:
parent
102cd6c73e
commit
a56a5e148e
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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))
|
||||
|
||||
@ -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 ->
|
||||
|
||||
@ -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")
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user