Merge branch 'master' into fradrive/company
This commit is contained in:
commit
f627de503e
17
CHANGELOG.md
17
CHANGELOG.md
@ -2,6 +2,23 @@
|
||||
|
||||
All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
|
||||
|
||||
## [27.4.48](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.47...v27.4.48) (2023-11-07)
|
||||
|
||||
|
||||
### Bug Fixes
|
||||
|
||||
* **lms:** mark as ended only if not seen for at least one day ([8165892](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8165892b2e4f945780bb8420cfc4eed50fdd294d))
|
||||
|
||||
## [27.4.47](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.46...v27.4.47) (2023-11-03)
|
||||
|
||||
## [27.4.46](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.45...v27.4.46) (2023-11-03)
|
||||
|
||||
|
||||
### Bug Fixes
|
||||
|
||||
* **course:** grant qualifications now issues and unblocks ([5d8d8cf](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5d8d8cf17e634ecb950a1c329c859fb93f94ef77))
|
||||
* **users:** allow prefer postal setting for users with fraport department ([a9d56c5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a9d56c51dcc727f8637b09a0e849372e75032f5e))
|
||||
|
||||
## [27.4.45](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.44...v27.4.45) (2023-10-18)
|
||||
|
||||
|
||||
|
||||
@ -38,6 +38,7 @@ QualificationScheduleRenewalTooltip: Wird eine Benachrichtigung versendet, falls
|
||||
QualificationUserNoRenewal: Läuft ohne Benachrichtigung aus
|
||||
QualificationUserNone: Für diese Person sind keine Qualifikationen registriert.
|
||||
QualificationGrantReason: Erteilungsbegründung
|
||||
QualificationRenewReason: Verlängerungsbegründung
|
||||
QualificationBlockReason: Entzugsbegründung
|
||||
QualificationBlockNotify: Benachrichtigung verschicken
|
||||
QualificationBlockRemoveSupervisor: Alle Ansprechpartner löschen
|
||||
|
||||
@ -38,6 +38,7 @@ QualificationScheduleRenewalTooltip: Will there be a notification, if this quali
|
||||
QualificationUserNoRenewal: Expires without further notification
|
||||
QualificationUserNone: No registered qualifications for this person.
|
||||
QualificationGrantReason: Reason for granting
|
||||
QualificationRenewReason: Reason for renewal
|
||||
QualificationBlockReason: Reason for revoking
|
||||
QualificationBlockNotify: Send notification
|
||||
QualificationBlockRemoveSupervisor: Remove all supervisors
|
||||
|
||||
@ -144,7 +144,7 @@ LmsUser
|
||||
-- UniqueLmsUserStatus lmsUser -- enforcing uniqueness prohibits history
|
||||
-- deriving Generic
|
||||
|
||||
-- LmsUserlist stores LMS upload for later processing only
|
||||
-- DEPRECATED V1 LmsUserlist stores LMS upload for later processing only
|
||||
LmsUserlist
|
||||
qualification QualificationId OnDeleteCascade OnUpdateCascade
|
||||
ident LmsIdent
|
||||
@ -153,7 +153,7 @@ LmsUserlist
|
||||
UniqueLmsUserlist qualification ident
|
||||
deriving Generic Show
|
||||
|
||||
-- LmsResult stores LMS upload for later processing only
|
||||
-- DEPRECATED V1 LmsResult stores LMS upload for later processing only
|
||||
LmsResult
|
||||
qualification QualificationId OnDeleteCascade OnUpdateCascade
|
||||
ident LmsIdent
|
||||
@ -162,6 +162,7 @@ LmsResult
|
||||
UniqueLmsResult qualification ident -- required by DBTable
|
||||
deriving Generic
|
||||
|
||||
-- V2 Stores LMS upload for processing in Background Job
|
||||
LmsReport
|
||||
qualification QualificationId OnDeleteCascade OnUpdateCascade
|
||||
ident LmsIdent
|
||||
@ -170,4 +171,16 @@ LmsReport
|
||||
lock Bool -- (0|1)
|
||||
timestamp UTCTime default=now()
|
||||
UniqueLmsReport qualification ident -- required by DBTable
|
||||
deriving Generic
|
||||
|
||||
-- LmsAudit removed by commit 71cde92a
|
||||
-- due to frequent transmit errors, a separate lms tranmission log is necessary again
|
||||
LmsReportLog
|
||||
qualification QualificationId OnDeleteCascade OnUpdateCascade
|
||||
ident LmsIdent
|
||||
date UTCTime Maybe -- BEWARE: timezone is local as submitted by LMS
|
||||
result LmsState -- (0|1|2) 0=LmsFailed[too many tries], 1=LmsOpen, 2=LmsPassed[success]
|
||||
lock Bool -- (0|1)
|
||||
timestamp UTCTime default=now()
|
||||
missing Bool default=false
|
||||
deriving Generic
|
||||
@ -1,3 +1,3 @@
|
||||
{
|
||||
"version": "27.4.45"
|
||||
"version": "27.4.48"
|
||||
}
|
||||
|
||||
2
package-lock.json
generated
2
package-lock.json
generated
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "27.4.45",
|
||||
"version": "27.4.48",
|
||||
"lockfileVersion": 1,
|
||||
"requires": true,
|
||||
"dependencies": {
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "27.4.45",
|
||||
"version": "27.4.48",
|
||||
"description": "",
|
||||
"keywords": [],
|
||||
"author": "",
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: uniworx
|
||||
version: 27.4.45
|
||||
version: 27.4.48
|
||||
dependencies:
|
||||
- base
|
||||
- yesod
|
||||
|
||||
@ -216,6 +216,7 @@ data Transaction
|
||||
, transactionQualification :: QualificationId
|
||||
, transactionQualificationValidUntil :: Day
|
||||
, transactionQualificationScheduleRenewal :: Maybe Bool -- Maybe, because some update may leave it unchanged (also avoids DB Migration)
|
||||
, transactionNote :: Maybe Text
|
||||
}
|
||||
| TransactionQualificationUserDelete
|
||||
{ transactionUser :: UserId
|
||||
|
||||
@ -296,7 +296,7 @@ data QualificationTableActionData
|
||||
| QualificationActBlockSupervisorData
|
||||
| QualificationActBlockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool }
|
||||
| QualificationActUnblockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool}
|
||||
| QualificationActRenewData
|
||||
| QualificationActRenewData { qualTableActChangeReason :: Text}
|
||||
| QualificationActGrantData { qualTableActGrantUntil :: Day }
|
||||
deriving (Eq, Ord, Show, Generic)
|
||||
|
||||
@ -573,7 +573,8 @@ postQualificationR sid qsh = do
|
||||
<$> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationBlockReason) Nothing
|
||||
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False)
|
||||
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockRemoveSupervisor) (Just False)
|
||||
, singletonMap QualificationActRenew $ pure QualificationActRenewData
|
||||
, singletonMap QualificationActRenew $ QualificationActRenewData
|
||||
<$> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationRenewReason) Nothing
|
||||
, singletonMap QualificationActGrant $ QualificationActGrantData
|
||||
<$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
|
||||
<* aformMessage msgGrantWarning
|
||||
@ -608,8 +609,8 @@ postQualificationR sid qsh = do
|
||||
return (tbl, qent)
|
||||
|
||||
formResult lmsRes $ \case
|
||||
(QualificationActRenewData, selectedUsers) | isAdmin -> do
|
||||
noks <- runDB $ renewValidQualificationUsers qid Nothing $ Set.toList selectedUsers
|
||||
(QualificationActRenewData renewReason, selectedUsers) | isAdmin -> do
|
||||
noks <- runDB $ renewValidQualificationUsers qid (canonical $ Just $ Left renewReason) Nothing $ Set.toList selectedUsers
|
||||
addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
|
||||
reloadKeepGetParams $ QualificationR sid qsh
|
||||
(QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do
|
||||
|
||||
@ -146,7 +146,7 @@ postTUsersR tid ssh csh tutn = do
|
||||
redirect $ CTutorialR tid ssh csh tutn TUsersR
|
||||
(TutorialUserRenewQualificationData{..}, selectedUsers)
|
||||
| tuQualification `Set.member` courseQids -> do
|
||||
noks <- runDB $ renewValidQualificationUsers tuQualification Nothing $ Set.toList selectedUsers
|
||||
noks <- runDB $ renewValidQualificationUsers tuQualification Nothing Nothing $ Set.toList selectedUsers
|
||||
addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
|
||||
redirect $ CTutorialR tid ssh csh tutn TUsersR
|
||||
(TutorialUserSendMailData{}, selectedUsers) -> do
|
||||
|
||||
@ -24,10 +24,10 @@ statusQualificationBlock s = statusHtml (bool Error Success s) $ iconQualificati
|
||||
|
||||
|
||||
-- needs refactoring, probbably no longer helpful
|
||||
mkQualificationBlocked :: QualificationBlockStandardReason -> UTCTime -> QualificationUserId -> QualificationUserBlock
|
||||
mkQualificationBlocked :: QualificationStandardReason -> UTCTime -> QualificationUserId -> QualificationUserBlock
|
||||
mkQualificationBlocked reason qualificationUserBlockFrom qualificationUserBlockQualificationUser = QualificationUserBlock{..}
|
||||
where
|
||||
qualificationUserBlockReason = qualificationBlockedReasonText reason
|
||||
qualificationUserBlockReason = tshow reason
|
||||
qualificationUserBlockUnblock = False
|
||||
qualificationUserBlockBlocker = Nothing
|
||||
|
||||
@ -158,6 +158,7 @@ upsertQualificationUser qualificationUserQualification startTime qualificationU
|
||||
, transactionUser = qualificationUserUser
|
||||
, transactionQualificationValidUntil = qualificationUserValidUntil
|
||||
, transactionQualificationScheduleRenewal = mbScheduleRenewal
|
||||
, transactionNote = canonical $ Just reason
|
||||
}
|
||||
|
||||
-- | Renew an existing valid qualification, ignoring all blocks otherwise
|
||||
@ -174,8 +175,8 @@ renewValidQualificationUsers ::
|
||||
, HasAppSettings (HandlerSite m)
|
||||
, MonadHandler m
|
||||
, MonadCatch m
|
||||
) => QualificationId -> Maybe UTCTime -> [UserId] -> ReaderT (YesodPersistBackend (HandlerSite m)) m Int
|
||||
renewValidQualificationUsers qid renewalTime uids =
|
||||
) => QualificationId -> Maybe QualificationChangeReason -> Maybe UTCTime -> [UserId] -> ReaderT (YesodPersistBackend (HandlerSite m)) m Int
|
||||
renewValidQualificationUsers qid reason renewalTime uids =
|
||||
-- The following short code snippet suffices in principle, but would not allow audit log entries. Are these still needed?
|
||||
-- E.update $ \qu -> do
|
||||
-- E.set qu [ QualificationUserValidUntil E.+=. E.interval (CalendarDiffDays 2 0) ] -- TODO: for Testing only
|
||||
@ -199,6 +200,7 @@ renewValidQualificationUsers qid renewalTime uids =
|
||||
, transactionUser = qualificationUserUser
|
||||
, transactionQualificationValidUntil = newValidTo
|
||||
, transactionQualificationScheduleRenewal = Nothing
|
||||
, transactionNote = qualificationChangeReasonText <$> reason
|
||||
}
|
||||
return $ length quEnts
|
||||
_ -> return (-1) -- qualificationId not found, isNothing qualificationValidDuration, etc.
|
||||
@ -217,8 +219,8 @@ qualificationUserBlocking ::
|
||||
, MonadHandler m
|
||||
, MonadCatch m
|
||||
, Num n
|
||||
) => QualificationId -> [UserId] -> Bool -> Maybe UTCTime -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
|
||||
qualificationUserBlocking qid uids unblock mbBlockTime (qualificationBlockReasonText -> reason) notify = do
|
||||
) => QualificationId -> [UserId] -> Bool -> Maybe UTCTime -> QualificationChangeReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
|
||||
qualificationUserBlocking qid uids unblock mbBlockTime (qualificationChangeReasonText -> reason) notify = do
|
||||
$logInfoS "BLOCK" $ Text.intercalate " - " [tshow qid, tshow uids, tshow unblock, tshow mbBlockTime, tshow reason, tshow notify]
|
||||
authUsr <- liftHandler maybeAuthId
|
||||
now <- liftIO getCurrentTime
|
||||
@ -269,8 +271,8 @@ qualificationUserUnblockByReason ::
|
||||
, MonadHandler m
|
||||
, MonadCatch m
|
||||
, Num n
|
||||
) => QualificationId -> [UserId] -> Maybe UTCTime -> QualificationBlockReason -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
|
||||
qualificationUserUnblockByReason qid uids mbUnblockTime (qualificationBlockReasonText -> reason) undo_reason notify = do
|
||||
) => QualificationId -> [UserId] -> Maybe UTCTime -> QualificationChangeReason -> QualificationChangeReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
|
||||
qualificationUserUnblockByReason qid uids mbUnblockTime (qualificationChangeReasonText -> reason) undo_reason notify = do
|
||||
cutoff <- maybe (liftIO getCurrentTime) return mbUnblockTime
|
||||
toUnblock <- E.select $ do
|
||||
quser <- E.from $ E.table @QualificationUser
|
||||
|
||||
@ -164,7 +164,7 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
|
||||
maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser lpw) (randomLMSIdentBut qprefix identsInUse)
|
||||
-- runMaybeT $ do
|
||||
-- lid <- MaybeT $ randomLMSIdentBu qprefix identsInUse
|
||||
-- MaybeT $ E.insertUniqueEntity $ mkLmsUser lpw lid
|
||||
-- MaybeT $ E.insertUniqueEntity $ mkLmsUser lpw lid
|
||||
inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser
|
||||
case inserted of
|
||||
Nothing -> do
|
||||
@ -187,7 +187,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
|
||||
quali <- getJust qid -- may throw an error, aborting the job
|
||||
let qshort = CI.original $ qualificationShorthand quali
|
||||
$logInfoS "LMS" $ "Processing e-learning results for qualification " <> qshort
|
||||
now <- liftIO getCurrentTime
|
||||
now <- liftIO getCurrentTime
|
||||
-- end users that expired by doing nothing
|
||||
expiredUsers <- E.select $ do
|
||||
(quser :& luser) <- E.from $
|
||||
@ -201,9 +201,10 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
|
||||
-- E.&&. E.isNothing (luser E.^. LmsUserStatus)
|
||||
-- E.&&. E.isNothing (luser E.^. LmsUserEnded)
|
||||
E.&&. E.not_ (validQualification now quser)
|
||||
pure (quser E.^. QualificationUserUser, luser E.?. LmsUserId)
|
||||
nrBlocked <- qualificationUserBlocking qid (E.unValue . fst <$> expiredUsers) False (Just now) (Right QualificationBlockExpired) True -- essential that blocks occur only once
|
||||
let expiredLearners = [luid | (_, E.Value (Just luid)) <- expiredUsers]
|
||||
pure (luser E.?. LmsUserId, quser E.^. QualificationUserUser)
|
||||
nrBlocked <- qualificationUserBlocking qid (E.unValue . snd <$> expiredUsers) False (Just now) (Right QualificationBlockExpired) True -- essential that blocks occur only once
|
||||
let expiredLearners = [ luid | (E.Value (Just luid), _) <- expiredUsers ]
|
||||
-- let expiredLearners = catMaybes (E.unValue . fst <$> expiredUsers)
|
||||
nrExpired <- E.updateCount $ \luser -> do
|
||||
E.set luser [LmsUserStatus E.=. E.justVal LmsExpired, LmsUserStatusDay E.=. E.justVal now]
|
||||
E.where_ $ E.isNothing (luser E.^. LmsUserStatus)
|
||||
@ -213,7 +214,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
|
||||
|
||||
when (quali ^. _qualificationExpiryNotification) $ do -- notifies expired and previously lms-failed drivers
|
||||
notifyInvalidDrivers <- E.select $ do
|
||||
(quser :& qblock) <- E.from $
|
||||
(quser :& qblock) <- E.from $
|
||||
E.table @QualificationUser
|
||||
`E.leftJoin` E.table @QualificationUserBlock
|
||||
`E.on` (\(quser :& qblock) -> qblock E.?. QualificationUserBlockQualificationUser E.?=. quser E.^. QualificationUserId
|
||||
@ -256,6 +257,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
|
||||
deleteWhere [LmsUserlistQualification ==. qid, LmsUserlistIdent <-. delusers]
|
||||
deleteWhere [LmsResultQualification ==. qid, LmsResultIdent <-. delusers]
|
||||
-- deleteWhere [LmsAuditQualification ==. qid, LmsAuditIdent <-. delusers]
|
||||
deleteWhere [LmsReportLogQualification ==. qid, LmsReportLogTimestamp <. auditCutoff ]
|
||||
|
||||
|
||||
dispatchJobLmsReports :: QualificationId -> JobHandler UniWorX
|
||||
@ -265,7 +267,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
|
||||
act = whenM (exists [LmsReportQualification ==. qid]) $ do -- executing twice must be prohibited due to assertion that ALL learners are always sent (D fails otherwise)
|
||||
now <- liftIO getCurrentTime
|
||||
-- DEBUG 2rows; remove later
|
||||
totalrows <- count [LmsReportQualification ==. qid]
|
||||
totalrows <- count [LmsReportQualification ==. qid]
|
||||
$logInfoS "LMS" $ "Report processing " <> tshow totalrows <> " rows for qualification " <> tshow qid
|
||||
when (totalrows > 0) $ do
|
||||
let -- locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now -- no longer necessary, since LMS reports dates only
|
||||
@ -291,7 +293,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
|
||||
E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
|
||||
E.&&. E.isNothing (luser E.^. LmsUserEnded) -- ignore all closed learners
|
||||
E.&&. lrFltr luser lreport
|
||||
return (luser, lreport)
|
||||
return (luser, lreport)
|
||||
-- A) reset status for learners that had their tries just resetted as indicated by LmsOpen
|
||||
E.update $ \luser -> do
|
||||
E.set luser [ LmsUserStatus E.=. E.nothing
|
||||
@ -314,27 +316,28 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
|
||||
in luserQry luserFltrNew (const $ const E.true) >>= mapM_ notifyNewLearner
|
||||
-- C) block qualifications for failed learners by calling qualificationUserBlocking [uids] (includes audit), notified during expiry
|
||||
let lrFltrBlock luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsFailed
|
||||
procBlock (Entity luid luser, Entity _ lreport) = do
|
||||
procBlock (Entity luid luser, Entity _ lreport) = do
|
||||
let repDay = lmsReportDate lreport <|> Just now
|
||||
ok_block <- qualificationUserBlocking qid [lmsUserUser luser] False (lmsReportDate lreport) (Right QualificationBlockFailedELearning) True -- only valid qualifications are blocked; transcribes to audit log
|
||||
ok_block <- qualificationUserBlocking qid [lmsUserUser luser] False (lmsReportDate lreport) (Right $ QualificationBlockFailedELearningBy $ lmsUserIdent luser) True -- only valid qualifications are blocked; transcribes to audit log
|
||||
update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. repDay]
|
||||
return $ Sum ok_block
|
||||
in lrepQry lrFltrBlock
|
||||
>>= foldMapM procBlock
|
||||
in lrepQry lrFltrBlock
|
||||
>>= foldMapM procBlock
|
||||
>>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " status set to blocked for qualification " <> tshow qid -- debug, remove later
|
||||
-- D) renew qualifications for all successfull learners
|
||||
let lrFltrSuccess luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsPassed
|
||||
procRenew (Entity luid luser, Entity _ lreport) = do
|
||||
let repDay = lmsReportDate lreport <|> Just now
|
||||
reason = Just $ Right $ QualificationRenewELearningBy $ lmsUserIdent luser
|
||||
-- LMS WORKAROUND 2: [supposedly fixed now] sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning
|
||||
-- let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning
|
||||
-- let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning
|
||||
-- ok_unblock <- qualificationUserUnblockByReason qid [lmsUserUser luser] repTime (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log
|
||||
-- when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid} having success reported after initially failed e-learning|])
|
||||
-- END LMS WORKAROUND 2
|
||||
ok_renew <- renewValidQualificationUsers qid repDay [lmsUserUser luser]-- only valid qualifications are truly renewed; transcribes to audit log
|
||||
ok_renew <- renewValidQualificationUsers qid reason repDay [lmsUserUser luser]-- only valid qualifications are truly renewed; transcribes to audit log
|
||||
update luid [LmsUserStatus =. Just LmsSuccess, LmsUserStatusDay =. repDay]
|
||||
return $ Sum ok_renew
|
||||
in lrepQry lrFltrSuccess
|
||||
in lrepQry lrFltrSuccess
|
||||
>>= foldMapM procRenew
|
||||
>>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " renewed and status set to success for qualification " <> tshow qid -- debug, remove later
|
||||
-- E) mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected)
|
||||
@ -377,7 +380,50 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
|
||||
>>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as unlocked and received for qualification " <> tshow qid -- debug, remove later
|
||||
updateReceivedLocked True
|
||||
>>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as locked and received for qualification " <> tshow qid -- debug, remove later
|
||||
-- G) Truncate LmsReport for qid and log
|
||||
-- G) Truncate LmsReport for qid, after updating log
|
||||
E.insertSelect $ do
|
||||
lreport <- E.from $ E.table @LmsReport
|
||||
let samelog = E.subSelect $ do
|
||||
lrl <- E.from $ E.table @LmsReportLog
|
||||
E.where_ $ lrl E.^. LmsReportLogQualification E.==. E.val qid
|
||||
E.&&. lrl E.^. LmsReportLogIdent E.==. lreport E.^. LmsReportIdent
|
||||
E.orderBy [E.desc $ lrl E.^. LmsReportLogTimestamp]
|
||||
return $ lreport E.^. LmsReportResult E.==. lrl E.^. LmsReportLogResult
|
||||
E.&&. lreport E.^. LmsReportLock E.==. lrl E.^. LmsReportLogLock
|
||||
E.&&. E.not_ (lrl E.^. LmsReportLogMissing)
|
||||
E.where_ $ lreport E.^. LmsReportQualification E.==. E.val qid
|
||||
E.&&. E.not_ (E.isTrue samelog)
|
||||
return (LmsReportLog
|
||||
E.<# (lreport E.^. LmsReportQualification)
|
||||
E.<&> (lreport E.^. LmsReportIdent )
|
||||
E.<&> (lreport E.^. LmsReportDate )
|
||||
E.<&> (lreport E.^. LmsReportResult )
|
||||
E.<&> (lreport E.^. LmsReportLock )
|
||||
E.<&> (lreport E.^. LmsReportTimestamp )
|
||||
E.<&> E.false)
|
||||
E.insertSelect $ do
|
||||
lrl <- E.from $ E.table @LmsReportLog
|
||||
E.where_ $ E.not_ (lrl E.^. LmsReportLogMissing)
|
||||
E.&&. lrl E.^. LmsReportLogQualification E.==. E.val qid
|
||||
E.&&. E.notExists (do
|
||||
lreport <- E.from $ E.table @LmsReport
|
||||
E.where_ $ lreport E.^. LmsReportQualification E.==. E.val qid
|
||||
E.&&. lreport E.^. LmsReportIdent E.==. lrl E.^. LmsReportLogIdent
|
||||
)
|
||||
E.&&. E.notExists (do
|
||||
lrl_old <- E.from $ E.table @LmsReportLog
|
||||
E.where_ $ lrl_old E.^. LmsReportLogQualification E.==. E.val qid
|
||||
E.&&. lrl_old E.^. LmsReportLogIdent E.==. lrl E.^. LmsReportLogIdent
|
||||
E.&&. lrl_old E.^. LmsReportLogTimestamp E.>. lrl E.^. LmsReportLogTimestamp
|
||||
)
|
||||
return (LmsReportLog
|
||||
E.<# (lrl E.^. LmsReportLogQualification)
|
||||
E.<&> (lrl E.^. LmsReportLogIdent )
|
||||
E.<&> E.nothing
|
||||
E.<&> (lrl E.^. LmsReportLogResult )
|
||||
E.<&> (lrl E.^. LmsReportLogLock )
|
||||
E.<&> E.val now
|
||||
E.<&> E.true)
|
||||
repProc <- deleteWhereCount [LmsReportQualification ==. qid]
|
||||
$logInfoS "LMS" [st|Processed #{tshow repProc} e-learning status reports for qualification #{tshow qid}.|]
|
||||
|
||||
@ -415,11 +461,11 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
|
||||
note <- if saneDate && (lmsUserStatus /= Just LmsSuccess)
|
||||
then do
|
||||
-- WORKAROUND LMS-Bug [supposedly fixed now, but isnt]: sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning
|
||||
let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning
|
||||
ok_unblock <- qualificationUserUnblockByReason qid [qualificationUserUser] Nothing (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log
|
||||
let reason_undo = Left $ "LMS Workaround undoing: " <> tshow (QualificationBlockFailedELearningBy lmsUserIdent)
|
||||
ok_unblock <- qualificationUserUnblockByReason qid [qualificationUserUser] Nothing (Right $ QualificationBlockFailedELearningBy lmsUserIdent) reason_undo False -- affects audit log
|
||||
when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid}|])
|
||||
|
||||
_ok_renew <- renewValidQualificationUsers qid Nothing [qualificationUserUser] -- only unblocked are renewed
|
||||
_ok_renew <- renewValidQualificationUsers qid (Just $ Right $ QualificationRenewELearningBy lmsUserIdent) Nothing [qualificationUserUser] -- only unblocked are renewed
|
||||
-- when (ok==1) $ update luid -- we end lms regardless of whether or not a regular renewal was successful, since BPol users may simultaneoysly have on-premise renewal courses and E-Learnings
|
||||
|
||||
update luid
|
||||
@ -469,7 +515,7 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
|
||||
| otherwise -> return () -- users likely not yet started
|
||||
|
||||
(Entity luid luser, Just (Entity _lulid lulist)) -> do
|
||||
let lReceived = lmsUserlistTimestamp lulist
|
||||
let lReceived = lmsUserlistTimestamp lulist
|
||||
update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotified is only updated upon sending notifications
|
||||
|
||||
when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available
|
||||
|
||||
@ -139,7 +139,8 @@ migrateManual = do
|
||||
, ("idx_qualification_user_block_unblock","CREATE INDEX idx_qualification_user_block_unblock ON \"qualification_user_block\" (\"unblock\")")
|
||||
, ("idx_qualification_user_block_from" ,"CREATE INDEX idx_qualification_user_block_from ON \"qualification_user_block\" (\"from\")")
|
||||
, ("idx_print_job_apc_ident" ,"CREATE INDEX idx_print_job_apc_ident ON \"print_job\" (\"apc_ident\")")
|
||||
, ("idx_user_avs_card_person_id" ,"CREATE INDEX idx_user_avs_card_person_id ON \"user_avs_card\" (\"person_id\")")
|
||||
, ("idx_user_avs_card_person_id" ,"CREATE INDEX idx_user_avs_card_person_id ON \"user_avs_card\" (\"person_id\")")
|
||||
, ("idx_lms_report_log_q_ident_time" ,"CREATE INDEX idx_lms_report_log_q_ident_time ON \"lms_report_log\" (\"qualification\",\"ident\",\"timestamp\")")
|
||||
]
|
||||
where
|
||||
addIndex :: Text -> Sql -> Migration
|
||||
|
||||
@ -12,8 +12,8 @@ module Model.Types.Lms
|
||||
) where
|
||||
|
||||
import Import.NoModel
|
||||
import qualified Data.Map as Map
|
||||
import Data.Map ((!))
|
||||
-- import qualified Data.Map as Map
|
||||
-- import Data.Map ((!))
|
||||
import Database.Persist.Sql
|
||||
import qualified Database.Esqueleto.Experimental as E
|
||||
import qualified Data.Csv as Csv
|
||||
@ -56,27 +56,37 @@ instance Csv.ToField LmsStatus where
|
||||
|
||||
|
||||
-- | Default Block/Unblock reasons
|
||||
data QualificationBlockStandardReason
|
||||
= QualificationBlockFailedELearning
|
||||
data QualificationStandardReason
|
||||
= QualificationRenewELearningBy LmsIdent
|
||||
| QualificationBlockFailedELearningBy LmsIdent
|
||||
| QualificationBlockFailedELearning
|
||||
| QualificationBlockReturnedByCompany
|
||||
| QualificationBlockExpired
|
||||
deriving (Eq, Ord, Enum, Bounded, Universe, Finite)
|
||||
|
||||
-- deriving (Eq, Ord, Enum, Bounded, Universe, Finite)
|
||||
|
||||
instance Show QualificationBlockStandardReason where
|
||||
show QualificationBlockFailedELearning = "E-Learning durchgefallen"
|
||||
show QualificationBlockReturnedByCompany = "Rückgabe Firma"
|
||||
show QualificationBlockExpired = "Abgelaufen"
|
||||
|
||||
qualificationBlockedReasonText :: QualificationBlockStandardReason -> Text
|
||||
instance Show QualificationStandardReason where
|
||||
show (QualificationRenewELearningBy lid) = "E-Learning bestanden für " <> show lid
|
||||
show (QualificationBlockFailedELearningBy lid) = "E-Learning durchgefallen für " <> show lid
|
||||
show QualificationBlockFailedELearning = "E-Learning durchgefallen"
|
||||
show QualificationBlockReturnedByCompany = "Rückgabe Firma"
|
||||
show QualificationBlockExpired = "Abgelaufen"
|
||||
|
||||
{-
|
||||
qualificationBlockedReasonText :: QualificationStandardReason -> Text
|
||||
qualificationBlockedReasonText =
|
||||
let dictionary :: Map.Map QualificationBlockStandardReason Text = Map.fromList [(r, tshow r) | r <- universeF]
|
||||
let dictionary :: Map.Map QualificationStandardReason Text = Map.fromList [(r, tshow r) | r <- universeF]
|
||||
in (dictionary !) -- cannot fail due to universeF
|
||||
|
||||
type QualificationBlockReason = Either Text QualificationBlockStandardReason
|
||||
qualificationBlockedReasonText :: QualificationStandardReason -> Text
|
||||
qualificationBlockedReasonText = tshow
|
||||
-}
|
||||
|
||||
qualificationBlockReasonText :: QualificationBlockReason -> Text
|
||||
qualificationBlockReasonText (Left reason) = reason
|
||||
qualificationBlockReasonText (Right stdreason) = qualificationBlockedReasonText stdreason
|
||||
type QualificationChangeReason = Either Text QualificationStandardReason
|
||||
|
||||
qualificationChangeReasonText :: QualificationChangeReason -> Text
|
||||
qualificationChangeReasonText (Left reason) = reason
|
||||
qualificationChangeReasonText (Right stdreason) = tshow stdreason
|
||||
|
||||
-- | LMS interface requires Bool to be encoded by 0 or 1 only
|
||||
newtype LmsBool = LmsBool { lms2bool :: Bool }
|
||||
|
||||
Reference in New Issue
Block a user