78 lines
2.4 KiB
Haskell
78 lines
2.4 KiB
Haskell
module Audit
|
|
( module Audit.Types
|
|
, audit, audit'
|
|
, AuditRemoteException(..)
|
|
, getRemote
|
|
) where
|
|
|
|
|
|
import Import.NoModel
|
|
import Model
|
|
import Database.Persist.Sql
|
|
import Audit.Types
|
|
|
|
import Utils.Lens
|
|
import qualified Network.Wai as Wai
|
|
import qualified Network.Socket as Wai
|
|
|
|
import qualified Net.IP as IP
|
|
|
|
{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
|
|
|
|
|
|
data AuditRemoteException
|
|
= ARUnsupportedSocketKind
|
|
deriving (Show, Generic, Typeable)
|
|
|
|
instance Exception AuditRemoteException
|
|
|
|
|
|
getRemote :: (MonadHandler m, MonadThrow m) => m IP
|
|
getRemote = do
|
|
wai <- waiRequest
|
|
case Wai.remoteHost wai of
|
|
Wai.SockAddrInet _ hAddr -> let (b1, b2, b3, b4) = Wai.hostAddressToTuple hAddr in return $ IP.ipv4 b1 b2 b3 b4
|
|
Wai.SockAddrInet6 _ _ hAddr _ -> let (w1, w2, w3, w4, w5, w6, w7, w8) = Wai.hostAddress6ToTuple hAddr in return $ IP.ipv6 w1 w2 w3 w4 w5 w6 w7 w8
|
|
_other -> throwM ARUnsupportedSocketKind
|
|
|
|
|
|
audit :: ( AuthId site ~ Key User
|
|
, AuthEntity site ~ User
|
|
, IsSqlBackend (YesodPersistBackend site)
|
|
, SqlBackendCanWrite (YesodPersistBackend site)
|
|
, HasInstanceID site InstanceId
|
|
, YesodAuthPersist site
|
|
)
|
|
=> Transaction -- ^ Transaction to record
|
|
-> [UserId] -- ^ Affected users
|
|
-> YesodDB site ()
|
|
-- ^ Log a transaction using information available from `HandlerT`:
|
|
--
|
|
-- - `transactionLogTime` is now
|
|
-- - `transactionLogInitiator` is currently logged in user (or none)
|
|
-- - `transactionLogRequest` is current HTTP-Request
|
|
audit (toJSON -> transactionLogInfo) affected = do
|
|
uid <- liftHandlerT maybeAuthId
|
|
|
|
transactionLogTime <- liftIO getCurrentTime
|
|
transactionLogInstance <- getsYesod $ view instanceID
|
|
transactionLogInitiator <- for uid $ fmap userIdent . getJust
|
|
transactionLogRemote <- Just <$> getRemote
|
|
|
|
tlId <- insert TransactionLog{..}
|
|
|
|
affectedUsers <- forM affected getJust
|
|
insertMany_ [ TransactionLogAffected tlId aident | aident <- userIdent <$> affectedUsers ]
|
|
|
|
audit' :: ( AuthId site ~ Key User
|
|
, AuthEntity site ~ User
|
|
, IsSqlBackend (YesodPersistBackend site)
|
|
, SqlBackendCanWrite (YesodPersistBackend site)
|
|
, HasInstanceID site InstanceId
|
|
, YesodAuthPersist site
|
|
)
|
|
=> Transaction -- ^ Transaction to record
|
|
-> YesodDB site ()
|
|
-- ^ Special case of `audit` for when there are no affected users
|
|
audit' = flip audit []
|