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
This commit is contained in:
parent
48ef25aa8f
commit
fb20defc42
@ -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
|
||||
54
src/Audit.hs
54
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
|
||||
}
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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
|
||||
@ -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."
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user