diff --git a/CHANGELOG.md b/CHANGELOG.md index 4a3f2b2cb..8f715c83e 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,9 +2,9 @@ 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/t27.4.46...t27.4.47) (2023-10-27) +## [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/t27.4.35...t27.4.46) (2023-10-26) +## [27.4.46](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.45...v27.4.46) (2023-11-03) ### Bug Fixes @@ -28,6 +28,7 @@ All notable changes to this project will be documented in this file. See [standa * **sap:** combineBlocks yet another bug squashed ([3924d14](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3924d14abd868305b42c9d04913536b4999dc45b)) * **sap:** compileBlocks ([b4a88ab](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b4a88abcf85783c350ad2bf3a5e973d13d1eb1f6)) * **sap:** yet another fix for finding date intervals ([fde97b0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fde97b048ab04ab59c9e3f2a2f74bb2c1e996b22)) +* **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 d501899f7..9b562af23 100644 --- a/models/lms.model +++ b/models/lms.model @@ -146,7 +146,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 @@ -155,7 +155,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 @@ -164,6 +164,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 @@ -172,4 +173,15 @@ 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() deriving Generic \ No newline at end of file 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..ace1eaa15 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -256,6 +256,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 @@ -316,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 @@ -326,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 @@ -377,7 +379,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 + -- 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}.|] @@ -415,11 +435,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 }