diff --git a/CHANGELOG.md b/CHANGELOG.md index 5d9b7616d..bc81a5744 100644 --- a/CHANGELOG.md +++ b/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) diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index ce59e03ed..113121211 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -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 diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 6e949fc4f..1cab2c3dd 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -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 diff --git a/models/lms.model b/models/lms.model index 616940762..4ba0f3927 100644 --- a/models/lms.model +++ b/models/lms.model @@ -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 \ No newline at end of file diff --git a/nix/docker/version.json b/nix/docker/version.json index 77bb560f7..128f6e4a8 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.45" + "version": "27.4.48" } diff --git a/package-lock.json b/package-lock.json index 31b4132f1..67f032ee5 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.45", + "version": "27.4.48", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 014db6ed0..04e02d31c 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.45", + "version": "27.4.48", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 42efdc6bb..de481c5b4 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.45 +version: 27.4.48 dependencies: - base - yesod diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 50dbc8811..ed3927a03 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -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 diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index d29a0815d..65710b884 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -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 diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 5a02a6d35..46d15e16b 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -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 diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index f104f0073..4f1e6fd97 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -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 diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 827f44496..bdf4c7ca8 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -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 diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index 4224ab7b7..5f9940449 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -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 diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index b8eaf90e1..c0c2097db 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -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 }