From c334fa4bf32140aaf9c4b9129ba37018e4fad79f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 6 Dec 2023 18:03:35 +0100 Subject: [PATCH] chore(log): add interface usage table --- models/audit.model | 14 +++++++++++++- routes | 2 +- src/Audit.hs | 38 +++++++++++++++++++++++++++++++++++++- src/Audit/Types.hs | 10 ++++++++-- src/Handler/SAP.hs | 2 ++ 5 files changed, 61 insertions(+), 5 deletions(-) diff --git a/models/audit.model b/models/audit.model index cf821f6ec..061f63bfe 100644 --- a/models/audit.model +++ b/models/audit.model @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen +-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -9,4 +9,16 @@ TransactionLog initiator UserId Maybe -- User associated with performing this action remote IP Maybe -- Remote party that triggered this action via HTTP info Value -- JSON-encoded `Transaction` + deriving Eq Read Show Generic + +InterfaceLog + time UTCTime + instance InstanceId + initiator UserId Maybe -- User associated with performing this interface access + remote IP Maybe -- Remote party that triggered this action via HTTP + interface Text + subtype Text + info Text + write Bool -- True implies a write to FRADrive + UniqueInterfaceSubtypeWrite interface subtype write deriving Eq Read Show Generic \ No newline at end of file diff --git a/routes b/routes index 34891b367..3f30c960a 100644 --- a/routes +++ b/routes @@ -283,7 +283,7 @@ /lms/#SchoolId/#QualificationShorthand/learners LmsLearnersR GET /lms/#SchoolId/#QualificationShorthand/learners/direct LmsLearnersDirectR GET !token -- LMS /lms/#SchoolId/#QualificationShorthand/report LmsReportR GET POST -/lms/#SchoolId/#QualificationShorthand/report/upload LmsReportUploadR GET POST !development +/lms/#SchoolId/#QualificationShorthand/report/upload LmsReportUploadR GET POST /lms/#SchoolId/#QualificationShorthand/report/direct LmsReportDirectR POST !token -- LMS -- other lms routes /lms/#SchoolId/#QualificationShorthand/ident/#LmsIdent LmsIdentR GET -- redirect to LmsR with filter-parameter diff --git a/src/Audit.hs b/src/Audit.hs index b6b8012a0..a01491b35 100644 --- a/src/Audit.hs +++ b/src/Audit.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen +-- SPDX-FileCopyrightText: 2023 Gregor Kleen ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -8,6 +8,7 @@ module Audit , audit , AuditRemoteException(..) , getRemote + , logInterface ) where @@ -112,3 +113,38 @@ audit transaction@(toJSON -> transactionLogInfo) = do insert_ TransactionLog{..} $logInfoS "Audit" $ Text.filter (/= '\n') $ tshow (transaction, transactionLogInitiator, transactionLogRemote) <> " - " <> pack (prettyCallStack callStack) + + +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 + -> Text -- ^ Any additional information + -> ReaderT (YesodPersistBackend (HandlerSite m)) m () +-- ^ Log a transaction using information available from `HandlerT`: +-- +-- - `transactionLogTime` is now +-- - `transactionLogInitiator` is currently logged in user (or none) +-- - `transactionLogRemote` is determined from current HTTP-Request +logInterface interfaceLogInterface interfaceLogSubtype interfaceLogInfo = do + interfaceLogTime <- liftIO getCurrentTime + interfaceLogInstance <- getsYesod $ view instanceID + interfaceLogInitiator <- liftHandler maybeAuthId + interfaceLogRemote <- handle (throwM . AuditRemoteException) $ Just <$> getRemote + interfaceLogWrite <- (methodGet /=) . Wai.requestMethod . reqWaiRequest <$> getRequest + putMany [InterfaceLog{..}] + audit TransactionInterface + { transactionInterfaceName = interfaceLogInterface + , transactionInterfaceSubtype = interfaceLogSubtype + , transactionInterfaceInfo = interfaceLogInfo + , transactionInterfaceWrite = interfaceLogWrite + } + \ No newline at end of file diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index ed3927a03..dcea62e09 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,,Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -234,6 +234,12 @@ data Transaction , transactionQualification :: QualificationId , transactionQualificationScheduleRenewal :: Maybe Bool -- TRUE=will be notified upon expiry, FALSE=won't be notified; always JUST, for compatibility with TransactionQualificationUserEdit } + | TransactionInterface + { transactionInterfaceName :: Text + , transactionInterfaceSubtype :: Text + , transactionInterfaceInfo :: Text + , transactionInterfaceWrite :: Bool -- True implies a write to FRADrive + } deriving (Eq, Ord, Read, Show, Generic) deriveJSON defaultOptions @@ -243,4 +249,4 @@ deriveJSON defaultOptions , sumEncoding = TaggedObject "transaction" "data" } ''Transaction -derivePersistFieldJSON ''Transaction +derivePersistFieldJSON ''Transaction \ No newline at end of file diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index be4ad973a..8c4be014a 100644 --- a/src/Handler/SAP.hs +++ b/src/Handler/SAP.hs @@ -139,8 +139,10 @@ getQualificationSAPDirectR = do nr = length qualUsers msg = "Qualification download file " <> csvSheetName <> " containing " <> tshow nr <> " rows" $logInfoS "SAP" msg + runDB $ logInterface "SAP" "" $ tshow $ length csvRendered addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\"" csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered + -- direct Download see: -- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod