From d7a94b96197dbcf90463803a204e082b3b64424a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 3 Nov 2023 14:41:31 +0100 Subject: [PATCH 1/5] chore(lms): include lms ids in qualification audit log events triggered by e-learning --- .../categories/qualification/de-de-formal.msg | 1 + .../categories/qualification/en-eu.msg | 1 + models/lms.model | 9 ++-- src/Audit/Types.hs | 1 + src/Handler/Qualification.hs | 9 ++-- src/Handler/Tutorial/Users.hs | 2 +- src/Handler/Utils/Qualification.hs | 18 ++++---- src/Jobs/Handler/LMS.hs | 20 ++++++--- src/Model/Types/Lms.hs | 42 ++++++++++++------- 9 files changed, 65 insertions(+), 38 deletions(-) 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..bf62961ad 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,6 @@ LmsReport lock Bool -- (0|1) timestamp UTCTime default=now() UniqueLmsReport qualification ident -- required by DBTable - deriving Generic \ No newline at end of file + deriving Generic + +-- LmsAudit removed by commit 71cde92a 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 689a96e2b..cb04bc67b 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) @@ -574,7 +574,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 @@ -612,8 +613,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 1b6cf4359..50e31babf 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -317,7 +317,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act let lrFltrBlock luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsFailed 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 @@ -327,12 +327,13 @@ dispatchJobLmsReports qid = JobHandlerAtomic act 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 -- 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 + -- END LMS WORKAROUND 2 + 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 @@ -379,6 +380,13 @@ dispatchJobLmsReports qid = JobHandlerAtomic act 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 + + -- CONTINUE HERE + -- E.insertSelect $ do + -- lreport <- E.from $ E.table @LmsReport + -- E.where_ $ lreport E.^. LmsReportQualification E.==. E.val qid + -- E.&&. + repProc <- deleteWhereCount [LmsReportQualification ==. qid] $logInfoS "LMS" [st|Processed #{tshow repProc} e-learning status reports for qualification #{tshow qid}.|] @@ -416,11 +424,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 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 } From 7373bc91471adaf71e162514307a0d7c76e663cd Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 3 Nov 2023 15:38:41 +0100 Subject: [PATCH 2/5] chore(lms): re-add dedicated lms audit log table removed in commit 71cde92, but freuquent lms errors make a dedicated log table for all unprocessed input necessary --- models/lms.model | 9 +++++++++ src/Jobs/Handler/LMS.hs | 28 ++++++++++++++++++++-------- 2 files changed, 29 insertions(+), 8 deletions(-) diff --git a/models/lms.model b/models/lms.model index bf62961ad..e72c7fc82 100644 --- a/models/lms.model +++ b/models/lms.model @@ -174,3 +174,12 @@ LmsReport 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() + deriving Generic \ No newline at end of file diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 50e31babf..586b2404e 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -257,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 @@ -379,14 +380,25 @@ 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 - - -- CONTINUE HERE - -- E.insertSelect $ do - -- lreport <- E.from $ E.table @LmsReport - -- E.where_ $ lreport E.^. LmsReportQualification E.==. E.val qid - -- E.&&. - + -- 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.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 )) repProc <- deleteWhereCount [LmsReportQualification ==. qid] $logInfoS "LMS" [st|Processed #{tshow repProc} e-learning status reports for qualification #{tshow qid}.|] From 5f7b2aac262d50d55857bb51816ee50d0757a6f3 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 3 Nov 2023 15:38:41 +0100 Subject: [PATCH 3/5] chore(sap): more test for compileBlocks --- models/lms.model | 9 +++++++++ src/Jobs/Handler/LMS.hs | 28 ++++++++++++++++++++-------- 2 files changed, 29 insertions(+), 8 deletions(-) diff --git a/models/lms.model b/models/lms.model index bf62961ad..e72c7fc82 100644 --- a/models/lms.model +++ b/models/lms.model @@ -174,3 +174,12 @@ LmsReport 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() + deriving Generic \ No newline at end of file diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 50e31babf..586b2404e 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -257,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 @@ -379,14 +380,25 @@ 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 - - -- CONTINUE HERE - -- E.insertSelect $ do - -- lreport <- E.from $ E.table @LmsReport - -- E.where_ $ lreport E.^. LmsReportQualification E.==. E.val qid - -- E.&&. - + -- 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.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 )) repProc <- deleteWhereCount [LmsReportQualification ==. qid] $logInfoS "LMS" [st|Processed #{tshow repProc} e-learning status reports for qualification #{tshow qid}.|] From 2aa14ee2e131308980e27659c2fcabfb69c8a247 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 3 Nov 2023 15:28:42 +0000 Subject: [PATCH 4/5] chore(release): 27.4.46 --- CHANGELOG.md | 8 ++++++++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 12 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 5d9b7616d..d52c1fcc2 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,14 @@ 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.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/nix/docker/version.json b/nix/docker/version.json index 77bb560f7..2e7f57f38 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.45" + "version": "27.4.46" } diff --git a/package-lock.json b/package-lock.json index 31b4132f1..2c3044679 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.45", + "version": "27.4.46", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 014db6ed0..b9d237fac 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.45", + "version": "27.4.46", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 42efdc6bb..5bc45e960 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.45 +version: 27.4.46 dependencies: - base - yesod From d2b20674f54a9bb2b5ce68032faaf14c1a12e052 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 3 Nov 2023 15:29:40 +0000 Subject: [PATCH 5/5] chore(release): 27.4.47 --- CHANGELOG.md | 2 ++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 6 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index d52c1fcc2..231e3501f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,8 @@ 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.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) diff --git a/nix/docker/version.json b/nix/docker/version.json index 2e7f57f38..ab8350d96 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.46" + "version": "27.4.47" } diff --git a/package-lock.json b/package-lock.json index 2c3044679..db2b94dbc 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.46", + "version": "27.4.47", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index b9d237fac..24ecd1bcc 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.46", + "version": "27.4.47", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 5bc45e960..edd6f7dcc 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.46 +version: 27.4.47 dependencies: - base - yesod