From 4154b1f26bcdc21d36cd9fd54e8a7379b960ecb8 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 30 Jan 2024 14:44:43 +0100 Subject: [PATCH 01/22] chore(utils): add timeoutHandler to run a sub-handler to be killed by timeout --- src/Handler/Course/Edit.hs | 6 +++--- src/Handler/Utils.hs | 2 ++ src/Handler/Utils/Concurrent.hs | 32 ++++++++++++++++++++++++++++++++ src/Jobs.hs | 8 ++++---- 4 files changed, 41 insertions(+), 7 deletions(-) create mode 100644 src/Handler/Utils/Concurrent.hs diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 127056489..ae88bb64c 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -279,8 +279,8 @@ getCourseNewR = do , E.desc $ courseCreated course] -- most recent created course E.limit 1 return course - template <- case listToMaybe oldCourses of - (Just oldTemplate) -> + template <- case oldCourses of + (oldTemplate:_) -> let newTemplate = courseToForm oldTemplate mempty mempty in return $ Just $ newTemplate { cfCourseId = Nothing @@ -289,7 +289,7 @@ getCourseNewR = do , cfRegTo = Nothing , cfDeRegUntil = Nothing } - Nothing -> do + [] -> do (tidOk,sshOk,cshOk) <- runDB $ (,,) <$> ifMaybeM mbTid True existsKey <*> ifMaybeM mbSsh True existsKey diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 715c910a5..4e2c18e92 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -35,6 +35,8 @@ import Handler.Utils.Qualification as Handler.Utils import Handler.Utils.Term as Handler.Utils +import Handler.Utils.Concurrent as Handler.Utils + import Control.Monad.Logger diff --git a/src/Handler/Utils/Concurrent.hs b/src/Handler/Utils/Concurrent.hs new file mode 100644 index 000000000..60e476a19 --- /dev/null +++ b/src/Handler/Utils/Concurrent.hs @@ -0,0 +1,32 @@ +-- SPDX-FileCopyrightText: 2024 Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +module Handler.Utils.Concurrent + ( module Handler.Utils.Concurrent + ) where + + +import Import +import UnliftIO.Concurrent + + +-- | Run a handler action until it finishes or if it exceeds a given number of microseconds via `registerDelay` +timeoutHandler :: Int -> HandlerFor site a -> HandlerFor site (Maybe a) +timeoutHandler maxWait act = do + innerAct <- handlerToIO + (hresult, tid) <- liftIO $ do + hresult <- newTVarIO Nothing + tid <- forkIO $ innerAct $ do + res <- act + liftIO $ atomically $ writeTVar hresult $ Just res + return (hresult, tid) + res <- liftIO $ do + flag <- registerDelay maxWait + atomically $ do + res <- readTVar hresult + out <- readTVar flag + checkSTM $ out || isJust res + return res + when (isNothing res) $ killThread tid + return res diff --git a/src/Jobs.hs b/src/Jobs.hs index f48922abb..b45b24b82 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -47,7 +47,7 @@ import qualified Control.Monad.Catch as Exc import Data.Time.Zones -import Control.Concurrent.STM (stateTVar, retry) +import Control.Concurrent.STM (stateTVar) import Control.Concurrent.STM.Delay import UnliftIO.Concurrent (forkIO, myThreadId, threadDelay) @@ -260,7 +260,7 @@ manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $ \routeExc -> (nextVal, newQueue) <- MaybeT . lift . fmap jqDequeue $ readTVar chan lift . lift $ writeTVar chan newQueue jobWorkers' <- lift . lift $ jobWorkers <$> readTMVar appJobState - receiver <- maybe (lift $ lift retry) return =<< uniformMay jobWorkers' + receiver <- maybe (lift $ lift retrySTM) return =<< uniformMay jobWorkers' return (nextVal, receiver) whenIsJust next $ \(nextVal, receiver) -> do atomically $ readTVar receiver >>= jqInsert nextVal >>= (writeTVar receiver $!) @@ -373,8 +373,8 @@ execCrontab = do State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab prevExec <- State.get case earliestJob settings prevExec crontab refT of - Nothing -> liftBase retry - Just (_, MatchNone) -> liftBase retry + Nothing -> liftBase retrySTM + Just (_, MatchNone) -> liftBase retrySTM Just x -> return (crontab, x, prevExec) do From d1fce58ec219b52e5d5fe6b8f04aac3df91f83fe Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 30 Jan 2024 15:32:46 +0100 Subject: [PATCH 02/22] refactor(utils): minor changes for timeoutHandler --- src/Handler/Utils.hs | 2 +- src/Handler/Utils/Concurrent.hs | 26 ++++++++++++++++---------- 2 files changed, 17 insertions(+), 11 deletions(-) diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 4e2c18e92..4648cf647 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -35,7 +35,7 @@ import Handler.Utils.Qualification as Handler.Utils import Handler.Utils.Term as Handler.Utils -import Handler.Utils.Concurrent as Handler.Utils +-- import Handler.Utils.Concurrent as Handler.Utils -- only imported when needed import Control.Monad.Logger diff --git a/src/Handler/Utils/Concurrent.hs b/src/Handler/Utils/Concurrent.hs index 60e476a19..1faaff498 100644 --- a/src/Handler/Utils/Concurrent.hs +++ b/src/Handler/Utils/Concurrent.hs @@ -3,30 +3,36 @@ -- SPDX-License-Identifier: AGPL-3.0-or-later module Handler.Utils.Concurrent - ( module Handler.Utils.Concurrent + ( module Handler.Utils.Concurrent ) where +-- NOTE: use `retrySTM` and `checkSTM` instead of `retry` or `check` import Import -import UnliftIO.Concurrent +import UnliftIO.Concurrent as Handler.Utils.Concurrent hiding (yield) + -- | Run a handler action until it finishes or if it exceeds a given number of microseconds via `registerDelay` timeoutHandler :: Int -> HandlerFor site a -> HandlerFor site (Maybe a) timeoutHandler maxWait act = do innerAct <- handlerToIO - (hresult, tid) <- liftIO $ do + (hresult, tid) <- liftIO $ do hresult <- newTVarIO Nothing - tid <- forkIO $ innerAct $ do - res <- act - liftIO $ atomically $ writeTVar hresult $ Just res + tid <- forkIO $ do + res <- innerAct act + atomically $ writeTVar hresult $ Just res return (hresult, tid) res <- liftIO $ do flag <- registerDelay maxWait - atomically $ do - res <- readTVar hresult + atomically $ do out <- readTVar flag + res <- readTVar hresult checkSTM $ out || isJust res return res - when (isNothing res) $ killThread tid - return res + case res of + Nothing -> liftIO $ do + killThread tid + readTVarIO hresult -- read once more after kill to ensure that any result is noticed + _ -> return res + From fd388b91f452c3c85d0aef67af8e5376afcae237 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 30 Jan 2024 18:42:13 +0100 Subject: [PATCH 03/22] chore(lpr): error log as interface log --- models/audit.model | 7 +++--- src/Audit.hs | 4 ++- src/Audit/Types.hs | 1 + src/Handler/Admin.hs | 8 +++--- src/Handler/LMS/Learners.hs | 2 +- src/Handler/LMS/Report.hs | 3 ++- src/Handler/PrintCenter.hs | 50 ++++++++++++++++++++++++++++++++++++- src/Handler/SAP.hs | 2 +- src/Jobs/Handler/LMS.hs | 4 +-- src/Utils/Print.hs | 24 ++++++++++++------ 10 files changed, 84 insertions(+), 21 deletions(-) diff --git a/models/audit.model b/models/audit.model index fd0889392..6a1277b7a 100644 --- a/models/audit.model +++ b/models/audit.model @@ -14,9 +14,10 @@ TransactionLog InterfaceLog interface Text subtype Text - write Bool -- requestMethod /= GET, i.e. True implies a write to FRADrive + write Bool -- requestMethod /= GET, i.e. True implies a write to FRADrive time UTCTime - rows Int Maybe -- number of datasets transmitted - info Text -- addtional status information + rows Int Maybe -- number of datasets transmitted + info Text -- addtional status information + success Bool default=true -- false logs a failure; but it will be overwritten by next transaction, but logged in TransactionLog UniqueInterfaceSubtypeWrite interface subtype write deriving Eq Read Show Generic \ No newline at end of file diff --git a/src/Audit.hs b/src/Audit.hs index e13c769b9..0e93fc9e7 100644 --- a/src/Audit.hs +++ b/src/Audit.hs @@ -123,11 +123,12 @@ logInterface :: ( AuthId (HandlerSite m) ~ Key User ) => Text -- ^ Interface that is used -> Text -- ^ Subtype of the interface, if any + -> Bool -- ^ Success=True, Failure=False -> Maybe Int -- ^ Number of transmitted datasets -> Text -- ^ Any additional information -> ReaderT (YesodPersistBackend (HandlerSite m)) m () -- ^ Log a transaction using information available from `HandlerT`, also calls `audit` -logInterface interfaceLogInterface interfaceLogSubtype interfaceLogRows interfaceLogInfo = do +logInterface interfaceLogInterface interfaceLogSubtype interfaceLogSuccess interfaceLogRows interfaceLogInfo = do interfaceLogTime <- liftIO getCurrentTime interfaceLogWrite <- (methodGet /=) . Wai.requestMethod . reqWaiRequest <$> getRequest deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- always replace, deleteBy & insert seems to be safest and fastest @@ -138,4 +139,5 @@ logInterface interfaceLogInterface interfaceLogSubtype interfaceLogRows interfac , transactionInterfaceWrite = interfaceLogWrite , transactionInterfaceRows = interfaceLogRows , transactionInterfaceInfo = interfaceLogInfo + , transactionInterfaceSuccess = Just interfaceLogSuccess } diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index b7ebe8807..976171ec4 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -240,6 +240,7 @@ data Transaction , transactionInterfaceWrite :: Bool -- True implies a write to FRADrive , transactionInterfaceRows :: Maybe Int , transactionInterfaceInfo :: Text + , transactionInterfaceSuccess :: Maybe Bool -- Just False implies a failure; Maybe used to achieve backwards compatibility } deriving (Eq, Ord, Read, Show, Generic) diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 2b9f17857..fbaf5df6e 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -257,8 +257,8 @@ mkInterfaceLogTable flagError cutOffOldTime = do mkBadInfo _ _ = return mempty writeAvsSynchStats okRows (fromMaybe cutOffOldTime -> okTime) badInfo = void $ upsertBy (UniqueInterfaceSubtypeWrite "AVS" "Synch" True) - (InterfaceLog "AVS" "Synch" True okTime okRows badInfo) - [InterfaceLogTime =. okTime, InterfaceLogRows =. okRows, InterfaceLogInfo =. badInfo] + (InterfaceLog "AVS" "Synch" True okTime okRows badInfo (null badInfo)) + [InterfaceLogTime =. okTime, InterfaceLogRows =. okRows, InterfaceLogInfo =. badInfo, InterfaceLogSuccess =. null badInfo] --case $(unValueN 3) <$> avsSynchStats of case avsSynchStats of ((E.Value True , E.Value okRows, E.Value okTime):(E.Value False, E.Value badRows, E.Value badTime):_) -> @@ -287,8 +287,8 @@ mkInterfaceLogTable flagError cutOffOldTime = do , sortable (Just "time") (i18nCell MsgInterfaceLastSynch ) $ dateTimeCell . view (resultILog . _interfaceLogTime) , sortable (Just "rows") (i18nCell MsgTableRows ) $ cellMaybe numCell . view (resultILog . _interfaceLogRows) , sortable Nothing (textCell "Info" ) $ \(view resultILog -> ilt) -> case ilt of - InterfaceLog "AVS" "Synch" True _ _ i -> anchorCell ProblemAvsErrorR $ toWgt i - InterfaceLog _ _ _ _ _ i -> textCell i + InterfaceLog "AVS" "Synch" True _ _ i _ -> anchorCell ProblemAvsErrorR $ toWgt i + InterfaceLog _ _ _ _ _ i _ -> textCell i ] dbtSorting = mconcat [ singletonMap "interface" $ SortColumn (E.^. InterfaceLogInterface) diff --git a/src/Handler/LMS/Learners.hs b/src/Handler/LMS/Learners.hs index 3e4b00b24..1b149b95f 100644 --- a/src/Handler/LMS/Learners.hs +++ b/src/Handler/LMS/Learners.hs @@ -213,6 +213,6 @@ getLmsLearnersDirectR sid qsh = do $logInfoS "LMS" msg addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\"" csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered - <* runDB (logInterface "LMS" (ciOriginal qsh) (Just nr) "") + <* runDB (logInterface "LMS" (ciOriginal qsh) True (Just nr) "") -- direct Download see: -- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod \ No newline at end of file diff --git a/src/Handler/LMS/Report.hs b/src/Handler/LMS/Report.hs index 201c2eab4..a0a6fefb6 100644 --- a/src/Handler/LMS/Report.hs +++ b/src/Handler/LMS/Report.hs @@ -315,12 +315,13 @@ postLmsReportDirectR sid qsh = do case enr of Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error $logWarnS "LMS" $ "Report upload failed parsing: " <> tshow e + logInterface "LMS" (ciOriginal qsh) False Nothing "" return (badRequest400, "Exception: " <> tshow e) Right nr -> do let msg = "Success. LMS Report upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ". " $logInfoS "LMS" msg when (nr > 0) $ queueDBJob $ JobLmsReports qid - logInterface "LMS" (ciOriginal qsh) (Just nr) "" + logInterface "LMS" (ciOriginal qsh) True (Just nr) "" return (ok200, msg) [] -> do let msg = "Report upload file missing." diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 6be31bf20..3fdd24b35 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -11,6 +11,7 @@ module Handler.PrintCenter , getPrintSendR , postPrintSendR , getPrintAckR , postPrintAckR , postPrintAckDirectR + , getPrintLogR ) where import Import @@ -26,7 +27,7 @@ import Database.Esqueleto.Utils.TH import Utils.Print --- import Data.Aeson (encode) +import qualified Data.Aeson as Aeson -- import qualified Data.Text as Text -- import qualified Data.Set as Set @@ -471,3 +472,50 @@ postPrintAckDirectR = do $logErrorS "APC" msg return (badRequest400, msg) sendResponseStatus status msg -- must be outside of runDB; otherwise transaction is rolled back + + +getPrintLogR :: Handler Html +getPrintLogR = do + let + logDBTable = DBTable{..} + where + resultLog :: Lens' (DBRow (TransactionLog, Aeson.Result Transaction)) TransactionLog + resultLog = _dbrOutput . _1 + + resultTrans :: Lens' (DBRow (TransactionLog, Aeson.Result Transaction)) (Aeson.Result Transaction) + resultTrans = _dbrOutput . _2 + + dbtIdent = "lpr-log" :: Text + dbtSQLQuery l = do + E.where_ $ E.val "LPR" E.==. l E.^. TransactionLogInfo E.->>. "interface-name" + return l + dbtRowKey = (E.^. TransactionLogId) + dbtProj = dbtProjSimple $ \(Entity _ l) -> do + return (l, Aeson.fromJSON $ transactionLogInfo l) + dbtColonnade = dbColonnade $ mconcat + [ sortable (Just "time") (i18nCell MsgSystemMessageTimestamp) $ \(view $ resultLog . to transactionLogTime -> t) -> dateTimeCell t + , sortable Nothing (textCell "Status") $ \(view resultTrans -> jt) -> + case jt of + (Aeson.Error _) -> mempty + (Aeson.Success t) -> cellMaybe iconBoolCell $ transactionInterfaceSuccess t + , sortable Nothing (i18nCell MsgSystemMessageContent) $ \(view resultTrans -> jt) -> + case jt of + (Aeson.Error msg) -> stringCell msg + (Aeson.Success t) -> textCell $ transactionInterfaceInfo t + ] + dbtSorting = mconcat + [ singletonMap "time" $ SortColumn (E.^. TransactionLogTime) + ] + dbtFilter = mempty + dbtFilterUI = mempty + + dbtStyle = def + dbtParams = def + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + validator = def & defaultSorting [ SortDescBy "time" ] + tbl <- runDB $ dbTableDB' validator logDBTable + siteLayoutMsg MsgMenuApc $ do + setTitleI MsgMenuApc + [whamlet|^{tbl}|] diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index 4fb8c2c5d..3414b618b 100644 --- a/src/Handler/SAP.hs +++ b/src/Handler/SAP.hs @@ -141,7 +141,7 @@ getQualificationSAPDirectR = do msg = "Qualification download file " <> csvSheetName <> " containing " <> tshow nr <> " rows" quals = Text.intercalate ", " $ nubOrd $ mapMaybe (view (_2 . E._unValue)) qualUsers $logInfoS "SAP" msg - let logInt = runDB $ logInterface "SAP" quals (Just nr) "" + let logInt = runDB $ logInterface "SAP" quals True (Just nr) "" addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\"" csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered <* logInt diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 763f46b39..12ab943f2 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -117,7 +117,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act NotificationQualificationExpiry { nQualification = qid, nExpiry = uex } } forM_ renewalUsers (queueDBJob . usr_job) - logInterface "LMS" (qshort <> "-enq") (Just $ length renewalUsers) "" + logInterface "LMS" (qshort <> "-enq") True (Just $ length renewalUsers) "" dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act @@ -259,7 +259,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act deleteWhere [LmsUserQualification ==. qid, LmsUserIdent <-. delusers] -- deleteWhere [LmsAuditQualification ==. qid, LmsAuditIdent <-. delusers] deleteWhere [LmsReportLogQualification ==. qid, LmsReportLogTimestamp <. auditCutoff ] - logInterface "LMS" (qshort <> "-deq") (Just nrBlocked) (tshow nrExpired <> " expired") + logInterface "LMS" (qshort <> "-deq") True (Just nrBlocked) (tshow nrExpired <> " expired") dispatchJobLmsReports :: QualificationId -> JobHandler UniWorX diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index 7735f1f09..8687158b8 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -269,13 +269,17 @@ printLetter' pji pdf = do -- printJobFile <- sinkFileDB True $ yield $ LBS.toStrict pdf -- for PrintJobFile :: FileContentReference use this code printJobFile = LBS.toStrict pdf printJobAcknowledged = Nothing + qshort <- ifMaybeM printJobQualification "-" $ fmap (maybe "_" $ CI.original . qualificationShorthand ) . get + let logInter = flip (logInterface "LPR" qshort) (Just 1) lprPDF printJobFilename pdf >>= \case Left err -> do + logInter False err return $ Left err Right ok -> do printJobCreated <- liftIO getCurrentTime -- updateWhere [PrintJobLmsUser ==. printJobLmsUser] [PrintJobLmsUser =. Nothing] -- only one printJob per LmsUser is allowed, since otherwise the qualification table contains double rows - insert_ PrintJob {..} + insert_ PrintJob{..} + logInter True ok return $ Right (ok, printJobFilename) reprintPDF :: Bool -> PrintJobId -> DB (Either Text Text) @@ -283,13 +287,19 @@ reprintPDF ignoreReroute pjid = maybeM (return $ Left "Print job id is unknown." where reprint :: PrintJob -> DB (Either Text Text) reprint pj@PrintJob{..} = do + qshort <- ifMaybeM printJobQualification "-" $ fmap (maybe "_" $ CI.original . qualificationShorthand ) . get + let logInter = flip (logInterface "LPR" qshort) (Just 1) result <- lprPDF' ignoreReroute printJobFilename $ LBS.fromStrict printJobFile - whenIsRight result $ const $ do - now <- liftIO getCurrentTime - insert_ pj{ printJobAcknowledged = Nothing - , printJobCreated = now - -- , printJobApcIdent = ??? cannot be modified here, since it is included inside the PDF - } + case result of + Left err -> + logInter False err + Right m -> do + logInter True m + now <- liftIO getCurrentTime + insert_ pj{ printJobAcknowledged = Nothing + , printJobCreated = now + -- , printJobApcIdent = ??? cannot be modified here, since it is included inside the PDF + } return result {- From 798a07e36c0ce2abb6c0d267e008c0e793b89e97 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 31 Jan 2024 12:43:12 +0100 Subject: [PATCH 04/22] chore(log): lpr log page made accessible --- .../utils/navigation/menu/de-de-formal.msg | 1 + .../uniworx/utils/navigation/menu/en-eu.msg | 1 + routes | 1 + src/Audit.hs | 2 +- src/Foundation/Navigation.hs | 13 +++++++- src/Handler/Admin.hs | 3 +- src/Handler/PrintCenter.hs | 33 +++++++++++-------- 7 files changed, 37 insertions(+), 17 deletions(-) diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 502f3d09f..a2b93a00d 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -145,6 +145,7 @@ MenuLdap: LDAP Schnittstelle MenuApc: Druckerei MenuPrintSend: Manueller Briefversand MenuPrintDownload: Brief herunterladen +MenuPrintLog: LPR Schnittstelle MenuApiDocs: API-Dokumentation (Englisch) MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger) diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 9fcb4b2a6..6fe895c22 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -145,6 +145,7 @@ MenuLdap: LDAP Interface MenuApc: Printing MenuPrintSend: Send Letter MenuPrintDownload: Download Letter +MenuPrintLog: LPR Interface MenuApiDocs: API documentation MenuSwagger: OpenAPI 2.0 (Swagger) diff --git a/routes b/routes index 3f30c960a..752405690 100644 --- a/routes +++ b/routes @@ -82,6 +82,7 @@ /print/acknowledge/direct PrintAckDirectR POST !system-printer /print/send PrintSendR GET POST /print/download/#CryptoUUIDPrintJob PrintDownloadR GET !system-printer +/print/log PrintLogR GET !system-printer /health HealthR GET !free /instance InstanceR GET !free diff --git a/src/Audit.hs b/src/Audit.hs index 0e93fc9e7..f26af2d80 100644 --- a/src/Audit.hs +++ b/src/Audit.hs @@ -128,7 +128,7 @@ logInterface :: ( AuthId (HandlerSite m) ~ Key User -> Text -- ^ Any additional information -> ReaderT (YesodPersistBackend (HandlerSite m)) m () -- ^ Log a transaction using information available from `HandlerT`, also calls `audit` -logInterface interfaceLogInterface interfaceLogSubtype interfaceLogSuccess interfaceLogRows interfaceLogInfo = do +logInterface (Text.strip -> interfaceLogInterface) (Text.strip -> interfaceLogSubtype) interfaceLogSuccess interfaceLogRows (Text.strip -> interfaceLogInfo) = do interfaceLogTime <- liftIO getCurrentTime interfaceLogWrite <- (methodGet /=) . Wai.requestMethod . reqWaiRequest <$> getRequest deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- always replace, deleteBy & insert seems to be safest and fastest diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index ce7d466f4..374b4d566 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -134,6 +134,7 @@ breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenter breadcrumb PrintDownloadR{} = i18nCrumb MsgMenuPrintDownload $ Just PrintCenterR breadcrumb PrintAckR{} = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR -- never displayed breadcrumb PrintAckDirectR{}= i18nCrumb MsgMenuPrintSend $ Just PrintCenterR -- never displayed +breadcrumb PrintLogR = i18nCrumb MsgMenuPrintLog $ Just PrintCenterR breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR breadcrumb (SchoolR ssh sRoute) = case sRoute of @@ -2435,8 +2436,18 @@ pageActions PrintCenterR = do , navForceActive = False } } + printLog = NavPageActionSecondary + { navLink = NavLink + { navLabel = MsgMenuPrintLog + , navRoute = PrintLogR + , navAccess' = NavAccessTrue + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + } dayLinks <- mapM toDayAck $ Map.toAscList dayMap - return $ manualSend : take 9 dayLinks + return $ manualSend : printLog : take 9 dayLinks pageActions AdminCrontabR = return [ NavPageActionPrimary diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index fbaf5df6e..92dcac020 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -287,7 +287,8 @@ mkInterfaceLogTable flagError cutOffOldTime = do , sortable (Just "time") (i18nCell MsgInterfaceLastSynch ) $ dateTimeCell . view (resultILog . _interfaceLogTime) , sortable (Just "rows") (i18nCell MsgTableRows ) $ cellMaybe numCell . view (resultILog . _interfaceLogRows) , sortable Nothing (textCell "Info" ) $ \(view resultILog -> ilt) -> case ilt of - InterfaceLog "AVS" "Synch" True _ _ i _ -> anchorCell ProblemAvsErrorR $ toWgt i + InterfaceLog "AVS" "Synch" True _ _ i _ -> anchorCell ProblemAvsErrorR $ toWgt $ bool i "AVS-Log" $ null i + InterfaceLog "LPR" _ _ _ _ i _ -> anchorCell PrintLogR $ toWgt $ bool i "LPR-Log" $ null i InterfaceLog _ _ _ _ _ i _ -> textCell i ] dbtSorting = mconcat diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 3fdd24b35..bdc6e4572 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -485,37 +485,42 @@ getPrintLogR = do resultTrans :: Lens' (DBRow (TransactionLog, Aeson.Result Transaction)) (Aeson.Result Transaction) resultTrans = _dbrOutput . _2 + tCell' err c dbr = case view resultTrans dbr of + (Aeson.Error msg) -> err msg -- should not happen, due to query filter + (Aeson.Success t) -> c t + tCellErr = tCell' stringCell + tCell = tCell' $ const mempty + dbtIdent = "lpr-log" :: Text dbtSQLQuery l = do E.where_ $ E.val "LPR" E.==. l E.^. TransactionLogInfo E.->>. "interface-name" + -- E.&&. E.val "interface" E.==. l E.^. TransactionLogInfo E.->>. "transaction" -- not necessary return l dbtRowKey = (E.^. TransactionLogId) dbtProj = dbtProjSimple $ \(Entity _ l) -> do return (l, Aeson.fromJSON $ transactionLogInfo l) dbtColonnade = dbColonnade $ mconcat - [ sortable (Just "time") (i18nCell MsgSystemMessageTimestamp) $ \(view $ resultLog . to transactionLogTime -> t) -> dateTimeCell t - , sortable Nothing (textCell "Status") $ \(view resultTrans -> jt) -> - case jt of - (Aeson.Error _) -> mempty - (Aeson.Success t) -> cellMaybe iconBoolCell $ transactionInterfaceSuccess t - , sortable Nothing (i18nCell MsgSystemMessageContent) $ \(view resultTrans -> jt) -> - case jt of - (Aeson.Error msg) -> stringCell msg - (Aeson.Success t) -> textCell $ transactionInterfaceInfo t + [ sortable (Just "time") (i18nCell MsgSystemMessageTimestamp) $ \(view $ resultLog . to transactionLogTime -> t) -> dateTimeCell t + , sortable (Just "status") (textCell "Status") $ tCell (cellMaybe iconBoolCell . transactionInterfaceSuccess) + , sortable (Just "subtype") (i18nCell MsgInterfaceSubtype) $ tCell ( textCell . transactionInterfaceSubtype) + , sortable (Just "info") (i18nCell MsgSystemMessageContent) $ tCellErr ( textCell . transactionInterfaceInfo) ] dbtSorting = mconcat - [ singletonMap "time" $ SortColumn (E.^. TransactionLogTime) + [ singletonMap "time" $ SortColumn (E.^. TransactionLogTime) + , singletonMap "status" $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-success") + , singletonMap "subtype" $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-subtype") + , singletonMap "info" $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-info" ) ] - dbtFilter = mempty + dbtFilter = mempty dbtFilterUI = mempty - dbtStyle = def + dbtStyle = def dbtParams = def dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing dbtExtraReps = [] validator = def & defaultSorting [ SortDescBy "time" ] tbl <- runDB $ dbTableDB' validator logDBTable - siteLayoutMsg MsgMenuApc $ do - setTitleI MsgMenuApc + siteLayoutMsg MsgMenuPrintLog $ do + setTitleI MsgMenuPrintLog [whamlet|^{tbl}|] From a592ad7094762d17cafd592dd5c950d570e3af2b Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 31 Jan 2024 18:03:25 +0100 Subject: [PATCH 05/22] chore(health): WIP new interface health handlers --- models/audit.model | 11 +++++++- models/lms.model | 2 +- routes | 30 +++++++++++---------- src/Database/Esqueleto/Utils.hs | 11 ++++++++ src/Handler/Health/Interfaces.hs | 46 ++++++++++++++++++++++++++++++++ 5 files changed, 84 insertions(+), 16 deletions(-) create mode 100644 src/Handler/Health/Interfaces.hs diff --git a/models/audit.model b/models/audit.model index 6a1277b7a..defb5c391 100644 --- a/models/audit.model +++ b/models/audit.model @@ -20,4 +20,13 @@ InterfaceLog info Text -- addtional status information success Bool default=true -- false logs a failure; but it will be overwritten by next transaction, but logged in TransactionLog UniqueInterfaceSubtypeWrite interface subtype write - deriving Eq Read Show Generic \ No newline at end of file + deriving Eq Read Show Generic + +InterfaceHealth + interface Text + subtype Text Maybe + write Bool Maybe + hours Int + message Text Maybe + UniqueInterfaceHealth interface subtype write !force -- Note that nullable fields must be either empty or unique + deriving Eq Read Show Generic diff --git a/models/lms.model b/models/lms.model index d9f4c1b7e..9e96df730 100644 --- a/models/lms.model +++ b/models/lms.model @@ -20,7 +20,7 @@ Qualification SchoolQualificationShort school shorthand -- must be unique per school and shorthand SchoolQualificationName school name -- must be unique per school and name -- across all schools, only one qualification may be a driving licence: - UniqueQualificationAvsLicence avsLicence !force + UniqueQualificationAvsLicence avsLicence !force -- either empty or unique -- NOTE: two NULL values are not equal for the purpose of Uniqueness constraints! deriving Eq Generic diff --git a/routes b/routes index 752405690..ab8d094ae 100644 --- a/routes +++ b/routes @@ -84,20 +84,22 @@ /print/download/#CryptoUUIDPrintJob PrintDownloadR GET !system-printer /print/log PrintLogR GET !system-printer -/health HealthR GET !free -/instance InstanceR GET !free -/info InfoR GET !free -/info/lecturer InfoLecturerR GET !free -/info/supervisor InfoSupervisorR GET !free -/info/legal LegalR GET !free -/info/glossary GlossaryR GET !free -/info/faq FaqR GET !free -/info/terms-of-use TermsOfUseR GET !free -/info/payments PaymentsR GET !free -/imprint ImprintR GET !free -/data-protection DataProtectionR GET !free -/version VersionR GET !free -/status StatusR GET !free +/health HealthR GET !free +/health/interfaces HealthInterfacesR GET !free +/health/interface/*Text HealthInterfaceR GET !free +/instance InstanceR GET !free +/info InfoR GET !free +/info/lecturer InfoLecturerR GET !free +/info/supervisor InfoSupervisorR GET !free +/info/legal LegalR GET !free +/info/glossary GlossaryR GET !free +/info/faq FaqR GET !free +/info/terms-of-use TermsOfUseR GET !free +/info/payments PaymentsR GET !free +/imprint ImprintR GET !free +/data-protection DataProtectionR GET !free +/version VersionR GET !free +/status StatusR GET !free /help HelpR GET POST !free diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 1e8ecfe7e..65e826b34 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -700,6 +700,17 @@ dayMaybe = E.unsafeSqlCastAs "date" interval :: CalendarDiffDays -> E.SqlExpr (E.Value Day) -- E.+=. requires both types to be the same, so we use Day -- interval _ = E.unsafeSqlCastAs "interval" $ E.unsafeSqlValue "'P2Y'" -- tested working example +interval = E.unsafeSqlCastAs "interval". E.unsafeSqlValue . wrapSqlString . Text.Builder.fromString . iso8601Show + where + singleQuote = Text.Builder.singleton '\'' + wrapSqlString b = singleQuote <> b <> singleQuote + +addHours :: E.SqlExpr (E.Value Int) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value UTCTime) +addHours + -- E.+=. requires both types to be the same, so we use Day +-- interval _ = E.unsafeSqlCastAs "interval" $ E.unsafeSqlValue "'P2Y'" -- tested working example + + interval = E.unsafeSqlCastAs "interval". E.unsafeSqlValue . wrapSqlString . Text.Builder.fromString . iso8601Show where singleQuote = Text.Builder.singleton '\'' diff --git a/src/Handler/Health/Interfaces.hs b/src/Handler/Health/Interfaces.hs new file mode 100644 index 000000000..8c87ee7c7 --- /dev/null +++ b/src/Handler/Health/Interfaces.hs @@ -0,0 +1,46 @@ +-- SPDX-FileCopyrightText: 2024 Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +module Handler.Health.Interfaces where + +import Import + +import Database.Esqueleto.Experimental ((:&)(..)) +import qualified Database.Esqueleto.Experimental as E +import qualified Database.Esqueleto.Utils as E + + +getHealthInterfacesR :: Handler Html +getHealthInterfacesR = auxHealthInterfaces [] + +getHealthInterfaceR :: [Text] -> Handler Html +getHealthInterfaceR ["*"] = auxHealthInterfaces [] +getHealthInterfaceR [i] = auxHealthInterfaces [(i, Nothing, Nothing)] +getHealthInterfaceR [i,s] = auxHealthInterfaces [(i, Just s, Nothing)] +getHealthInterfaceR [i,s, Text.toLower . Text.strip -> w] + | w `elem` ["1", "t", "true" ,"wahr", "w"] = auxHealthInterfaces [(i, Just s, Just True )] + | w `elem` ["0", "f", "false","falsch"] = auxHealthInterfaces [(i, Just s, Just False)] +-- TODO: also allow '*' for wildcards and cycle; better write separate parse function +getHealthInterfaceR _ = notFound + + +auxHealthInterfaces :: [(Text, Maybe Text, Maybe Bool)] -> Handler Html +auxHealthInterfaces interfs = do + _TODO <- runDB $ E.select $ do + (ilog :& ihealth) <- E.from (E.table @InterfaceLog + `E.leftJoin` E.table @InterfaceHealth + `E.on` (\(ilog :& ihealth) -> + ilog E.^. InterfaceLogInterface E.=?. ihealth E.?. InterfaceHealthInterface + E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype) + E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite ) + )) + unless (null interfs) $ + E.where_ $ E.or [ ilog E.^. InterfaceInterface E.==. E.val ifce + E.&&. ilog E.^. InterfaceSubtype E.=~. E.val subt + E.&&. ilog E.^. InterfaceWrite E.=~. E.val writ + | (ifce, subt, writ) <- interfs + ] + let ihour = E.coalesceDefault [E.joinV (ihealth E.?. InterfaceHealthHours)] (E.val 48) + return (ilog, ihour, E.joinV $ ihealth E.?. InterfaceHealthMessage) + notFound \ No newline at end of file From 47f853bd4af0c639a736e149bbeeef73438bc032 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 1 Feb 2024 10:35:31 +0100 Subject: [PATCH 06/22] chore(health): stub that compiles --- .../utils/navigation/menu/de-de-formal.msg | 1 + .../uniworx/utils/navigation/menu/en-eu.msg | 1 + routes | 3 +- src/Application.hs | 1 + src/Database/Esqueleto/Utils.hs | 12 ---- src/Foundation/Navigation.hs | 18 ++++- src/Handler/Health/Interface.hs | 70 +++++++++++++++++++ src/Handler/Health/Interfaces.hs | 46 ------------ 8 files changed, 89 insertions(+), 63 deletions(-) create mode 100644 src/Handler/Health/Interface.hs delete mode 100644 src/Handler/Health/Interfaces.hs diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index a2b93a00d..c94663cfc 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -23,6 +23,7 @@ MenuPayments: Zahlungsbedingungen MenuInstance: Instanz-Identifikation MenuHealth: Instanz-Zustand +MenuHealthInterface: Schnittstellen Zustand MenuHelp: Hilfe MenuProfile: Anpassen MenuLogin !ident-ok: Login diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 6fe895c22..e09c56ef1 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -23,6 +23,7 @@ MenuPayments: Payment Terms MenuInstance: Instance identification MenuHealth: Instance health +MenuHealthInterface: Interface health MenuHelp: Support MenuProfile: Settings MenuLogin: Login diff --git a/routes b/routes index ab8d094ae..41f6d1f90 100644 --- a/routes +++ b/routes @@ -85,8 +85,7 @@ /print/log PrintLogR GET !system-printer /health HealthR GET !free -/health/interfaces HealthInterfacesR GET !free -/health/interface/*Text HealthInterfaceR GET !free +/health/interface/+Texts HealthInterfaceR GET !free /instance InstanceR GET !free /info InfoR GET !free /info/lecturer InfoLecturerR GET !free diff --git a/src/Application.hs b/src/Application.hs index 45f24768e..4b60ecb39 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -145,6 +145,7 @@ import Handler.Material import Handler.CryptoIDDispatch import Handler.SystemMessage import Handler.Health +import Handler.Health.Interface import Handler.Exam import Handler.ExamOffice import Handler.Metrics diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 65e826b34..8a0a02a17 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -705,18 +705,6 @@ interval = E.unsafeSqlCastAs "interval". E.unsafeSqlValue . wrapSqlString . Text singleQuote = Text.Builder.singleton '\'' wrapSqlString b = singleQuote <> b <> singleQuote -addHours :: E.SqlExpr (E.Value Int) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value UTCTime) -addHours - -- E.+=. requires both types to be the same, so we use Day --- interval _ = E.unsafeSqlCastAs "interval" $ E.unsafeSqlValue "'P2Y'" -- tested working example - - -interval = E.unsafeSqlCastAs "interval". E.unsafeSqlValue . wrapSqlString . Text.Builder.fromString . iso8601Show - where - singleQuote = Text.Builder.singleton '\'' - wrapSqlString b = singleQuote <> b <> singleQuote - - infixl 6 `diffDays`, `diffTimes` diffDays :: E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Int) diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 374b4d566..72095a86d 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -165,9 +165,10 @@ breadcrumb FaqR = i18nCrumb MsgBreadcrumbFaq $ Just InfoR breadcrumb HelpR = i18nCrumb MsgMenuHelp Nothing -breadcrumb HealthR = i18nCrumb MsgMenuHealth Nothing -breadcrumb InstanceR = i18nCrumb MsgMenuInstance Nothing -breadcrumb StatusR = i18nCrumb MsgMenuHealth Nothing -- never displayed +breadcrumb HealthR = i18nCrumb MsgMenuHealth Nothing +breadcrumb (HealthInterfaceR _) = i18nCrumb MsgMenuHealthInterface (Just HealthR) +breadcrumb InstanceR = i18nCrumb MsgMenuInstance Nothing +breadcrumb StatusR = i18nCrumb MsgMenuHealth Nothing -- never displayed breadcrumb QualificationAllR = i18nCrumb MsgMenuQualifications Nothing breadcrumb (QualificationSchoolR ssh ) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ SchoolListR) $ do -- redirect only, used in other breadcrumbs @@ -1334,6 +1335,17 @@ pageActions HealthR = return } , navChildren = [] } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuHealthInterface + , navRoute = HealthInterfaceR [] + , navAccess' = NavAccessTrue + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } ] pageActions InstanceR = return [ NavPageActionPrimary diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs new file mode 100644 index 000000000..6592b6f56 --- /dev/null +++ b/src/Handler/Health/Interface.hs @@ -0,0 +1,70 @@ +-- SPDX-FileCopyrightText: 2024 Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +module Handler.Health.Interface + ( + getHealthInterfaceR + ) + where + +import Import + +-- import qualified Data.Set as Set +import qualified Data.Text as Text + +import Database.Esqueleto.Experimental ((:&)(..)) +import qualified Database.Esqueleto.Experimental as E +import qualified Database.Esqueleto.Utils as E + + +identifyInterfaces :: [Text] -> [Unique InterfaceHealth] +identifyInterfaces [] = [] +identifyInterfaces [i] = [UniqueInterfaceHealth i Nothing Nothing] +identifyInterfaces [i,s] = [UniqueInterfaceHealth i (wc2null s) Nothing] +identifyInterfaces (i:s:w:r) = UniqueInterfaceHealth i (wc2null s) (pbool w) : identifyInterfaces r + +-- | identify a wildcard argument +wc2null :: Text -> Maybe Text +wc2null "." = Nothing +-- wc2null "-" = Nothing -- used as wildcard subtype in lpr interface +wc2null "_" = Nothing +wc2null o = Just o + +-- | sloppily parse a boolean, also see Model.Types.Avs.SloppyBool +pbool :: Text -> Maybe Bool +pbool (Text.toLower . Text.strip -> w) + | w `elem` ["1", "t", "true" ,"wahr", "w"] = Just True + | w `elem` ["0", "f", "false","falsch"] = Just False + | otherwise = Nothing + + +getHealthInterfaceR :: [Text] -> Handler Html +getHealthInterfaceR ris = do + let interfs = identifyInterfaces ris + res <- runDB $ E.select $ do + (ilog :& ihealth) <- E.from (E.table @InterfaceLog + `E.leftJoin` E.table @InterfaceHealth + `E.on` (\(ilog :& ihealth) -> + ilog E.^. InterfaceLogInterface E.=?. ihealth E.?. InterfaceHealthInterface + E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype) + E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite ) + )) + unless (null interfs) $ + E.where_ $ E.or [ ilog E.^. InterfaceLogInterface E.==. E.val ifce + E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.val subt + E.&&. ilog E.^. InterfaceLogWrite E.=~. E.val writ + | (UniqueInterfaceHealth ifce subt writ) <- interfs + ] + let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val 48) + return (ilog, ihour, E.joinV $ ihealth E.?. InterfaceHealthMessage) + siteLayoutMsg MsgMenuHealthInterface $ do + setTitleI MsgMenuHealthInterface + [whamlet| + TODO This page is not yet fully implemented + +
    + $forall i <- res +
  • + #{show i} + |] diff --git a/src/Handler/Health/Interfaces.hs b/src/Handler/Health/Interfaces.hs deleted file mode 100644 index 8c87ee7c7..000000000 --- a/src/Handler/Health/Interfaces.hs +++ /dev/null @@ -1,46 +0,0 @@ --- SPDX-FileCopyrightText: 2024 Steffen Jost --- --- SPDX-License-Identifier: AGPL-3.0-or-later - -module Handler.Health.Interfaces where - -import Import - -import Database.Esqueleto.Experimental ((:&)(..)) -import qualified Database.Esqueleto.Experimental as E -import qualified Database.Esqueleto.Utils as E - - -getHealthInterfacesR :: Handler Html -getHealthInterfacesR = auxHealthInterfaces [] - -getHealthInterfaceR :: [Text] -> Handler Html -getHealthInterfaceR ["*"] = auxHealthInterfaces [] -getHealthInterfaceR [i] = auxHealthInterfaces [(i, Nothing, Nothing)] -getHealthInterfaceR [i,s] = auxHealthInterfaces [(i, Just s, Nothing)] -getHealthInterfaceR [i,s, Text.toLower . Text.strip -> w] - | w `elem` ["1", "t", "true" ,"wahr", "w"] = auxHealthInterfaces [(i, Just s, Just True )] - | w `elem` ["0", "f", "false","falsch"] = auxHealthInterfaces [(i, Just s, Just False)] --- TODO: also allow '*' for wildcards and cycle; better write separate parse function -getHealthInterfaceR _ = notFound - - -auxHealthInterfaces :: [(Text, Maybe Text, Maybe Bool)] -> Handler Html -auxHealthInterfaces interfs = do - _TODO <- runDB $ E.select $ do - (ilog :& ihealth) <- E.from (E.table @InterfaceLog - `E.leftJoin` E.table @InterfaceHealth - `E.on` (\(ilog :& ihealth) -> - ilog E.^. InterfaceLogInterface E.=?. ihealth E.?. InterfaceHealthInterface - E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype) - E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite ) - )) - unless (null interfs) $ - E.where_ $ E.or [ ilog E.^. InterfaceInterface E.==. E.val ifce - E.&&. ilog E.^. InterfaceSubtype E.=~. E.val subt - E.&&. ilog E.^. InterfaceWrite E.=~. E.val writ - | (ifce, subt, writ) <- interfs - ] - let ihour = E.coalesceDefault [E.joinV (ihealth E.?. InterfaceHealthHours)] (E.val 48) - return (ilog, ihour, E.joinV $ ihealth E.?. InterfaceHealthMessage) - notFound \ No newline at end of file From 6d44f36e2ac2fce716a53e2b40b8b7f142e1062b Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 2 Feb 2024 13:06:39 +0100 Subject: [PATCH 07/22] chore(lpr): add manual print-ack csv upload --- .../utils/navigation/menu/de-de-formal.msg | 1 + .../uniworx/utils/navigation/menu/en-eu.msg | 1 + routes | 2 +- src/Foundation/Navigation.hs | 26 +++-- src/Handler/PrintCenter.hs | 107 ++++++++++-------- 5 files changed, 82 insertions(+), 55 deletions(-) diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index c94663cfc..eab4f204e 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -147,6 +147,7 @@ MenuApc: Druckerei MenuPrintSend: Manueller Briefversand MenuPrintDownload: Brief herunterladen MenuPrintLog: LPR Schnittstelle +MenuPrintAck: Druckbestätigung MenuApiDocs: API-Dokumentation (Englisch) MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger) diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index e09c56ef1..526c6d871 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -147,6 +147,7 @@ MenuApc: Printing MenuPrintSend: Send Letter MenuPrintDownload: Download Letter MenuPrintLog: LPR Interface +MenuPrintAck: Acknowledge Printing MenuApiDocs: API documentation MenuSwagger: OpenAPI 2.0 (Swagger) diff --git a/routes b/routes index 41f6d1f90..34ad73505 100644 --- a/routes +++ b/routes @@ -79,7 +79,7 @@ /print PrintCenterR GET POST !system-printer /print/acknowledge/#Day/#Int/#Int PrintAckR GET POST !system-printer -/print/acknowledge/direct PrintAckDirectR POST !system-printer +/print/acknowledge/direct PrintAckDirectR GET POST !system-printer /print/send PrintSendR GET POST /print/download/#CryptoUUIDPrintJob PrintDownloadR GET !system-printer /print/log PrintLogR GET !system-printer diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 72095a86d..008e68e08 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -127,13 +127,13 @@ breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing breadcrumb FirmsCommR{} = i18nCrumb MsgMenuFirmsComm $ Just FirmAllR breadcrumb FirmUsersR{} = i18nCrumb MsgMenuFirmUsers $ Just FirmAllR breadcrumb (FirmSupersR fsh)= i18nCrumb MsgMenuFirmSupervisors $ Just $ FirmUsersR fsh -breadcrumb (FirmCommR fsh)= i18nCrumb MsgMenuFirmsComm $ Just $ FirmUsersR fsh +breadcrumb (FirmCommR fsh)= i18nCrumb MsgMenuFirmsComm $ Just $ FirmUsersR fsh breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR breadcrumb PrintDownloadR{} = i18nCrumb MsgMenuPrintDownload $ Just PrintCenterR breadcrumb PrintAckR{} = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR -- never displayed -breadcrumb PrintAckDirectR{}= i18nCrumb MsgMenuPrintSend $ Just PrintCenterR -- never displayed +breadcrumb PrintAckDirectR{}= i18nCrumb MsgMenuPrintAck $ Just PrintCenterR breadcrumb PrintLogR = i18nCrumb MsgMenuPrintLog $ Just PrintCenterR breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR @@ -193,7 +193,7 @@ breadcrumb (LmsLearnersDirectR ssh qsh) = i18nCrumb MsgMenuLmsLearners $ Jus breadcrumb (LmsReportR ssh qsh) = i18nCrumb MsgMenuLmsReport $ Just $ LmsR ssh qsh breadcrumb (LmsReportUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsReportR ssh qsh breadcrumb (LmsReportDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsReportR ssh qsh -- never displayed --- +-- breadcrumb (LmsIdentR ssh qsh _ ) = breadcrumb $ LmsR ssh qsh -- just a redirect breadcrumb (LmsUserR ssh _qsh u ) = i18nCrumb MsgMenuLmsUser $ Just $ LmsUserSchoolR u ssh breadcrumb (LmsUserSchoolR u _ ) = i18nCrumb MsgMenuLmsUserSchool $ Just $ LmsUserAllR u @@ -294,7 +294,7 @@ breadcrumb (CourseR tid ssh csh (TutorialR tutn sRoute)) = case sRoute of TUsersR -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbTutorial . Just $ CourseR tid ssh csh CTutorialListR) $ do guardM . lift . hasReadAccessTo $ CTutorialR tid ssh csh tutn TUsersR return (CI.original tutn, Just $ CourseR tid ssh csh CTutorialListR) - TAddUserR -> i18nCrumb MsgMenuTutorialAddMembers . Just $ CTutorialR tid ssh csh tutn TUsersR + TAddUserR -> i18nCrumb MsgMenuTutorialAddMembers . Just $ CTutorialR tid ssh csh tutn TUsersR TEditR -> i18nCrumb MsgMenuTutorialEdit . Just $ CTutorialR tid ssh csh tutn TUsersR TDeleteR -> i18nCrumb MsgMenuTutorialDelete . Just $ CTutorialR tid ssh csh tutn TUsersR TCommR -> i18nCrumb MsgMenuTutorialComm . Just $ CTutorialR tid ssh csh tutn TUsersR @@ -2380,7 +2380,7 @@ pageActions (LmsR sid qsh) = return [ defNavLink MsgMenuLmsUpload $ LmsReportUploadR sid qsh , defNavLink MsgMenuLmsDirectUpload $ LmsReportDirectR sid qsh ] - } + } , NavPageActionSecondary { navLink = defNavLink MsgMenuLmsEdit $ LmsEditR sid qsh } @@ -2405,7 +2405,7 @@ pageActions (FirmUsersR fsh) = return [ NavPageActionPrimary { navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh , navChildren = [] - } + } ] pageActions (FirmSupersR fsh) = return [ NavPageActionPrimary @@ -2458,10 +2458,20 @@ pageActions PrintCenterR = do , navForceActive = False } } + printAck = NavPageActionSecondary + { navLink = NavLink + { navLabel = MsgMenuPrintAck + , navRoute = PrintAckDirectR + , navAccess' = NavAccessTrue + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + } dayLinks <- mapM toDayAck $ Map.toAscList dayMap - return $ manualSend : printLog : take 9 dayLinks + return $ manualSend : printLog : printAck : take 9 dayLinks -pageActions AdminCrontabR = return +pageActions AdminCrontabR = return [ NavPageActionPrimary { navLink = defNavLink MsgMenuAdminJobs AdminJobsR , navChildren = [] diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index bdc6e4572..084cc74d6 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -7,10 +7,10 @@ module Handler.PrintCenter ( getPrintDownloadR - , getPrintCenterR, postPrintCenterR + , getPrintCenterR, postPrintCenterR , getPrintSendR , postPrintSendR , getPrintAckR , postPrintAckR - , postPrintAckDirectR + , getPrintAckDirectR, postPrintAckDirectR , getPrintLogR ) where @@ -44,11 +44,11 @@ single :: (k,a) -> Map k a single = uncurry Map.singleton -data LRQF = LRQF - { lrqfLetter :: Text +data LRQF = LRQF + { lrqfLetter :: Text , lrqfUser :: Either UserEmail UserId , lrqfSuper :: Maybe (Either UserEmail UserId) - , lrqfQuali :: Entity Qualification + , lrqfQuali :: Entity Qualification , lrqfIdent :: LmsIdent , lrqfPin :: Text , lrqfExpiry :: Maybe Day @@ -63,12 +63,12 @@ makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateLetterRe <*> areq (userField False Nothing) (fslI MsgLmsUser) (lrqfUser <$> tmpl) <*> aopt (userField False Nothing) (fslI MsgTableSupervisor) (lrqfSuper <$> tmpl) <*> areq qualificationFieldEnt (fslI MsgQualificationName) (lrqfQuali <$> tmpl) - <*> areq lmsField (fslI MsgTableLmsIdent) (lrqfIdent <$> tmpl) + <*> areq lmsField (fslI MsgTableLmsIdent) (lrqfIdent <$> tmpl) <*> areq textField (fslI MsgTableLmsPin) (lrqfPin <$> tmpl) <*> aopt dayField (fslI MsgLmsQualificationValidUntil) (lrqfExpiry <$> tmpl) - <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) + <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgLmsRenewalReminder) (lrqfReminder <$> tmpl) - where + where lmsField = convertField LmsIdent getLmsIdent textField validateLetterRenewQualificationF :: FormValidator LRQF Handler () @@ -77,12 +77,12 @@ validateLetterRenewQualificationF = -- do return () lrqf2letter :: LRQF -> DB (Entity User, SomeLetter) -lrqf2letter LRQF{..} - | lrqfLetter == "r" = do +lrqf2letter LRQF{..} + | lrqfLetter == "r" = do usr <- getUser lrqfUser rcvr <- mapM getUser lrqfSuper now <- liftIO getCurrentTime - let letter = LetterRenewQualificationF + let letter = LetterRenewQualificationF { lmsLogin = lrqfIdent , lmsPin = lrqfPin , qualHolderID = usr ^. _entityKey @@ -97,13 +97,13 @@ lrqf2letter LRQF{..} , isReminder = lrqfReminder } return (fromMaybe usr rcvr, SomeLetter letter) - | lrqfLetter == "e" || lrqfLetter == "E" = do + | lrqfLetter == "e" || lrqfLetter == "E" = do rcvr <- mapM getUser lrqfSuper usr <- getUser lrqfUser usrShrt <- encrypt $ entityKey usr usrUuid <- encrypt $ entityKey usr urender <- liftHandler getUrlRender - let letter = LetterExpireQualification + let letter = LetterExpireQualification { leqHolderCFN = usrShrt , leqHolderID = usr ^. _entityKey , leqHolderDN = usr ^. _userDisplayName @@ -112,15 +112,15 @@ lrqf2letter LRQF{..} , leqId = lrqfQuali ^. _entityKey , leqName = lrqfQuali ^. _qualificationName . _CI , leqShort = lrqfQuali ^. _qualificationShorthand . _CI - , leqSchool = lrqfQuali ^. _qualificationSchool + , leqSchool = lrqfQuali ^. _qualificationSchool , leqUrl = pure . urender $ ForProfileDataR usrUuid } return (fromMaybe usr rcvr, SomeLetter letter) | otherwise = error "Unknown Letter Type encountered. Use 'e' or 'r' only." - where + where getUser :: Either UserEmail UserId -> DB (Entity User) getUser (Right uid) = getEntity404 uid - getUser (Left mail) = getBy404 $ UniqueEmail mail + getUser (Left mail) = getBy404 $ UniqueEmail mail data PJTableAction = PJActAcknowledge | PJActReprint @@ -191,7 +191,7 @@ pjTableQuery (printJob `E.LeftOuterJoin` recipient return (printJob, recipient, sender, course, quali) mkPJTable :: DB (FormResult (PJTableActionData, Set PrintJobId), Widget) -mkPJTable = do +mkPJTable = do let dbtSQLQuery = pjTableQuery dbtRowKey = queryPrintJob >>> (E.^. PrintJobId) @@ -226,7 +226,7 @@ mkPJTable = do dbtFilter = mconcat [ single ("name" , FilterColumn . E.mkContainsFilterWithCommaPlus id $ views (to queryPrintJob) (E.^. PrintJobName)) , single ("apcid" , FilterColumn . E.mkContainsFilterWithComma id $ views (to queryPrintJob) (E.^. PrintJobApcIdent)) - , single ("filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename)) + , single ("filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename)) , single ("created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) --, single ("created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) , single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryRecipient) (E.?. UserDisplayName)) @@ -234,7 +234,7 @@ mkPJTable = do , single ("course" , FilterColumn . E.mkContainsFilterWith (Just . CI.mk) $ views (to queryCourse) (E.?. CourseName)) , single ("qualification", FilterColumn . E.mkContainsFilterWith (Just . CI.mk) $ views (to queryQualification) (E.?. QualificationName)) , single ("lmsid" , FilterColumn . E.mkContainsFilterWithCommaPlus (Just . LmsIdent) $ views (to queryPrintJob) (E.^. PrintJobLmsUser)) - + , single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged))) ] dbtFilterUI mPrev = mconcat @@ -289,7 +289,7 @@ mkPJTable = do getPrintCenterR, postPrintCenterR :: Handler Html getPrintCenterR = postPrintCenterR -postPrintCenterR = do +postPrintCenterR = do (pjRes, pjTable) <- runDB mkPJTable formResult pjRes $ \case @@ -299,21 +299,21 @@ postPrintCenterR = do addMessageI Success $ MsgPrintJobAcknowledge num reloadKeepGetParams PrintCenterR (PJActReprintData{ignoreReroute}, Set.toList -> pjIds) -> do - let countOk = either (const $ Sum 0) (const $ Sum 1) + let countOk = either (const $ Sum 0) (const $ Sum 1) oks <- runDB $ forM pjIds $ fmap countOk . reprintPDF (fromMaybe False ignoreReroute) let nr_oks = getSum $ mconcat oks nr_tot = length pjIds mstat = bool Warning Success $ nr_oks == nr_tot addMessageI mstat $ MsgPrintJobReprint nr_oks nr_tot reloadKeepGetParams PrintCenterR - siteConf <- getYesod + siteConf <- getYesod let lprConf = siteConf ^. _appLprConf reroute = siteConf ^. _appMailRerouteTo lprWgt = [whamlet| LPR Konfiguration ist #{lprQueue lprConf}@#{lprHost lprConf}:#{lprPort lprConf}
    $maybe _ <- reroute - Mail-reroute-to ist gesetzt, somit werden alle lpr Kommandos unterdrückt! + Mail-reroute-to ist gesetzt, somit werden alle lpr Kommandos unterdrückt! |] siteLayoutMsg MsgMenuApc $ do setTitleI MsgMenuApc @@ -323,7 +323,7 @@ postPrintCenterR = do getPrintSendR, postPrintSendR :: Handler Html getPrintSendR = postPrintSendR postPrintSendR = do - usr <- requireAuth -- to determine language and recipient for test + usr <- requireAuth -- to determine language and recipient for test mbQual <- runDB $ selectFirst [] [Asc QualificationAvsLicence, Asc QualificationShorthand] now <- liftIO getCurrentTime let nowaday = utctDay now @@ -341,7 +341,7 @@ postPrintSendR = do def_lrqf = mkLetter <$> mbQual ((sendResult, sendWidget), sendEnctype) <- runFormPost $ makeRenewalForm def_lrqf - let procFormSend lrqf = case lrqfLetter lrqf of + let procFormSend lrqf = case lrqfLetter lrqf of "E" -> (runDB (lrqf2letter lrqf) >>= printHtml (Just uid)) >>= \case Right html -> sendResponse $ toTypedContent html Left err -> do @@ -349,7 +349,7 @@ postPrintSendR = do $logErrorS "LPR" msg addMessage Error $ toHtml msg pure () - _ -> do + _ -> do ok <- (runDB (lrqf2letter lrqf) >>= printLetter (Just uid)) >>= \case Left err -> do let msg = "PDF printing failed with error: " <> err @@ -400,26 +400,26 @@ postPrintAckR ackDay numAck chksm = do , formSubmit = FormNoSubmit } formResult ackRes $ \BtnConfirm -> do - numNew <- runDB $ do - pjs <- Ex.select $ do + numNew <- runDB $ do + pjs <- Ex.select $ do pj <- Ex.from $ Ex.table @PrintJob - let pjDay = E.day $ pj Ex.^. PrintJobCreated + let pjDay = E.day $ pj Ex.^. PrintJobCreated Ex.where_ $ Ex.isNothing (pj Ex.^. PrintJobAcknowledged) - Ex.&&. (pjDay Ex.==. Ex.val ackDay) + Ex.&&. (pjDay Ex.==. Ex.val ackDay) return $ pj Ex.^. PrintJobId let changed = numAck /= length pjs || chksm /= hash (Set.fromList (Ex.unValue <$> pjs)) if changed then return (-1) - else do + else do now <- liftIO getCurrentTime E.updateCount $ \pj -> do - let pjDay = E.day $ pj E.^. PrintJobCreated + let pjDay = E.day $ pj E.^. PrintJobCreated E.set pj [ PrintJobAcknowledged E.=. E.justVal now ] E.where_ $ E.isNothing (pj E.^. PrintJobAcknowledged) E.&&. (pjDay E.==. E.val ackDay) -- Ex.updateCount $ do -- pj <- Ex.from $ Ex.table @PrintJob - -- let pjDay = E.day $ pj Ex.^. PrintJobCreated + -- let pjDay = E.day $ pj Ex.^. PrintJobCreated -- Ex.set pj [ PrintJobAcknowledged Ex.=. Ex.just (Ex.val now) ] -- Ex.where_ $ Ex.isNothing (pj Ex.^. PrintJobAcknowledged) -- Ex.&&. (pjDay Ex.==. Ex.val ackDay) @@ -428,29 +428,44 @@ postPrintAckR ackDay numAck chksm = do else addMessageI Error MsgPrintJobAcknowledgeFailed redirect PrintCenterR ackDayText <- formatTime SelFormatDate ackDay - siteLayoutMsg - (MsgPrintJobAcknowledgeQuestion numAck ackDayText) + siteLayoutMsg + (MsgPrintJobAcknowledgeQuestion numAck ackDayText) ackForm -- no header csv, containing a single column of lms identifiers (logins) -- instance Csv.FromRecord LmsIdent -- default suffices --- instance Csv.FromRecord Text where --- parseRecord v +-- instance Csv.FromRecord Text where +-- parseRecord v -- | length v >= 1 = v Csv..! 0 -- | otherwise = pure "ERROR" saveApcident :: UTCTime -> Natural -> Text -> JobDB Natural saveApcident t i apci = insert_ (PrintAcknowledge apci t False) >> return (succ i) + +makeAckUploadForm :: Form FileInfo +makeAckUploadForm = renderAForm FormStandard $ fileAFormReq "Acknowledge APC-Ident CSV" + +getPrintAckDirectR :: Handler Html +getPrintAckDirectR = do + (widget, enctype) <- generateFormPost makeAckUploadForm + siteLayoutMsg MsgMenuPrintAck $ do + setTitleI MsgMenuPrintAck + [whamlet|$newline never +
    + ^{widget} + + |] + postPrintAckDirectR :: Handler Html postPrintAckDirectR = do now <- liftIO getCurrentTime (_params, files) <- runRequestBody (status, msg) <- case files of - [(_fhead,file)] -> do - runDBJobs $ do + [(_fhead,file)] -> do + runDBJobs $ do enr <- try $ runConduit $ fileSource file - -- .| decodeCsvPositional Csv.NoHeader -- decode by separator position + -- .| decodeCsvPositional Csv.NoHeader -- decode by separator position .| decodeUtf8C -- no CSV, just convert each line to a single text .| linesUnboundedC .| foldMC (saveApcident now) 0 @@ -462,7 +477,7 @@ postPrintAckDirectR = do let msg = "Success: received " <> tshow nr <> " APC identifiers to be processed later." $logInfoS "LMS" msg when (nr > 0) $ queueDBJob JobPrintAck - return (ok200, msg) + return (ok200, msg) [] -> do let msg = "Error: No file received. A file of lms identifiers must be supplied for print job acknowledging." $logWarnS "APC" msg @@ -476,7 +491,7 @@ postPrintAckDirectR = do getPrintLogR :: Handler Html getPrintLogR = do - let + let logDBTable = DBTable{..} where resultLog :: Lens' (DBRow (TransactionLog, Aeson.Result Transaction)) TransactionLog @@ -485,9 +500,9 @@ getPrintLogR = do resultTrans :: Lens' (DBRow (TransactionLog, Aeson.Result Transaction)) (Aeson.Result Transaction) resultTrans = _dbrOutput . _2 - tCell' err c dbr = case view resultTrans dbr of + tCell' err c dbr = case view resultTrans dbr of (Aeson.Error msg) -> err msg -- should not happen, due to query filter - (Aeson.Success t) -> c t + (Aeson.Success t) -> c t tCellErr = tCell' stringCell tCell = tCell' $ const mempty @@ -497,7 +512,7 @@ getPrintLogR = do -- E.&&. E.val "interface" E.==. l E.^. TransactionLogInfo E.->>. "transaction" -- not necessary return l dbtRowKey = (E.^. TransactionLogId) - dbtProj = dbtProjSimple $ \(Entity _ l) -> do + dbtProj = dbtProjSimple $ \(Entity _ l) -> do return (l, Aeson.fromJSON $ transactionLogInfo l) dbtColonnade = dbColonnade $ mconcat [ sortable (Just "time") (i18nCell MsgSystemMessageTimestamp) $ \(view $ resultLog . to transactionLogTime -> t) -> dateTimeCell t @@ -521,6 +536,6 @@ getPrintLogR = do dbtExtraReps = [] validator = def & defaultSorting [ SortDescBy "time" ] tbl <- runDB $ dbTableDB' validator logDBTable - siteLayoutMsg MsgMenuPrintLog $ do + siteLayoutMsg MsgMenuPrintLog $ do setTitleI MsgMenuPrintLog [whamlet|^{tbl}|] From bbb9f9fadb4136a92fa6727cb73ee02eb489f495 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 2 Feb 2024 17:16:19 +0100 Subject: [PATCH 08/22] chore(health): telling interface table compiles --- .../uniworx/categories/admin/de-de-formal.msg | 6 +- messages/uniworx/categories/admin/en-eu.msg | 6 +- src/Handler/Health/Interface.hs | 89 +++++++++++++++++-- src/Handler/LMS/Report.hs | 3 +- src/Handler/Utils/DateTime.hs | 4 +- 5 files changed, 95 insertions(+), 13 deletions(-) diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index f4c23696d..ad521c490 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -121,6 +121,10 @@ ProblemsAvsSynchHeading: Synchronisation AVS Fahrberechtigungen ProblemsAvsErrorHeading: Fehlermeldungen ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit +InterfaceStatus !ident-ok: Status +InterfaceName: Schnittstelle InterfaceLastSynch: Zuletzt InterfaceSubtype: Betreffend -InterfaceWrite: Schreibend \ No newline at end of file +InterfaceWrite: Schreibend +InterfaceSuccess: Rückmeldung +InterfaceInfo: Nachricht \ No newline at end of file diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index c035f54c0..c73fd8910 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -121,6 +121,10 @@ ProblemsAvsSynchHeading: Synchronisation AVS Driving Licences ProblemsAvsErrorHeading: Error Log ProblemsInterfaceSince: Only considering successes and errors since +InterfaceStatus: Status +InterfaceName: Interface InterfaceLastSynch: Last InterfaceSubtype: Affecting -InterfaceWrite: Write \ No newline at end of file +InterfaceWrite: Write +InterfaceSuccess: Returned +InterfaceInfo: Message \ No newline at end of file diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index 6592b6f56..e623901f1 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -2,6 +2,9 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} -- !!! TODO REMOVE ME + + module Handler.Health.Interface ( getHealthInterfaceR @@ -12,10 +15,12 @@ import Import -- import qualified Data.Set as Set import qualified Data.Text as Text +import Handler.Utils import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.Utils as E +import qualified Database.Esqueleto.Legacy as EL (on) identifyInterfaces :: [Text] -> [Unique InterfaceHealth] @@ -34,35 +39,105 @@ wc2null o = Just o -- | sloppily parse a boolean, also see Model.Types.Avs.SloppyBool pbool :: Text -> Maybe Bool pbool (Text.toLower . Text.strip -> w) - | w `elem` ["1", "t", "true" ,"wahr", "w"] = Just True + | w `elem` ["1", "t", "true" ,"wahr", "w"] = Just True | w `elem` ["0", "f", "false","falsch"] = Just False | otherwise = Nothing +mkInterfaceLogTable :: [Unique InterfaceHealth] -> (Bool -> Widget) -> DB ([(Text,Bool)], Widget) +mkInterfaceLogTable interfs flagError = do + now <- liftIO getCurrentTime + dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..} + where + dbtIdent = "interface-log" :: Text + dbtProj = dbtProjId + dbtSQLQuery (ilog `E.LeftOuterJoin` ihealth) = do + EL.on ( ilog E.^. InterfaceLogInterface E.=?. ihealth E.?. InterfaceHealthInterface + E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype) + E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite ) + ) + unless (null interfs) $ + E.where_ $ E.or [ ilog E.^. InterfaceLogInterface E.==. E.val ifce + E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.val subt + E.&&. ilog E.^. InterfaceLogWrite E.=~. E.val writ + | (UniqueInterfaceHealth ifce subt writ) <- interfs + ] + let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24) -- if no default time is set, use 3 days instead + return (ilog, ihour, E.joinV $ ihealth E.?. InterfaceHealthMessage) + + queryILog :: (E.SqlExpr (Entity InterfaceLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity InterfaceHealth))) -> E.SqlExpr (Entity InterfaceLog) + queryILog = $(E.sqlLOJproj 2 1) + resultILog :: Lens' (DBRow (Entity InterfaceLog, E.Value Int, E.Value (Maybe Text))) InterfaceLog + resultILog = _dbrOutput . _1 . _entityVal + resultHours :: Lens' (DBRow (Entity InterfaceLog, E.Value Int, E.Value (Maybe Text))) Int + resultHours = _dbrOutput . _2 . E._unValue + -- resultErrMsg :: Traversal' (DBRow (Entity InterfaceLog, E.Value Int, E.Value (Maybe Text))) Text + -- resultErrMsg = _dbrOutput . _3 . E._unValue . _Just + + dbtRowKey = queryILog >>> (E.^.InterfaceLogId) + colonnade now = mconcat + [ sortable Nothing (i18nCell MsgInterfaceStatus) $ \row -> -- do + let hours = row ^. resultHours + -- defmsg = row ^? resultErrMsg + logtime = row ^. resultILog . _interfaceLogTime + success = row ^. resultILog . _interfaceLogSuccess + iface = row ^. resultILog . _interfaceLogInterface + status = success && now <= addHours hours logtime + in tellCell [(iface,status)] $ + wgtCell $ flagError status + , sortable (Just "interface") (i18nCell MsgInterfaceName ) $ \(view (resultILog . _interfaceLogInterface) -> n) -> textCell n + , sortable (Just "subtype") (i18nCell MsgInterfaceSubtype ) $ textCell . view (resultILog . _interfaceLogSubtype) + , sortable (Just "write") (i18nCell MsgInterfaceWrite ) $ (`ifIconCell` IconEdit) . view (resultILog . _interfaceLogWrite) + , sortable (Just "time") (i18nCell MsgInterfaceLastSynch ) $ dateTimeCell . view (resultILog . _interfaceLogTime) + , sortable (Just "rows") (i18nCell MsgTableRows ) $ cellMaybe numCell . view (resultILog . _interfaceLogRows) + , sortable (Just "success") (i18nCell MsgInterfaceSuccess ) $ \(view (resultILog . _interfaceLogSuccess) -> s) -> iconBoolCell s + , sortable Nothing (i18nCell MsgInterfaceInfo ) $ \(view resultILog -> ilt) -> case ilt of + InterfaceLog "AVS" "Synch" True _ _ i _ -> anchorCell ProblemAvsErrorR $ toWgt $ bool i "AVS-Log" $ null i + InterfaceLog "LPR" _ _ _ _ i _ -> anchorCell PrintLogR $ toWgt $ bool i "LPR-Log" $ null i + InterfaceLog _ _ _ _ _ i _ -> textCell i + ] + dbtSorting = mconcat + [ singletonMap "interface" $ SortColumn $ queryILog >>> (E.^. InterfaceLogInterface) + , singletonMap "subtype" $ SortColumn $ queryILog >>> (E.^. InterfaceLogSubtype) + , singletonMap "write" $ SortColumn $ queryILog >>> (E.^. InterfaceLogWrite) + , singletonMap "time" $ SortColumn $ queryILog >>> (E.^. InterfaceLogTime) + , singletonMap "rows" $ SortColumn $ queryILog >>> (E.^. InterfaceLogRows) + , singletonMap "success" $ SortColumn $ queryILog >>> (E.^. InterfaceLogSuccess) + ] + ilvalidator = def & defaultSorting [SortAscBy "interface", SortAscBy "subtype", SortAscBy "write"] + dbtFilter = mempty + dbtFilterUI = mempty + dbtStyle = def + dbtParams = def + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + + getHealthInterfaceR :: [Text] -> Handler Html getHealthInterfaceR ris = do let interfs = identifyInterfaces ris res <- runDB $ E.select $ do - (ilog :& ihealth) <- E.from (E.table @InterfaceLog + (ilog :& ihealth) <- E.from (E.table @InterfaceLog `E.leftJoin` E.table @InterfaceHealth - `E.on` (\(ilog :& ihealth) -> + `E.on` (\(ilog :& ihealth) -> ilog E.^. InterfaceLogInterface E.=?. ihealth E.?. InterfaceHealthInterface E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype) E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite ) )) - unless (null interfs) $ + unless (null interfs) $ E.where_ $ E.or [ ilog E.^. InterfaceLogInterface E.==. E.val ifce E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.val subt E.&&. ilog E.^. InterfaceLogWrite E.=~. E.val writ | (UniqueInterfaceHealth ifce subt writ) <- interfs - ] - let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val 48) + ] + let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val 48) return (ilog, ihour, E.joinV $ ihealth E.?. InterfaceHealthMessage) siteLayoutMsg MsgMenuHealthInterface $ do setTitleI MsgMenuHealthInterface [whamlet| TODO This page is not yet fully implemented - +
      $forall i <- res
    • diff --git a/src/Handler/LMS/Report.hs b/src/Handler/LMS/Report.hs index a0a6fefb6..2e3ffb00b 100644 --- a/src/Handler/LMS/Report.hs +++ b/src/Handler/LMS/Report.hs @@ -294,8 +294,7 @@ postLmsReportUploadR sid qsh = do setTitleI MsgMenuLmsUpload [whamlet|$newline never - ^{widget} -

      + ^{widget} |] diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 49cc6a7ba..2b05f208f 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -93,8 +93,8 @@ toMorning = toTimeOfDay 6 0 0 toTimeOfDay :: Int -> Int -> Pico -> Day -> UTCTime toTimeOfDay todHour todMin todSec d = localTimeToUTCTZ appTZ $ LocalTime d TimeOfDay{..} -addHours :: Integer -> UTCTime -> UTCTime -addHours = addUTCTime . secondsToNominalDiffTime . fromInteger . (* 3600) +addHours :: Integral n => n -> UTCTime -> UTCTime +addHours = addUTCTime . secondsToNominalDiffTime . fromIntegral . (* 3600) instance HasLocalTime UTCTime where toLocalTime = utcToLocalTime From c71814d1ef1efc16c278136dfd6ebd86bd1d20db Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 2 Feb 2024 18:43:57 +0100 Subject: [PATCH 09/22] fix(health): fix #151 by offering route /health/interface/* --- .../uniworx/categories/admin/de-de-formal.msg | 5 +- messages/uniworx/categories/admin/en-eu.msg | 5 +- models/audit.model | 3 +- src/Handler/Admin.hs | 81 +----------- src/Handler/Health/Interface.hs | 118 ++++++++++++------ templates/admin-problems.hamlet | 7 +- 6 files changed, 100 insertions(+), 119 deletions(-) diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index ad521c490..6fb6a2836 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -121,10 +121,13 @@ ProblemsAvsSynchHeading: Synchronisation AVS Fahrberechtigungen ProblemsAvsErrorHeading: Fehlermeldungen ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit +InterfacesOk: Schnittstellen sind ok. +InterfacesFail n@Int: #{tshow n} Schnittstellenprobleme! InterfaceStatus !ident-ok: Status InterfaceName: Schnittstelle InterfaceLastSynch: Zuletzt InterfaceSubtype: Betreffend InterfaceWrite: Schreibend InterfaceSuccess: Rückmeldung -InterfaceInfo: Nachricht \ No newline at end of file +InterfaceInfo: Nachricht +InterfaceFreshness: Prüfungszeitraum (h) \ No newline at end of file diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index c73fd8910..74420ff19 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -121,10 +121,13 @@ ProblemsAvsSynchHeading: Synchronisation AVS Driving Licences ProblemsAvsErrorHeading: Error Log ProblemsInterfaceSince: Only considering successes and errors since +InterfacesOk: Interfaces are ok. +InterfacesFail n: #{tshow n} Interface problems! InterfaceStatus: Status InterfaceName: Interface InterfaceLastSynch: Last InterfaceSubtype: Affecting InterfaceWrite: Write InterfaceSuccess: Returned -InterfaceInfo: Message \ No newline at end of file +InterfaceInfo: Message +InterfaceFreshness: Check hours \ No newline at end of file diff --git a/models/audit.model b/models/audit.model index defb5c391..3cd567a13 100644 --- a/models/audit.model +++ b/models/audit.model @@ -26,7 +26,6 @@ InterfaceHealth interface Text subtype Text Maybe write Bool Maybe - hours Int - message Text Maybe + hours Int UniqueInterfaceHealth interface subtype write !force -- Note that nullable fields must be either empty or unique deriving Eq Read Show Generic diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 92dcac020..fd001c768 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -24,6 +24,7 @@ import qualified Database.Esqueleto.Utils as E import Handler.Utils import Handler.Utils.Avs import Handler.Utils.Users +import Handler.Health.Interface import Handler.Admin.Test as Handler.Admin import Handler.Admin.ErrorMessage as Handler.Admin @@ -54,13 +55,15 @@ getAdminProblemsR = do flagNonZero n | n <= 0 = flagError True | otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n)) - (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, interfaceTable) <- runDB $ (,,,,,) + (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, (interfaceOks, interfaceTable)) <- runDB $ (,,,,,) <$> areAllUsersReachable <*> allDriversHaveAvsId now <*> allRDriversHaveFs now <*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <. cutOffOldTime]) <*> (not <$> exists [PrintAcknowledgeProcessed ==. False]) - <*> fmap (view _2) (mkInterfaceLogTable flagError cutOffOldTime) + <*> mkInterfaceLogTable flagError mempty + let interfacesBadNr = length $ filter (not . snd) interfaceOks + -- interfacesOk = all snd interfaceOks diffLics <- try retrieveDifferingLicences >>= \case -- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received" (Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException) @@ -235,77 +238,3 @@ retrieveDriversRWithoutF now = do E.where_ $ E.exists (hasValidQual AvsLicenceRollfeld) E.&&. E.notExists (hasValidQual AvsLicenceVorfeld) return usr - - - - - -mkInterfaceLogTable :: (Bool -> Widget) -> UTCTime -> DB (Any, Widget) -mkInterfaceLogTable flagError cutOffOldTime = do - avsSynchStats <- E.select $ do - uavs <- E.from $ E.table @UserAvs - E.where_ $ uavs E.^. UserAvsLastSynch E.>. E.val cutOffOldTime - let isOk = E.isNothing (uavs E.^. UserAvsLastSynchError) - E.groupBy isOk - E.orderBy [E.descNullsLast isOk] - return (isOk, E.countRows, E.max_ $ uavs E.^. UserAvsLastSynch) - let - mkBadInfo badRows (fromMaybe cutOffOldTime -> badTime) | badRows > 0 = do - fmtCut <- formatTime SelFormatDate cutOffOldTime - fmtBad <- formatTime SelFormatDateTime badTime - return $ tshow badRows <> " Fehler seit " <> fmtCut <> ", zuletzt um " <> fmtBad - mkBadInfo _ _ = return mempty - writeAvsSynchStats okRows (fromMaybe cutOffOldTime -> okTime) badInfo = - void $ upsertBy (UniqueInterfaceSubtypeWrite "AVS" "Synch" True) - (InterfaceLog "AVS" "Synch" True okTime okRows badInfo (null badInfo)) - [InterfaceLogTime =. okTime, InterfaceLogRows =. okRows, InterfaceLogInfo =. badInfo, InterfaceLogSuccess =. null badInfo] - --case $(unValueN 3) <$> avsSynchStats of - case avsSynchStats of - ((E.Value True , E.Value okRows, E.Value okTime):(E.Value False, E.Value badRows, E.Value badTime):_) -> - writeAvsSynchStats (Just okRows) okTime =<< mkBadInfo badRows badTime - ((E.Value True , E.Value okRows, E.Value okTime):_) -> - writeAvsSynchStats (Just okRows) okTime mempty - ((E.Value False, E.Value badRows, E.Value badTime):_) -> do - lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch] - writeAvsSynchStats Nothing lastOk =<< mkBadInfo badRows badTime - _ -> return () - - let - flagOld = flagError . (cutOffOldTime <) - resultDBTable = DBTable{..} - where - resultILog :: Lens' (DBRow (Entity InterfaceLog)) InterfaceLog - resultILog = _dbrOutput . _entityVal - dbtSQLQuery = return - dbtRowKey = (E.^. InterfaceLogId) - dbtProj = dbtProjId - dbtColonnade = dbColonnade $ mconcat - [ sortable Nothing (textCell "Status" ) $ wgtCell . flagOld . view (resultILog . _interfaceLogTime) - , sortable (Just "interface") (textCell "Interface" ) $ \(view (resultILog . _interfaceLogInterface) -> n) -> textCell n - , sortable (Just "subtype") (i18nCell MsgInterfaceSubtype ) $ textCell . view (resultILog . _interfaceLogSubtype) - , sortable (Just "write") (i18nCell MsgInterfaceWrite ) $ (`ifIconCell` IconEdit) . view (resultILog . _interfaceLogWrite) - , sortable (Just "time") (i18nCell MsgInterfaceLastSynch ) $ dateTimeCell . view (resultILog . _interfaceLogTime) - , sortable (Just "rows") (i18nCell MsgTableRows ) $ cellMaybe numCell . view (resultILog . _interfaceLogRows) - , sortable Nothing (textCell "Info" ) $ \(view resultILog -> ilt) -> case ilt of - InterfaceLog "AVS" "Synch" True _ _ i _ -> anchorCell ProblemAvsErrorR $ toWgt $ bool i "AVS-Log" $ null i - InterfaceLog "LPR" _ _ _ _ i _ -> anchorCell PrintLogR $ toWgt $ bool i "LPR-Log" $ null i - InterfaceLog _ _ _ _ _ i _ -> textCell i - ] - dbtSorting = mconcat - [ singletonMap "interface" $ SortColumn (E.^. InterfaceLogInterface) - , singletonMap "subtype" $ SortColumn (E.^. InterfaceLogSubtype) - , singletonMap "write" $ SortColumn (E.^. InterfaceLogWrite) - , singletonMap "time" $ SortColumn (E.^. InterfaceLogTime) - , singletonMap "rows" $ SortColumn (E.^. InterfaceLogRows) - ] - dbtFilter = mempty - dbtFilterUI = mempty - dbtStyle = def - dbtIdent = "interface-log" :: Text - dbtParams = def - dbtCsvEncode = noCsvEncode - dbtCsvDecode = Nothing - dbtExtraReps = [] - resultDBTableValidator = def - & defaultSorting [SortAscBy "interface", SortAscBy "subtype", SortAscBy "write"] - dbTable resultDBTableValidator resultDBTable \ No newline at end of file diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index e623901f1..d1b8a0af0 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -8,6 +8,8 @@ module Handler.Health.Interface ( getHealthInterfaceR + , mkInterfaceLogTable + , runInterfaceChecks ) where @@ -17,7 +19,7 @@ import Import import qualified Data.Text as Text import Handler.Utils -import Database.Esqueleto.Experimental ((:&)(..)) +-- import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Legacy as EL (on) @@ -43,8 +45,39 @@ pbool (Text.toLower . Text.strip -> w) | w `elem` ["0", "f", "false","falsch"] = Just False | otherwise = Nothing -mkInterfaceLogTable :: [Unique InterfaceHealth] -> (Bool -> Widget) -> DB ([(Text,Bool)], Widget) -mkInterfaceLogTable interfs flagError = do + + +getHealthInterfaceR :: [Text] -> Handler Html +getHealthInterfaceR ris = do + let interfs = identifyInterfaces ris + (missing, allok, res, iltable) <- runInterfaceLogTable interfs + when missing notFound -- send 404 if an interface any interface was not found + unless allok $ sendResponseStatus internalServerError500 $ "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] + siteLayoutMsg MsgMenuHealthInterface $ do + setTitleI MsgMenuHealthInterface + [whamlet| + Interfaces healthy. + + ^{iltable} + |] + + +runInterfaceLogTable :: [Unique InterfaceHealth] -> Handler (Bool, Bool, [(Text,Bool)], Widget) +runInterfaceLogTable interfs = do + -- we abuse messageTooltip for colored icons here + msgSuccessTooltip <- messageI Success MsgMessageSuccess + -- msgWarningTooltip <- messageI Warning MsgMessageWarning + msgErrorTooltip <- messageI Error MsgMessageError + let flagError = messageTooltip . bool msgErrorTooltip msgSuccessTooltip + (res, twgt) <- runDB $ mkInterfaceLogTable flagError interfs + let missing = notNull [ifce | (UniqueInterfaceHealth ifce _subt _writ) <- interfs, ifce `notElem` (fst <$> res) ] + allok = all snd res + return (missing, allok, res, twgt) + + +mkInterfaceLogTable :: (Bool -> Widget) -> [Unique InterfaceHealth] -> DB ([(Text,Bool)], Widget) +mkInterfaceLogTable flagError interfs = do + runInterfaceChecks now <- liftIO getCurrentTime dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..} where @@ -62,16 +95,14 @@ mkInterfaceLogTable interfs flagError = do | (UniqueInterfaceHealth ifce subt writ) <- interfs ] let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24) -- if no default time is set, use 3 days instead - return (ilog, ihour, E.joinV $ ihealth E.?. InterfaceHealthMessage) + return (ilog, ihour) queryILog :: (E.SqlExpr (Entity InterfaceLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity InterfaceHealth))) -> E.SqlExpr (Entity InterfaceLog) queryILog = $(E.sqlLOJproj 2 1) - resultILog :: Lens' (DBRow (Entity InterfaceLog, E.Value Int, E.Value (Maybe Text))) InterfaceLog + resultILog :: Lens' (DBRow (Entity InterfaceLog, E.Value Int)) InterfaceLog resultILog = _dbrOutput . _1 . _entityVal - resultHours :: Lens' (DBRow (Entity InterfaceLog, E.Value Int, E.Value (Maybe Text))) Int + resultHours :: Lens' (DBRow (Entity InterfaceLog, E.Value Int)) Int resultHours = _dbrOutput . _2 . E._unValue - -- resultErrMsg :: Traversal' (DBRow (Entity InterfaceLog, E.Value Int, E.Value (Maybe Text))) Text - -- resultErrMsg = _dbrOutput . _3 . E._unValue . _Just dbtRowKey = queryILog >>> (E.^.InterfaceLogId) colonnade now = mconcat @@ -88,6 +119,7 @@ mkInterfaceLogTable interfs flagError = do , sortable (Just "subtype") (i18nCell MsgInterfaceSubtype ) $ textCell . view (resultILog . _interfaceLogSubtype) , sortable (Just "write") (i18nCell MsgInterfaceWrite ) $ (`ifIconCell` IconEdit) . view (resultILog . _interfaceLogWrite) , sortable (Just "time") (i18nCell MsgInterfaceLastSynch ) $ dateTimeCell . view (resultILog . _interfaceLogTime) + , sortable Nothing (i18nCell MsgInterfaceFreshness ) $ numCell . view resultHours , sortable (Just "rows") (i18nCell MsgTableRows ) $ cellMaybe numCell . view (resultILog . _interfaceLogRows) , sortable (Just "success") (i18nCell MsgInterfaceSuccess ) $ \(view (resultILog . _interfaceLogSuccess) -> s) -> iconBoolCell s , sortable Nothing (i18nCell MsgInterfaceInfo ) $ \(view resultILog -> ilt) -> case ilt of @@ -95,6 +127,7 @@ mkInterfaceLogTable interfs flagError = do InterfaceLog "LPR" _ _ _ _ i _ -> anchorCell PrintLogR $ toWgt $ bool i "LPR-Log" $ null i InterfaceLog _ _ _ _ _ i _ -> textCell i ] + dbtSorting = mconcat [ singletonMap "interface" $ SortColumn $ queryILog >>> (E.^. InterfaceLogInterface) , singletonMap "subtype" $ SortColumn $ queryILog >>> (E.^. InterfaceLogSubtype) @@ -113,33 +146,44 @@ mkInterfaceLogTable interfs flagError = do dbtExtraReps = [] +-- | runs additional checks and logs results within InterfaceLogTable; assumed to executable within a handler call +runInterfaceChecks :: DB () +runInterfaceChecks = do + avsInterfaceCheck + lprAckCheck + +lprAckCheck :: DB () +lprAckCheck = return () -- !!! TODO !!! Stub + -- ensure that all received apc-idents were ok -getHealthInterfaceR :: [Text] -> Handler Html -getHealthInterfaceR ris = do - let interfs = identifyInterfaces ris - res <- runDB $ E.select $ do - (ilog :& ihealth) <- E.from (E.table @InterfaceLog - `E.leftJoin` E.table @InterfaceHealth - `E.on` (\(ilog :& ihealth) -> - ilog E.^. InterfaceLogInterface E.=?. ihealth E.?. InterfaceHealthInterface - E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype) - E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite ) - )) - unless (null interfs) $ - E.where_ $ E.or [ ilog E.^. InterfaceLogInterface E.==. E.val ifce - E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.val subt - E.&&. ilog E.^. InterfaceLogWrite E.=~. E.val writ - | (UniqueInterfaceHealth ifce subt writ) <- interfs - ] - let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val 48) - return (ilog, ihour, E.joinV $ ihealth E.?. InterfaceHealthMessage) - siteLayoutMsg MsgMenuHealthInterface $ do - setTitleI MsgMenuHealthInterface - [whamlet| - TODO This page is not yet fully implemented - -

        - $forall i <- res -
      • - #{show i} - |] +avsInterfaceCheck :: DB () +avsInterfaceCheck = flip (maybeM $ return ()) (getBy $ UniqueInterfaceHealth "AVS" (Just "Synch") (Just True)) $ \Entity{entityVal=InterfaceHealth{interfaceHealthHours}} -> do + now <- liftIO getCurrentTime + let cutOffOldTime = addHours (-interfaceHealthHours) now + avsSynchStats <- E.select $ do + uavs <- E.from $ E.table @UserAvs + E.where_ $ uavs E.^. UserAvsLastSynch E.>. E.val cutOffOldTime + let isOk = E.isNothing (uavs E.^. UserAvsLastSynchError) + E.groupBy isOk + E.orderBy [E.descNullsLast isOk] + return (isOk, E.countRows, E.max_ $ uavs E.^. UserAvsLastSynch) + let + mkBadInfo badRows (fromMaybe cutOffOldTime -> badTime) | badRows > 0 = do + fmtCut <- formatTime SelFormatDate cutOffOldTime + fmtBad <- formatTime SelFormatDateTime badTime + return $ tshow badRows <> " Fehler seit " <> fmtCut <> ", zuletzt um " <> fmtBad + mkBadInfo _ _ = return mempty + writeAvsSynchStats okRows (fromMaybe cutOffOldTime -> okTime) badInfo = + void $ upsertBy (UniqueInterfaceSubtypeWrite "AVS" "Synch" True) + (InterfaceLog "AVS" "Synch" True okTime okRows badInfo (null badInfo)) + [InterfaceLogTime =. okTime, InterfaceLogRows =. okRows, InterfaceLogInfo =. badInfo, InterfaceLogSuccess =. null badInfo] + --case $(unValueN 3) <$> avsSynchStats of + case avsSynchStats of + ((E.Value True , E.Value okRows, E.Value okTime):(E.Value False, E.Value badRows, E.Value badTime):_) -> + writeAvsSynchStats (Just okRows) okTime =<< mkBadInfo badRows badTime + ((E.Value True , E.Value okRows, E.Value okTime):_) -> + writeAvsSynchStats (Just okRows) okTime mempty + ((E.Value False, E.Value badRows, E.Value badTime):_) -> do + lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch] + writeAvsSynchStats Nothing lastOk =<< mkBadInfo badRows badTime + _ -> return () diff --git a/templates/admin-problems.hamlet b/templates/admin-problems.hamlet index d07df69fd..b2a48143b 100644 --- a/templates/admin-problems.hamlet +++ b/templates/admin-problems.hamlet @@ -56,8 +56,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

        _{MsgMenuInterfaces}
        -

        - _{MsgProblemsInterfaceSince} ^{formatTimeW SelFormatDate cutOffOldTime} +

        + $if interfacesBadNr > 0 + _{MsgInterfacesFail interfacesBadNr} + $else + _{MsgInterfacesOk} ^{interfaceTable} From ce3852e3d365e62b32d181d58b7cbcc749e49373 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 5 Feb 2024 18:54:50 +0100 Subject: [PATCH 10/22] fix(health): fix #153 and offer interface health route matching --- .../uniworx/categories/admin/de-de-formal.msg | 2 +- messages/uniworx/categories/admin/en-eu.msg | 2 +- src/Audit.hs | 38 +++- src/Handler/Health/Interface.hs | 165 ++++++++++++------ src/Model/Migration/Definitions.hs | 8 + src/Utils.hs | 11 +- src/Utils/Lens.hs | 1 + src/Utils/Print.hs | 4 +- 8 files changed, 167 insertions(+), 64 deletions(-) diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index 6fb6a2836..eb6cfe753 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -122,7 +122,7 @@ ProblemsAvsErrorHeading: Fehlermeldungen ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit InterfacesOk: Schnittstellen sind ok. -InterfacesFail n@Int: #{tshow n} Schnittstellenprobleme! +InterfacesFail n@Int: #{pluralDEeN n "Schnittstellenproblem"}! InterfaceStatus !ident-ok: Status InterfaceName: Schnittstelle InterfaceLastSynch: Zuletzt diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index 74420ff19..13f35ed9f 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -122,7 +122,7 @@ ProblemsAvsErrorHeading: Error Log ProblemsInterfaceSince: Only considering successes and errors since InterfacesOk: Interfaces are ok. -InterfacesFail n: #{tshow n} Interface problems! +InterfacesFail n: #{pluralENsN n "interface problem"}! InterfaceStatus: Status InterfaceName: Interface InterfaceLastSynch: Last diff --git a/src/Audit.hs b/src/Audit.hs index f26af2d80..40c4a4206 100644 --- a/src/Audit.hs +++ b/src/Audit.hs @@ -8,7 +8,7 @@ module Audit , audit , AuditRemoteException(..) , getRemote - , logInterface + , logInterface, logInterface' ) where @@ -128,11 +128,39 @@ logInterface :: ( AuthId (HandlerSite m) ~ Key User -> Text -- ^ Any additional information -> ReaderT (YesodPersistBackend (HandlerSite m)) m () -- ^ Log a transaction using information available from `HandlerT`, also calls `audit` -logInterface (Text.strip -> interfaceLogInterface) (Text.strip -> interfaceLogSubtype) interfaceLogSuccess interfaceLogRows (Text.strip -> interfaceLogInfo) = do - interfaceLogTime <- liftIO getCurrentTime +logInterface interfaceLogInterface interfaceLogSubtype interfaceLogSuccess interfaceLogRows interfaceLogInfo = do interfaceLogWrite <- (methodGet /=) . Wai.requestMethod . reqWaiRequest <$> getRequest - deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- always replace, deleteBy & insert seems to be safest and fastest - insert_ InterfaceLog{..} + logInterface' interfaceLogInterface interfaceLogSubtype interfaceLogWrite interfaceLogSuccess interfaceLogRows interfaceLogInfo + +logInterface' :: ( AuthId (HandlerSite m) ~ Key User + , IsSqlBackend (YesodPersistBackend (HandlerSite m)) + , SqlBackendCanWrite (YesodPersistBackend (HandlerSite m)) + , HasInstanceID (HandlerSite m) InstanceId + , YesodAuthPersist (HandlerSite m) + , MonadHandler m + , MonadCatch m + , HasAppSettings (HandlerSite m) + , HasCallStack + ) + => Text -- ^ Interface that is used + -> Text -- ^ Subtype of the interface, if any + -> Bool -- ^ True indicates Write Access to FRADrive + -> Bool -- ^ Success=True, Failure=False + -> Maybe Int -- ^ Number of transmitted datasets + -> Text -- ^ Any additional information + -> ReaderT (YesodPersistBackend (HandlerSite m)) m () +-- ^ Log a transaction using information available from `HandlerT`, also calls `audit` +logInterface' (Text.strip -> interfaceLogInterface) (Text.strip -> interfaceLogSubtype) interfaceLogWrite interfaceLogSuccess interfaceLogRows (Text.strip -> interfaceLogInfo) = do + interfaceLogTime <- liftIO getCurrentTime + -- deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- always replace: deleteBy & insert seems to be safest and fastest + -- insert_ InterfaceLog{..} + void $ upsertBy (UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite) + ( InterfaceLog{..} ) + [ InterfaceLogTime =. interfaceLogTime + , InterfaceLogRows =. interfaceLogRows + , InterfaceLogInfo =. interfaceLogInfo + , InterfaceLogSuccess =. interfaceLogSuccess + ] audit TransactionInterface { transactionInterfaceName = interfaceLogInterface , transactionInterfaceSubtype = interfaceLogSubtype diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index d1b8a0af0..c43ffaed8 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -18,24 +18,21 @@ import Import -- import qualified Data.Set as Set import qualified Data.Text as Text import Handler.Utils +import Handler.Utils.Concurrent -- import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Legacy as EL (on) +import qualified Database.Persist.Sql as E (deleteWhereCount) -identifyInterfaces :: [Text] -> [Unique InterfaceHealth] -identifyInterfaces [] = [] -identifyInterfaces [i] = [UniqueInterfaceHealth i Nothing Nothing] -identifyInterfaces [i,s] = [UniqueInterfaceHealth i (wc2null s) Nothing] -identifyInterfaces (i:s:w:r) = UniqueInterfaceHealth i (wc2null s) (pbool w) : identifyInterfaces r - -- | identify a wildcard argument wc2null :: Text -> Maybe Text -wc2null "." = Nothing +-- wc2null "." = Nothing -- does not work, since dots are eliminated in URLs -- wc2null "-" = Nothing -- used as wildcard subtype in lpr interface wc2null "_" = Nothing +wc2null "*" = Nothing wc2null o = Just o -- | sloppily parse a boolean, also see Model.Types.Avs.SloppyBool @@ -45,55 +42,92 @@ pbool (Text.toLower . Text.strip -> w) | w `elem` ["0", "f", "false","falsch"] = Just False | otherwise = Nothing +-- | parse UniqueInterfaceHealth with subtype and write arguments being optional for the last interface. Wildcards '_' or '.' are also allowed in all places. +identifyInterfaces :: [Text] -> [Unique InterfaceHealth] +identifyInterfaces [] = [] +identifyInterfaces [i] = [UniqueInterfaceHealth i Nothing Nothing] +identifyInterfaces [i,s] = [UniqueInterfaceHealth i (wc2null s) Nothing] +identifyInterfaces (i:s:w:r) = UniqueInterfaceHealth i (wc2null s) (pbool w) : identifyInterfaces r + +type ReqBanInterfaceHealth = ([Unique InterfaceHealth],[Unique InterfaceHealth]) + +-- | Interface names prefixed with '-' are to be excluded from the query +splitInterfaces :: [Unique InterfaceHealth] -> ReqBanInterfaceHealth +splitInterfaces = foldl' aux mempty + where + aux (reqs,bans) uih@(UniqueInterfaceHealth i s w) + | Just ('-', b) <- Text.uncons i = (reqs, UniqueInterfaceHealth b s w : bans) + | otherwise = (uih : reqs, bans) + +-- | check whether the first argument is equal or more specialzed (i.e. more Just) than the second +matchesUniqueInterfaceHealth :: Unique InterfaceHealth -> Unique InterfaceHealth -> Bool +matchesUniqueInterfaceHealth (UniqueInterfaceHealth ai as aw) (UniqueInterfaceHealth bi bs bw) = ai == bi && eqOrNothing as bs && eqOrNothing aw bw + where + eqOrNothing _ Nothing = True + eqOrNothing a b = a == b getHealthInterfaceR :: [Text] -> Handler Html getHealthInterfaceR ris = do - let interfs = identifyInterfaces ris - (missing, allok, res, iltable) <- runInterfaceLogTable interfs - when missing notFound -- send 404 if an interface any interface was not found - unless allok $ sendResponseStatus internalServerError500 $ "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] - siteLayoutMsg MsgMenuHealthInterface $ do + let (forced, ris') = case ris of + ("force":ris0) -> (True , ris0) + _ -> (False, ris ) + interfs = splitInterfaces $ identifyInterfaces ris' + (missing, allok, res, iltable) <- runInterfaceLogTable interfs + let badMsg = "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] + when missing notFound -- send 404 if any requested interface was not found + unless (forced || allok) $ sendResponseStatus internalServerError500 badMsg + content <- siteLayoutMsg MsgMenuHealthInterface $ do setTitleI MsgMenuHealthInterface [whamlet| - Interfaces healthy. + $if allok + Interfaces are healthy. + $else + #{badMsg} ^{iltable} |] + sendResponseStatus (bool internalServerError500 status200 allok) content -runInterfaceLogTable :: [Unique InterfaceHealth] -> Handler (Bool, Bool, [(Text,Bool)], Widget) -runInterfaceLogTable interfs = do +runInterfaceLogTable :: ReqBanInterfaceHealth -> Handler (Bool, Bool, [(Text,Bool)], Widget) +runInterfaceLogTable interfs@(reqIfs,_) = do -- we abuse messageTooltip for colored icons here msgSuccessTooltip <- messageI Success MsgMessageSuccess -- msgWarningTooltip <- messageI Warning MsgMessageWarning msgErrorTooltip <- messageI Error MsgMessageError let flagError = messageTooltip . bool msgErrorTooltip msgSuccessTooltip (res, twgt) <- runDB $ mkInterfaceLogTable flagError interfs - let missing = notNull [ifce | (UniqueInterfaceHealth ifce _subt _writ) <- interfs, ifce `notElem` (fst <$> res) ] + let missing = notNull [ifce | (UniqueInterfaceHealth ifce _subt _writ) <- reqIfs, ifce `notElem` (fst <$> res) ] allok = all snd res return (missing, allok, res, twgt) +-- ihDebugShow :: Unique InterfaceHealth -> Text +-- ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> tshow s <> tshow w <> ")" -mkInterfaceLogTable :: (Bool -> Widget) -> [Unique InterfaceHealth] -> DB ([(Text,Bool)], Widget) -mkInterfaceLogTable flagError interfs = do - runInterfaceChecks +mkInterfaceLogTable :: (Bool -> Widget) -> ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget) +mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do + -- $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs]) + void $ liftHandler $ timeoutHandler 42000001 $ runDB $ runInterfaceChecks interfs now <- liftIO getCurrentTime dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..} where + sanitize = text2AlphaNumPlus ['+','-','_','Ä','Ö','Ü','ß','ä','ö','ü'] dbtIdent = "interface-log" :: Text dbtProj = dbtProjId dbtSQLQuery (ilog `E.LeftOuterJoin` ihealth) = do EL.on ( ilog E.^. InterfaceLogInterface E.=?. ihealth E.?. InterfaceHealthInterface - E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype) - E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite ) + E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype) + E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite ) ) - unless (null interfs) $ - E.where_ $ E.or [ ilog E.^. InterfaceLogInterface E.==. E.val ifce - E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.val subt - E.&&. ilog E.^. InterfaceLogWrite E.=~. E.val writ - | (UniqueInterfaceHealth ifce subt writ) <- interfs - ] + let matchUIH crits = E.or + [ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) + E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.val (sanitize <$> subt) + E.&&. ilog E.^. InterfaceLogWrite E.=~. E.val writ + | (UniqueInterfaceHealth ifce subt writ) <- crits + ] + unless (null reqIfs) $ E.where_ $ matchUIH reqIfs + unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24) -- if no default time is set, use 3 days instead return (ilog, ihour) @@ -147,19 +181,46 @@ mkInterfaceLogTable flagError interfs = do -- | runs additional checks and logs results within InterfaceLogTable; assumed to executable within a handler call -runInterfaceChecks :: DB () -runInterfaceChecks = do - avsInterfaceCheck - lprAckCheck - -lprAckCheck :: DB () -lprAckCheck = return () -- !!! TODO !!! Stub - -- ensure that all received apc-idents were ok +runInterfaceChecks :: ReqBanInterfaceHealth -> DB () +runInterfaceChecks interfs = do + avsInterfaceCheck interfs + lprAckCheck interfs -avsInterfaceCheck :: DB () -avsInterfaceCheck = flip (maybeM $ return ()) (getBy $ UniqueInterfaceHealth "AVS" (Just "Synch") (Just True)) $ \Entity{entityVal=InterfaceHealth{interfaceHealthHours}} -> do - now <- liftIO getCurrentTime - let cutOffOldTime = addHours (-interfaceHealthHours) now +maybeRunCheck :: ReqBanInterfaceHealth -> Unique InterfaceHealth -> (UTCTime -> DB ()) -> DB () +maybeRunCheck (reqIfs,banIfs) uih act + | null reqIfs || any (matchesUniqueInterfaceHealth uih) reqIfs + , null banIfs || not (any (matchesUniqueInterfaceHealth uih) banIfs) = do + mih <- getBy uih + whenIsJust mih $ \eih -> do + now <- liftIO getCurrentTime + act $ addHours (negate $ interfaceHealthHours $ entityVal eih) now + | otherwise = return () + +-- maybeRunCheck :: Unique InterfaceHealth -> (Int -> DB ()) -> DB () +-- maybeRunCheck uih act = maybeM (return ()) (act . interfaceHealthHours . entityVal) $ getBy uih + -- maybeRunCheck uih act = getBy uih >>= flip whenIsJust (act . interfaceHealthHours . entityVal) + -- where + -- ih2hours :: Entity InterfaceHealth -> Int + -- -- ih2hours Entity{entityVal=InterfaceHealth{interfaceHealthHours=h}} = h + -- ih2hours = interfaceHealthHours . entityVal + + +lprAckCheck :: ReqBanInterfaceHealth -> DB () +lprAckCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "Printer" (Just "Acknowledge") (Just True)) $ \cutOffOldTime -> do + unproc <- selectList [PrintAcknowledgeTimestamp <. cutOffOldTime, PrintAcknowledgeProcessed ==. False] [] + if notNull unproc + then mkLog False (Just $ length unproc) "Long unprocessed APC-Idents exist" + else do + oks <- E.deleteWhereCount [PrintAcknowledgeTimestamp <. cutOffOldTime, PrintAcknowledgeProcessed ==. True] + if oks > 0 + then mkLog True (Just $ fromIntegral oks) "Long processed APC-Idents removed" + else mkLog True Nothing mempty + where + mkLog = logInterface' "Printer" "Acknowledge" True + + +avsInterfaceCheck :: ReqBanInterfaceHealth -> DB () +avsInterfaceCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "AVS" (Just "Synch") (Just True)) $ \cutOffOldTime -> do avsSynchStats <- E.select $ do uavs <- E.from $ E.table @UserAvs E.where_ $ uavs E.^. UserAvsLastSynch E.>. E.val cutOffOldTime @@ -167,23 +228,21 @@ avsInterfaceCheck = flip (maybeM $ return ()) (getBy $ UniqueInterfaceHealth "AV E.groupBy isOk E.orderBy [E.descNullsLast isOk] return (isOk, E.countRows, E.max_ $ uavs E.^. UserAvsLastSynch) - let + let mkBadInfo badRows (fromMaybe cutOffOldTime -> badTime) | badRows > 0 = do fmtCut <- formatTime SelFormatDate cutOffOldTime fmtBad <- formatTime SelFormatDateTime badTime return $ tshow badRows <> " Fehler seit " <> fmtCut <> ", zuletzt um " <> fmtBad mkBadInfo _ _ = return mempty - writeAvsSynchStats okRows (fromMaybe cutOffOldTime -> okTime) badInfo = - void $ upsertBy (UniqueInterfaceSubtypeWrite "AVS" "Synch" True) - (InterfaceLog "AVS" "Synch" True okTime okRows badInfo (null badInfo)) - [InterfaceLogTime =. okTime, InterfaceLogRows =. okRows, InterfaceLogInfo =. badInfo, InterfaceLogSuccess =. null badInfo] - --case $(unValueN 3) <$> avsSynchStats of - case avsSynchStats of - ((E.Value True , E.Value okRows, E.Value okTime):(E.Value False, E.Value badRows, E.Value badTime):_) -> - writeAvsSynchStats (Just okRows) okTime =<< mkBadInfo badRows badTime - ((E.Value True , E.Value okRows, E.Value okTime):_) -> - writeAvsSynchStats (Just okRows) okTime mempty - ((E.Value False, E.Value badRows, E.Value badTime):_) -> do - lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch] - writeAvsSynchStats Nothing lastOk =<< mkBadInfo badRows badTime + writeAvsSynchStats okRows badInfo = + logInterface' "AVS" "Synch" True (null badInfo) okRows badInfo + --case $(unValueN 3) <$> avsSynchStats of + case avsSynchStats of + ((E.Value True , E.Value okRows, E.Value _okTime):(E.Value False, E.Value badRows, E.Value badTime):_) -> + writeAvsSynchStats (Just okRows) =<< mkBadInfo badRows badTime + ((E.Value True , E.Value okRows, E.Value _okTime):_) -> + writeAvsSynchStats (Just okRows) mempty + ((E.Value False, E.Value badRows, E.Value badTime):_) -> + -- lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch] + writeAvsSynchStats Nothing =<< mkBadInfo badRows badTime _ -> return () diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index 8e458ac47..a875b9648 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -123,6 +123,14 @@ migrateAlwaysSafe = do let itemDay = Map.findWithDefault today item changelogItemDays return [st|('#{toPathPiece item}', '#{iso8601Show itemDay}')|] in sql + -- unless (tableExists "interface_health") $ do + -- [executeQQ| + -- INSERT INTO "interface_health" (interface, subtype, write, hours) + -- VALUES + -- ('Printer', 'Acknowledge', True, 168) + -- , ('AVS' , 'Synch' , True , 96) + -- ON CONFLICT DO NOTHING; + -- |] {- Confusion about quotes, from the PostgreSQL Manual: diff --git a/src/Utils.hs b/src/Utils.hs index 2093da8b2..c47f29992 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -23,7 +23,7 @@ import qualified Data.CaseInsensitive as CI import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as CBS -import qualified Data.Char as Char +-- import qualified Data.Char as Char import qualified Data.Text as Text import qualified Data.Text.Encoding as Text @@ -319,9 +319,16 @@ citext2string = Text.unpack . CI.original string2citext :: String -> CI Text string2citext = CI.mk . Text.pack +text2AlphaNumPlus :: [Char] -> Text -> Text +text2AlphaNumPlus = + let alphaNum = Set.fromAscList $ ['0'..'9'] <> ['A'..'Z'] <> ['a'..'z'] + in \oks -> + let aNumPlus = Set.fromList oks <> alphaNum + in Text.filter (`Set.member` aNumPlus) + -- | Convert or remove all non-ascii characters, e.g. for filenames text2asciiAlphaNum :: Text -> Text -text2asciiAlphaNum = Text.filter (\c -> Char.isAlphaNum c && Char.isAscii c) +text2asciiAlphaNum = text2AlphaNumPlus ['-','_'] . Text.replace "ä" "ae" . Text.replace "Ä" "Ae" . Text.replace "Æ" "ae" diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 5e5f993c6..adcba7262 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -310,6 +310,7 @@ makeLenses_ ''AuthorshipStatementDefinition makeLenses_ ''PrintJob makeLenses_ ''InterfaceLog +-- makeLenses_ ''InterfaceLog -- not needed -------------------------- -- Fields for `UniWorX` -- diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index 8687158b8..d4dc3f882 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -270,7 +270,7 @@ printLetter' pji pdf = do printJobFile = LBS.toStrict pdf printJobAcknowledged = Nothing qshort <- ifMaybeM printJobQualification "-" $ fmap (maybe "_" $ CI.original . qualificationShorthand ) . get - let logInter = flip (logInterface "LPR" qshort) (Just 1) + let logInter = flip (logInterface "Printer" qshort) (Just 1) lprPDF printJobFilename pdf >>= \case Left err -> do logInter False err @@ -288,7 +288,7 @@ reprintPDF ignoreReroute pjid = maybeM (return $ Left "Print job id is unknown." reprint :: PrintJob -> DB (Either Text Text) reprint pj@PrintJob{..} = do qshort <- ifMaybeM printJobQualification "-" $ fmap (maybe "_" $ CI.original . qualificationShorthand ) . get - let logInter = flip (logInterface "LPR" qshort) (Just 1) + let logInter = flip (logInterface "Printer" qshort) (Just 1) result <- lprPDF' ignoreReroute printJobFilename $ LBS.fromStrict printJobFile case result of Left err -> From 1464a9a5822250f49d06391428bbd6b171cba461 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 6 Feb 2024 00:14:53 +0000 Subject: [PATCH 11/22] chore(release): 27.4.57 --- CHANGELOG.md | 9 +++++++++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 13 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index d99bd198d..a09ca5698 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,15 @@ 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.57](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.56...v27.4.57) (2024-02-06) + + +### Bug Fixes + +* **course:** fix [#147](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/147) abort addd participant aborts now ([d332c0c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d332c0c11afd8b1dfe1343659f0b1626c968bbde)) +* **health:** fix [#151](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/151) by offering route /health/interface/* ([c71814d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c71814d1ef1efc16c278136dfd6ebd86bd1d20db)) +* **health:** fix [#153](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/153) and offer interface health route matching ([ce3852e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ce3852e3d365e62b32d181d58b7cbcc749e49373)) + ## [27.4.56](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.55...v27.4.56) (2023-12-20) diff --git a/nix/docker/version.json b/nix/docker/version.json index be8c9e7d6..2bc1d589a 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.56" + "version": "27.4.57" } diff --git a/package-lock.json b/package-lock.json index fb4545bc0..769a5b181 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.56", + "version": "27.4.57", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 25437a405..d92518019 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.56", + "version": "27.4.57", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 2ead3ea00..f22cd7d97 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.56 +version: 27.4.57 dependencies: - base - yesod From 42f1a802b52007ccca9595d732fc20f40cc66f6a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 6 Feb 2024 10:32:00 +0000 Subject: [PATCH 12/22] chore(health): getHealthInterfaceR responds to mime content type header --- src/Handler/Health/Interface.hs | 39 ++++++++++++++++++--------------- 1 file changed, 21 insertions(+), 18 deletions(-) diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index c43ffaed8..1b6ee1dee 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -67,27 +67,30 @@ matchesUniqueInterfaceHealth (UniqueInterfaceHealth ai as aw) (UniqueInterfaceHe eqOrNothing a b = a == b -getHealthInterfaceR :: [Text] -> Handler Html -getHealthInterfaceR ris = do - let (forced, ris') = case ris of - ("force":ris0) -> (True , ris0) - _ -> (False, ris ) - interfs = splitInterfaces $ identifyInterfaces ris' +getHealthInterfaceR :: [Text] -> Handler TypedContent +getHealthInterfaceR (dropWhile (=="force") -> ris) = do -- for backwards compatibility we ignore leading "force" + let interfs = splitInterfaces $ identifyInterfaces ris (missing, allok, res, iltable) <- runInterfaceLogTable interfs - let badMsg = "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] when missing notFound -- send 404 if any requested interface was not found - unless (forced || allok) $ sendResponseStatus internalServerError500 badMsg - content <- siteLayoutMsg MsgMenuHealthInterface $ do - setTitleI MsgMenuHealthInterface - [whamlet| - $if allok - Interfaces are healthy. - $else - #{badMsg} + let respond = sendResponseStatus (bool internalServerError500 status200 allok) + plainMsg = if allok + then "Interfaces are healthy" + else "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] + selectRep $ do + provideRep $ do + content <- siteLayoutMsg MsgMenuHealthInterface $ do + setTitleI MsgMenuHealthInterface + [whamlet| +

        + #{plainMsg} +
        + ^{iltable} + |] + respond content + + provideRep $ do + respond $ RepPlain $ toContent plainMsg - ^{iltable} - |] - sendResponseStatus (bool internalServerError500 status200 allok) content runInterfaceLogTable :: ReqBanInterfaceHealth -> Handler (Bool, Bool, [(Text,Bool)], Widget) From 4a843fe30e35f346ffbe5c0337d69bf319cfeced Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 6 Feb 2024 10:48:54 +0000 Subject: [PATCH 13/22] refactor(health): simplfy code following HealthR handler --- src/Handler/Health/Interface.hs | 23 ++++++++++------------- 1 file changed, 10 insertions(+), 13 deletions(-) diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index 1b6ee1dee..87be63b89 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -68,28 +68,25 @@ matchesUniqueInterfaceHealth (UniqueInterfaceHealth ai as aw) (UniqueInterfaceHe getHealthInterfaceR :: [Text] -> Handler TypedContent -getHealthInterfaceR (dropWhile (=="force") -> ris) = do -- for backwards compatibility we ignore leading "force" +getHealthInterfaceR (dropWhile (=="force") -> ris) = do -- for backwards compatibility we ignore leading "force" let interfs = splitInterfaces $ identifyInterfaces ris (missing, allok, res, iltable) <- runInterfaceLogTable interfs - when missing notFound -- send 404 if any requested interface was not found - let respond = sendResponseStatus (bool internalServerError500 status200 allok) - plainMsg = if allok - then "Interfaces are healthy" - else "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] - selectRep $ do - provideRep $ do - content <- siteLayoutMsg MsgMenuHealthInterface $ do + when missing notFound -- send 404 if any requested interface was not found + let ihstatus = if allok then status200 + else internalServerError500 + plainMsg = if allok then "Interfaces are healthy." + else "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] + sendResponseStatus ihstatus <=< selectRep $ do + provideRep . siteLayoutMsg MsgMenuHealthInterface $ do setTitleI MsgMenuHealthInterface [whamlet|
        #{plainMsg}
        ^{iltable} - |] - respond content + |] - provideRep $ do - respond $ RepPlain $ toContent plainMsg + provideRep $ return $ RepPlain $ toContent plainMsg From 2a0bca1230b456eb413842b37f03342b25e49742 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 6 Feb 2024 15:37:00 +0000 Subject: [PATCH 14/22] refactor(health): interface-health - send text/plain by default - attempt to fix negative sub-filters for interface health --- src/Handler/Health/Interface.hs | 20 ++++++++++++-------- src/Model/Migration/Definitions.hs | 4 ++-- 2 files changed, 14 insertions(+), 10 deletions(-) diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index 87be63b89..4e551eb96 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -76,18 +76,16 @@ getHealthInterfaceR (dropWhile (=="force") -> ris) = do -- for bac else internalServerError500 plainMsg = if allok then "Interfaces are healthy." else "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] - sendResponseStatus ihstatus <=< selectRep $ do - provideRep . siteLayoutMsg MsgMenuHealthInterface $ do + sendResponseStatus ihstatus <=< selectRep $ do -- most browsers send accept:text/html, thus text/plain can be default here + provideRep . return . RepPlain $ toContent plainMsg -- /?_accept=text/plain + provideRep . siteLayoutMsg MsgMenuHealthInterface $ do -- /?_accept=text/html setTitleI MsgMenuHealthInterface [whamlet|
        #{plainMsg}
        ^{iltable} - |] - - provideRep $ return $ RepPlain $ toContent plainMsg - + |] runInterfaceLogTable :: ReqBanInterfaceHealth -> Handler (Bool, Bool, [(Text,Bool)], Widget) @@ -105,6 +103,12 @@ runInterfaceLogTable interfs@(reqIfs,_) = do -- ihDebugShow :: Unique InterfaceHealth -> Text -- ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> tshow s <> tshow w <> ")" +-- | like (=~.) but avoids condition entirely if second argument is Nothing; Note that using =~. with E.val Nothing did not work somehow! +infixl 4 ~~. +(~~.) :: PersistField typ => E.SqlExpr (E.Value typ) -> Maybe typ -> E.SqlExpr (E.Value Bool) +(~~.) a Nothing = E.true +(~~.) a (Just b) = a E.==. E.val b + mkInterfaceLogTable :: (Bool -> Widget) -> ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget) mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do -- $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs]) @@ -122,8 +126,8 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do ) let matchUIH crits = E.or [ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) - E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.val (sanitize <$> subt) - E.&&. ilog E.^. InterfaceLogWrite E.=~. E.val writ + E.&&. ilog E.^. InterfaceLogSubtype ~~. (sanitize <$> subt) + E.&&. ilog E.^. InterfaceLogWrite ~~. writ | (UniqueInterfaceHealth ifce subt writ) <- crits ] unless (null reqIfs) $ E.where_ $ matchUIH reqIfs diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index a875b9648..e7d34e713 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -125,7 +125,7 @@ migrateAlwaysSafe = do in sql -- unless (tableExists "interface_health") $ do -- [executeQQ| - -- INSERT INTO "interface_health" (interface, subtype, write, hours) + -- INSERT INTO "interface_health" ("interface", "subtype", "write", "hours") -- VALUES -- ('Printer', 'Acknowledge', True, 168) -- , ('AVS' , 'Synch' , True , 96) From 67552a666e2588c1f477eacd5036c09903b2d40e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 6 Feb 2024 15:47:17 +0000 Subject: [PATCH 15/22] refactor(health): optimize sql query, needs tests --- src/Handler/Health/Interface.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index 4e551eb96..e1a523dea 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -130,6 +130,14 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do E.&&. ilog E.^. InterfaceLogWrite ~~. writ | (UniqueInterfaceHealth ifce subt writ) <- crits ] + -- let matchUIH crits = E.or + -- [ E.and $ catMaybes + -- [ Just $ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) + -- , foldMap ((ilog E.^. InterfaceLogSubtype E.==.) . E.val . sanitize) subt + -- , foldMap ((ilog E.^. InterfaceLogWrite E.==.) . E.val ) writ + -- ] + -- | (UniqueInterfaceHealth ifce subt writ) <- crits + -- ] unless (null reqIfs) $ E.where_ $ matchUIH reqIfs unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24) -- if no default time is set, use 3 days instead From 618c78a69d7db77a745282c63356a936facff70d Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 7 Feb 2024 10:23:51 +0100 Subject: [PATCH 16/22] chore(health): examining cause of #155 --- src/Handler/Health/Interface.hs | 39 ++++++++++++++++++--------------- 1 file changed, 21 insertions(+), 18 deletions(-) diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index e1a523dea..42ec567fd 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -100,18 +100,19 @@ runInterfaceLogTable interfs@(reqIfs,_) = do allok = all snd res return (missing, allok, res, twgt) --- ihDebugShow :: Unique InterfaceHealth -> Text --- ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> tshow s <> tshow w <> ")" +ihDebugShow :: Unique InterfaceHealth -> Text +ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> "," <> tshow s <> "," <> tshow w <> ")" +-- NOTE: Using (~~.) instead of ()=~.) -- | like (=~.) but avoids condition entirely if second argument is Nothing; Note that using =~. with E.val Nothing did not work somehow! -infixl 4 ~~. -(~~.) :: PersistField typ => E.SqlExpr (E.Value typ) -> Maybe typ -> E.SqlExpr (E.Value Bool) -(~~.) a Nothing = E.true -(~~.) a (Just b) = a E.==. E.val b +-- infixl 4 ~~. +-- (~~.) :: PersistField typ => E.SqlExpr (E.Value typ) -> Maybe typ -> E.SqlExpr (E.Value Bool) +-- (~~.) _ Nothing = E.true +-- (~~.) a (Just b) = a E.==. E.val b mkInterfaceLogTable :: (Bool -> Widget) -> ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget) mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do - -- $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs]) + $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs]) void $ liftHandler $ timeoutHandler 42000001 $ runDB $ runInterfaceChecks interfs now <- liftIO getCurrentTime dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..} @@ -124,22 +125,24 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype) E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite ) ) - let matchUIH crits = E.or - [ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) - E.&&. ilog E.^. InterfaceLogSubtype ~~. (sanitize <$> subt) - E.&&. ilog E.^. InterfaceLogWrite ~~. writ - | (UniqueInterfaceHealth ifce subt writ) <- crits - ] + -- let matchUIH crits = E.or + -- [ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) + -- E.&&. ilog E.^. InterfaceLogSubtype ~~. (sanitize <$> subt) + -- E.&&. ilog E.^. InterfaceLogWrite ~~. writ + -- | (UniqueInterfaceHealth ifce subt writ) <- crits + -- ] -- let matchUIH crits = E.or -- [ E.and $ catMaybes - -- [ Just $ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) - -- , foldMap ((ilog E.^. InterfaceLogSubtype E.==.) . E.val . sanitize) subt - -- , foldMap ((ilog E.^. InterfaceLogWrite E.==.) . E.val ) writ + -- [ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) & Just + -- , (ilog E.^. InterfaceLogSubtype E.==.) . E.val . sanitize <$> subt + -- , (ilog E.^. InterfaceLogWrite E.==.) . E.val <$> writ -- ] -- | (UniqueInterfaceHealth ifce subt writ) <- crits -- ] - unless (null reqIfs) $ E.where_ $ matchUIH reqIfs - unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs + -- unless (null reqIfs) $ E.where_ $ matchUIH reqIfs + -- unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs + E.where_ $ E.not_ (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- NOT OKAY ONLY Printer F SEE ISSUE #155 + -- E.where_ $ ilog E.^. InterfaceLogInterface E.!=. E.val "LMS" E.||. ilog E.^. InterfaceLogSubtype E.!=. E.val (sanitize "F") -- OKAY let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24) -- if no default time is set, use 3 days instead return (ilog, ihour) From 3303c4eebf928e527d2f9c1eb6e2495c10b94b13 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 7 Feb 2024 10:39:21 +0100 Subject: [PATCH 17/22] fix(health): negative interface routes working as intended now --- src/Handler/Health/Interface.hs | 76 ++++++++++++++------------------- 1 file changed, 31 insertions(+), 45 deletions(-) diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index 42ec567fd..f64ef254f 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -2,8 +2,6 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later -{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} -- !!! TODO REMOVE ME - module Handler.Health.Interface ( @@ -62,7 +60,7 @@ splitInterfaces = foldl' aux mempty -- | check whether the first argument is equal or more specialzed (i.e. more Just) than the second matchesUniqueInterfaceHealth :: Unique InterfaceHealth -> Unique InterfaceHealth -> Bool matchesUniqueInterfaceHealth (UniqueInterfaceHealth ai as aw) (UniqueInterfaceHealth bi bs bw) = ai == bi && eqOrNothing as bs && eqOrNothing aw bw - where + where eqOrNothing _ Nothing = True eqOrNothing a b = a == b @@ -72,9 +70,9 @@ getHealthInterfaceR (dropWhile (=="force") -> ris) = do -- for bac let interfs = splitInterfaces $ identifyInterfaces ris (missing, allok, res, iltable) <- runInterfaceLogTable interfs when missing notFound -- send 404 if any requested interface was not found - let ihstatus = if allok then status200 + let ihstatus = if allok then status200 else internalServerError500 - plainMsg = if allok then "Interfaces are healthy." + plainMsg = if allok then "Interfaces are healthy." else "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] sendResponseStatus ihstatus <=< selectRep $ do -- most browsers send accept:text/html, thus text/plain can be default here provideRep . return . RepPlain $ toContent plainMsg -- /?_accept=text/plain @@ -100,19 +98,12 @@ runInterfaceLogTable interfs@(reqIfs,_) = do allok = all snd res return (missing, allok, res, twgt) -ihDebugShow :: Unique InterfaceHealth -> Text -ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> "," <> tshow s <> "," <> tshow w <> ")" - --- NOTE: Using (~~.) instead of ()=~.) --- | like (=~.) but avoids condition entirely if second argument is Nothing; Note that using =~. with E.val Nothing did not work somehow! --- infixl 4 ~~. --- (~~.) :: PersistField typ => E.SqlExpr (E.Value typ) -> Maybe typ -> E.SqlExpr (E.Value Bool) --- (~~.) _ Nothing = E.true --- (~~.) a (Just b) = a E.==. E.val b +-- ihDebugShow :: Unique InterfaceHealth -> Text +-- ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> "," <> tshow s <> "," <> tshow w <> ")" mkInterfaceLogTable :: (Bool -> Widget) -> ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget) mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do - $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs]) + -- $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs]) void $ liftHandler $ timeoutHandler 42000001 $ runDB $ runInterfaceChecks interfs now <- liftIO getCurrentTime dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..} @@ -122,27 +113,30 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do dbtProj = dbtProjId dbtSQLQuery (ilog `E.LeftOuterJoin` ihealth) = do EL.on ( ilog E.^. InterfaceLogInterface E.=?. ihealth E.?. InterfaceHealthInterface - E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype) - E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite ) + E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype) + E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite ) ) - -- let matchUIH crits = E.or - -- [ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) - -- E.&&. ilog E.^. InterfaceLogSubtype ~~. (sanitize <$> subt) - -- E.&&. ilog E.^. InterfaceLogWrite ~~. writ - -- | (UniqueInterfaceHealth ifce subt writ) <- crits - -- ] - -- let matchUIH crits = E.or - -- [ E.and $ catMaybes - -- [ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) & Just - -- , (ilog E.^. InterfaceLogSubtype E.==.) . E.val . sanitize <$> subt - -- , (ilog E.^. InterfaceLogWrite E.==.) . E.val <$> writ - -- ] - -- | (UniqueInterfaceHealth ifce subt writ) <- crits - -- ] - -- unless (null reqIfs) $ E.where_ $ matchUIH reqIfs - -- unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs - E.where_ $ E.not_ (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- NOT OKAY ONLY Printer F SEE ISSUE #155 - -- E.where_ $ ilog E.^. InterfaceLogInterface E.!=. E.val "LMS" E.||. ilog E.^. InterfaceLogSubtype E.!=. E.val (sanitize "F") -- OKAY + let matchUIH crits = E.or + [ E.and $ catMaybes + [ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) & Just + , (ilog E.^. InterfaceLogSubtype E.==.) . E.val . sanitize <$> subt + , (ilog E.^. InterfaceLogWrite E.==.) . E.val <$> writ + ] + | (UniqueInterfaceHealth ifce subt writ) <- crits + ] + matchUIHnot crits = E.and + [ E.or $ catMaybes + [ ilog E.^. InterfaceLogInterface E.!=. E.val (sanitize ifce) & Just + , (ilog E.^. InterfaceLogSubtype E.!=.) . E.val . sanitize <$> subt + , (ilog E.^. InterfaceLogWrite E.!=.) . E.val <$> writ + ] + | (UniqueInterfaceHealth ifce subt writ) <- crits + ] + unless (null reqIfs) $ E.where_ $ matchUIH reqIfs + unless (null banIfs) $ E.where_ $ matchUIHnot banIfs + -- unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs -- !!! DOES NOT WORK !!! Yields strange results, see #155 + -- E.where_ $ E.not_ (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- BAD All missing, except for "Printer" "F" + -- E.where_ $ ilog E.^. InterfaceLogInterface E.!=. E.val "LMS" E.||. ilog E.^. InterfaceLogSubtype E.!=. E.val (sanitize "F") -- OKAY let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24) -- if no default time is set, use 3 days instead return (ilog, ihour) @@ -211,14 +205,6 @@ maybeRunCheck (reqIfs,banIfs) uih act act $ addHours (negate $ interfaceHealthHours $ entityVal eih) now | otherwise = return () --- maybeRunCheck :: Unique InterfaceHealth -> (Int -> DB ()) -> DB () --- maybeRunCheck uih act = maybeM (return ()) (act . interfaceHealthHours . entityVal) $ getBy uih - -- maybeRunCheck uih act = getBy uih >>= flip whenIsJust (act . interfaceHealthHours . entityVal) - -- where - -- ih2hours :: Entity InterfaceHealth -> Int - -- -- ih2hours Entity{entityVal=InterfaceHealth{interfaceHealthHours=h}} = h - -- ih2hours = interfaceHealthHours . entityVal - lprAckCheck :: ReqBanInterfaceHealth -> DB () lprAckCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "Printer" (Just "Acknowledge") (Just True)) $ \cutOffOldTime -> do @@ -227,10 +213,10 @@ lprAckCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "Printer" (Ju then mkLog False (Just $ length unproc) "Long unprocessed APC-Idents exist" else do oks <- E.deleteWhereCount [PrintAcknowledgeTimestamp <. cutOffOldTime, PrintAcknowledgeProcessed ==. True] - if oks > 0 + if oks > 0 then mkLog True (Just $ fromIntegral oks) "Long processed APC-Idents removed" else mkLog True Nothing mempty - where + where mkLog = logInterface' "Printer" "Acknowledge" True From 263894b05899ce55635d790f5334729fbc655ecc Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 7 Feb 2024 12:43:39 +0100 Subject: [PATCH 18/22] fix(lms): previouly failed notifications will be sent again --- src/Jobs/Handler/LMS.hs | 5 +++-- src/Jobs/Types.hs | 4 +++- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 12ab943f2..013f849b7 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -313,7 +313,8 @@ dispatchJobLmsReports qid = JobHandlerAtomic act E.&&. lreport E.^. LmsReportLock E.==. E.true ) -- B) notify all newly reported users that lms is available - let luserFltrNew luser = E.isNothing $ luser E.^. LmsUserReceived -- not seen before, just starting + let luserFltrNew luser = E.isNothing (luser E.^. LmsUserReceived) -- not seen before, just starting + E.||. E.isNothing (luser E.^. LmsUserNotified) -- a previous notification has failed notifyNewLearner (E.Value uid) = queueDBJob JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False } } in luserQry luserFltrNew (const $ const E.true) >>= mapM_ notifyNewLearner -- C) block qualifications for failed learners by calling qualificationUserBlocking [uids] (includes audit), notified during expiry diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index dc8e04120..69ad6b4d6 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -375,6 +375,8 @@ jobNoQueueSame = \case notifyNoQueueSame :: Notification -> Maybe JobNoQueueSame notifyNoQueueSame = \case NotificationQualificationRenewal{} -> Just JobNoQueueSame -- send one at once; safe, since the job is rescheduled if sending was not acknowledged + NotificationQualificationExpiry{} -> Just JobNoQueueSame -- do not send multiple expiry messages to the same person at once + NotificationQualificationExpired{} -> Just JobNoQueueSame _ -> Nothing jobMovable :: JobCtl -> Bool From 57f5cac75af6a0d96f3216fcfbd0446d98f44345 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Thu, 8 Feb 2024 20:51:43 +0100 Subject: [PATCH 19/22] chore(release): 27.4.58 --- 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 a09ca5698..1ff23608e 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.58](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.57...v27.4.58) (2024-02-08) + + +### Bug Fixes + +* **health:** negative interface routes working as intended now ([3303c4e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3303c4eebf928e527d2f9c1eb6e2495c10b94b13)) +* **lms:** previouly failed notifications will be sent again ([263894b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/263894b05899ce55635d790f5334729fbc655ecc)) + ## [27.4.57](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.56...v27.4.57) (2024-02-06) diff --git a/nix/docker/version.json b/nix/docker/version.json index 2bc1d589a..0f6ee116f 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.57" + "version": "27.4.58" } diff --git a/package-lock.json b/package-lock.json index 769a5b181..16f8bd6f6 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.57", + "version": "27.4.58", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index d92518019..2eac33199 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.57", + "version": "27.4.58", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index f22cd7d97..9e9579f42 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.57 +version: 27.4.58 dependencies: - base - yesod From e2be8bbd5c82fd8a68187ee6bea4ab49e2980797 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 12 Feb 2024 11:30:54 +0100 Subject: [PATCH 20/22] chore(sql): examine #155 --- src/Database/Esqueleto/Utils.hs | 3 ++- src/Handler/Health/Interface.hs | 4 +++- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 8a0a02a17..c0b80448e 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -17,6 +17,7 @@ module Database.Esqueleto.Utils , (>~.), (<~.) , or, and , any, all + -- , parens , subSelectAnd, subSelectOr , mkExactFilter, mkExactFilterWith, mkExactFilterWithComma , mkExactFilterLast, mkExactFilterLastWith diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index f64ef254f..c530b43c5 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -135,8 +135,10 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do unless (null reqIfs) $ E.where_ $ matchUIH reqIfs unless (null banIfs) $ E.where_ $ matchUIHnot banIfs -- unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs -- !!! DOES NOT WORK !!! Yields strange results, see #155 + -- unless (null banIfs) $ E.where_ $ E.not_ $ E.parens $ matchUIH banIfs -- WORKS OKAY -- E.where_ $ E.not_ (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- BAD All missing, except for "Printer" "F" - -- E.where_ $ ilog E.^. InterfaceLogInterface E.!=. E.val "LMS" E.||. ilog E.^. InterfaceLogSubtype E.!=. E.val (sanitize "F") -- OKAY + -- E.where_ $ E.not_ $ E.parens (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- WORKS OKAY + -- E.where_ $ ilog E.^. InterfaceLogInterface E.!=. E.val "LMS" E.||. ilog E.^. InterfaceLogSubtype E.!=. E.val (sanitize "F") -- WORKS OKAY let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24) -- if no default time is set, use 3 days instead return (ilog, ihour) From 42695cf5ef9f21691dc027f1ec97d57eec72f03e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 12 Feb 2024 11:56:31 +0100 Subject: [PATCH 21/22] fix(sql): remove potential bug in relation to missing parenthesis after not_ --- src/Database/Esqueleto/Utils.hs | 5 ++++- src/Handler/Utils/Users.hs | 2 +- src/Jobs/Handler/LMS.hs | 4 ++-- 3 files changed, 7 insertions(+), 4 deletions(-) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index c0b80448e..127e0ed88 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -17,7 +17,7 @@ module Database.Esqueleto.Utils , (>~.), (<~.) , or, and , any, all - -- , parens + , not__, parens , subSelectAnd, subSelectOr , mkExactFilter, mkExactFilterWith, mkExactFilterWithComma , mkExactFilterLast, mkExactFilterLastWith @@ -253,6 +253,9 @@ subSelectOr q = parens . E.subSelectUnsafe $ flip (E.unsafeSqlAggregateFunction parens :: E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) parens = E.unsafeSqlFunction "" +-- | Workaround for Esqueleto-Bug not placing parenthesis after NOT, see #155 +not__ :: E.SqlExpr (E.Value Bool) -> E.SqlExpr (E.Value Bool) +not__ = E.not_ . parens -- Allow usage of Tuples as DbtRowKey, i.e. SqlIn instances for tuples $(sqlInTuples [2..16]) diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 5c85c9c73..e281c7fcf 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -189,7 +189,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria) containsAsSet x y = E.and . map (\y' -> x `E.hasInfix` E.val y') $ asWords y - toSql user pl = bool id E.not_ (is _PLNegated pl) $ case pl ^. _plVar of + toSql user pl = bool id E.not__ (is _PLNegated pl) $ case pl ^. _plVar of GuessUserMatrikelnummer userMatriculation' -> user E.^. UserMatrikelnummer E.==. E.val (Just userMatriculation') GuessUserEduPersonPrincipalName userEPPN' -> user E.^. UserLdapPrimaryKey E.==. E.val (Just userEPPN') GuessUserDisplayName userDisplayName' -> user E.^. UserDisplayName `containsAsSet` userDisplayName' diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 013f849b7..136ea518e 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -202,7 +202,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act -- E.&&. luser E.?. LmsUserQualification E.?=. E.val qid -- E.&&. E.isNothing (luser E.^. LmsUserStatus) -- E.&&. E.isNothing (luser E.^. LmsUserEnded) - E.&&. E.not_ (validQualification now quser) + E.&&. E.not__ (validQualification now quser) 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 ] @@ -223,7 +223,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act `E.on` (\(quser :& qblock) -> qblock E.?. QualificationUserBlockQualificationUser E.?=. quser E.^. QualificationUserId E.&&. qblock `isLatestBlockBefore` E.val now ) - E.where_ $ -- E.not_ (validQualification now quser) -- currently invalid + E.where_ $ -- E.not__ (validQualification now quser) -- currently invalid quser E.^. QualificationUserQualification E.==. E.val qid -- correct qualification E.&&. quserToNotify now quser qblock -- recently became invalid or blocked pure (quser E.^. QualificationUserUser) From 192c7337491fca7092499331efe3f88e8cf682c4 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 12 Feb 2024 18:30:07 +0100 Subject: [PATCH 22/22] chore(health): migration for health defaults --- src/Model/Migration/Definitions.hs | 28 ++++++++++++++++++++-------- 1 file changed, 20 insertions(+), 8 deletions(-) diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index e7d34e713..ab0147ff4 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -49,6 +49,7 @@ import qualified Data.Time.Zones as TZ data ManualMigration = Migration20230524QualificationUserBlock | Migration20230703LmsUserStatus + | Migration20240212InitInterfaceHealth -- create table interface_health and fill with default values deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) deriving anyclass (Universe, Finite) @@ -123,14 +124,6 @@ migrateAlwaysSafe = do let itemDay = Map.findWithDefault today item changelogItemDays return [st|('#{toPathPiece item}', '#{iso8601Show itemDay}')|] in sql - -- unless (tableExists "interface_health") $ do - -- [executeQQ| - -- INSERT INTO "interface_health" ("interface", "subtype", "write", "hours") - -- VALUES - -- ('Printer', 'Acknowledge', True, 168) - -- , ('AVS' , 'Synch' , True , 96) - -- ON CONFLICT DO NOTHING; - -- |] {- Confusion about quotes, from the PostgreSQL Manual: @@ -185,6 +178,25 @@ customMigrations = mapF $ \case ; |] + Migration20240212InitInterfaceHealth -> + unlessM (tableExists "interface_health") $ do -- fill health table with some defaults + [executeQQ| + CREATE TABLE "interface_health" + ( id BIGSERIAL NOT NULL + , interface CHARACTER VARYING NOT NULL + , subtype CHARACTER VARYING + , write BOOLEAN + , hours BIGINT NOT NULL + , PRIMARY KEY(id) + , CONSTRAINT unique_interface_health UNIQUE(interface, subtype, write) + ); + INSERT INTO "interface_health" ("interface", "subtype", "write", "hours") + VALUES + ('Printer', 'Acknowledge', True, 168) + , ('AVS' , 'Synch' , True , 96) + ON CONFLICT DO NOTHING; + |] + tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool tableExists table = do