89 lines
3.0 KiB
Haskell
89 lines
3.0 KiB
Haskell
module Audit
|
|
( module Audit.Types
|
|
, AuditException(..)
|
|
, 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
|
|
|
|
|
|
data AuditException
|
|
= AuditRemoteException AuditRemoteException
|
|
| AuditUserNotFound UserId
|
|
deriving (Show, Generic, Typeable)
|
|
instance Exception AuditException
|
|
|
|
|
|
audit :: ( AuthId (HandlerSite m) ~ Key User
|
|
, AuthEntity (HandlerSite m) ~ User
|
|
, IsSqlBackend (YesodPersistBackend (HandlerSite m))
|
|
, SqlBackendCanWrite (YesodPersistBackend (HandlerSite m))
|
|
, HasInstanceID (HandlerSite m) InstanceId
|
|
, YesodAuthPersist (HandlerSite m)
|
|
, MonadHandler m
|
|
, MonadCatch m
|
|
)
|
|
=> Transaction -- ^ Transaction to record
|
|
-> [UserId] -- ^ Affected users
|
|
-> 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
|
|
audit (toJSON -> transactionLogInfo) affected = do
|
|
uid <- liftHandlerT maybeAuthId
|
|
|
|
transactionLogTime <- liftIO getCurrentTime
|
|
transactionLogInstance <- getsYesod $ view instanceID
|
|
transactionLogInitiator <- for uid $ \uid' -> maybe (throwM $ AuditUserNotFound uid') (return . userIdent) =<< get uid'
|
|
transactionLogRemote <- handle (throwM . AuditRemoteException) $ Just <$> getRemote
|
|
|
|
tlId <- insert TransactionLog{..}
|
|
|
|
affectedUsers <- forM affected $ \uid' -> maybe (throwM $ AuditUserNotFound uid') (return . userIdent) =<< get uid'
|
|
insertMany_ $ map (TransactionLogAffected tlId) affectedUsers
|
|
|
|
audit' :: ( AuthId (HandlerSite m) ~ Key User
|
|
, AuthEntity (HandlerSite m) ~ User
|
|
, IsSqlBackend (YesodPersistBackend (HandlerSite m))
|
|
, SqlBackendCanWrite (YesodPersistBackend (HandlerSite m))
|
|
, HasInstanceID (HandlerSite m) InstanceId
|
|
, YesodAuthPersist (HandlerSite m)
|
|
, MonadHandler m
|
|
, MonadCatch m
|
|
)
|
|
=> Transaction -- ^ Transaction to record
|
|
-> ReaderT (YesodPersistBackend (HandlerSite m)) m ()
|
|
-- ^ Special case of `audit` for when there are no affected users
|
|
audit' = flip audit []
|