From fb20defc4254139e48c8d6f1061b3f23e56f5a58 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 7 Dec 2023 16:59:10 +0100 Subject: [PATCH] refactor(log): simplify interface logging Since each interface log also triggers an AuditLog entry, the additional data about user and instance do not need to be saved twice --- models/audit.model | 12 ++++----- src/Audit.hs | 54 +++++++++++-------------------------- src/Audit/Types.hs | 3 ++- src/Handler/LMS/Learners.hs | 2 +- src/Handler/LMS/Report.hs | 5 ++-- src/Handler/SAP.hs | 4 ++- 6 files changed, 29 insertions(+), 51 deletions(-) diff --git a/models/audit.model b/models/audit.model index 061f63bfe..fd0889392 100644 --- a/models/audit.model +++ b/models/audit.model @@ -11,14 +11,12 @@ TransactionLog 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 +InterfaceLog interface Text subtype Text - info Text - write Bool -- 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 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 03038df1b..e13c769b9 100644 --- a/src/Audit.hs +++ b/src/Audit.hs @@ -108,17 +108,7 @@ audit transaction@(toJSON -> transactionLogInfo) = do transactionLogInstance <- getsYesod $ view instanceID transactionLogInitiator <- liftHandler maybeAuthId transactionLogRemote <- handle (throwM . AuditRemoteException) $ Just <$> getRemote - auditHelper transaction TransactionLog{..} - -auditHelper :: ( - IsSqlBackend (YesodPersistBackend (HandlerSite m)) - , SqlBackendCanWrite (YesodPersistBackend (HandlerSite m)) - , MonadHandler m - , HasCallStack - ) - => Transaction -> TransactionLog -> ReaderT (YesodPersistBackend (HandlerSite m)) m () -auditHelper transaction tl@TransactionLog{..} = do - insert_ tl + insert_ TransactionLog{..} $logInfoS "Audit" $ Text.filter (/= '\n') $ tshow (transaction, transactionLogInitiator, transactionLogRemote) <> " - " <> pack (prettyCallStack callStack) logInterface :: ( AuthId (HandlerSite m) ~ Key User @@ -131,33 +121,21 @@ logInterface :: ( AuthId (HandlerSite m) ~ Key User , HasAppSettings (HandlerSite m) , HasCallStack ) - => Text -- ^ Interface that is used - -> Text -- ^ Subtype of the interface, if any - -> Text -- ^ Any additional information + => Text -- ^ Interface that is used + -> Text -- ^ Subtype of the interface, if any + -> Maybe Int -- ^ Number of transmitted datasets + -> 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 +-- ^ Log a transaction using information available from `HandlerT`, also calls `audit` +logInterface interfaceLogInterface interfaceLogSubtype 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 insert_ InterfaceLog{..} - let transaction = TransactionInterface - { transactionInterfaceName = interfaceLogInterface - , transactionInterfaceSubtype = interfaceLogSubtype - , transactionInterfaceInfo = interfaceLogInfo - , transactionInterfaceWrite = interfaceLogWrite - } - auditHelper transaction TransactionLog - { transactionLogTime = interfaceLogTime - , transactionLogInstance = interfaceLogInstance - , transactionLogInitiator = interfaceLogInitiator - , transactionLogRemote = interfaceLogRemote - , transactionLogInfo = toJSON transaction - } + audit TransactionInterface + { transactionInterfaceName = interfaceLogInterface + , transactionInterfaceSubtype = interfaceLogSubtype + , transactionInterfaceWrite = interfaceLogWrite + , transactionInterfaceRows = interfaceLogRows + , transactionInterfaceInfo = interfaceLogInfo + } diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index dcea62e09..b7ebe8807 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -237,8 +237,9 @@ data Transaction | TransactionInterface { transactionInterfaceName :: Text , transactionInterfaceSubtype :: Text - , transactionInterfaceInfo :: Text , transactionInterfaceWrite :: Bool -- True implies a write to FRADrive + , transactionInterfaceRows :: Maybe Int + , transactionInterfaceInfo :: Text } deriving (Eq, Ord, Read, Show, Generic) diff --git a/src/Handler/LMS/Learners.hs b/src/Handler/LMS/Learners.hs index 380935740..3e4b00b24 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) (tshow nr <> " rows")) + <* runDB (logInterface "LMS" (ciOriginal qsh) (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 77c5f0a6a..201c2eab4 100644 --- a/src/Handler/LMS/Report.hs +++ b/src/Handler/LMS/Report.hs @@ -199,8 +199,7 @@ mkReportTable sid qsh qid = do , LmsReportResult =. lmsReportCsvResult actionData , LmsReportLock =. lmsReportCsvLock actionData , LmsReportTimestamp =. eanow - ] - -- audit $ Transaction.. (add to Audit.Types) + ] lift . queueDBJob $ JobLmsReports qid return $ LmsReportR sid qsh , dbtCsvRenderKey = const $ \case @@ -321,7 +320,7 @@ postLmsReportDirectR sid qsh = 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) (tshow nr <> " rows") + logInterface "LMS" (ciOriginal qsh) (Just nr) "" return (ok200, msg) [] -> do let msg = "Report upload file missing." diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index c30c8a0c7..4fb8c2c5d 100644 --- a/src/Handler/SAP.hs +++ b/src/Handler/SAP.hs @@ -16,6 +16,7 @@ import Handler.Utils import Handler.Utils.Csv import Handler.Utils.Profile +import qualified Data.Text as Text (intercalate) -- import qualified Data.CaseInsensitive as CI import qualified Data.Csv as Csv import Database.Esqueleto.Experimental ((:&)(..)) @@ -138,8 +139,9 @@ getQualificationSAPDirectR = do csvSheetName = "fradrive_sap_" <> fdate <> ".csv" nr = length qualUsers 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" "" $ tshow nr <> " rows" + let logInt = runDB $ logInterface "SAP" quals (Just nr) "" addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\"" csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered <* logInt