93 lines
2.7 KiB
Haskell
93 lines
2.7 KiB
Haskell
module Audit
|
|
( module Audit.Types
|
|
, AuditException(..)
|
|
, audit
|
|
, AuditRemoteException(..)
|
|
, getRemote
|
|
) where
|
|
|
|
|
|
import Import.NoModel
|
|
import Settings
|
|
import Model
|
|
import Database.Persist.Sql
|
|
import Audit.Types
|
|
|
|
import qualified Data.Text.Encoding as Text
|
|
|
|
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, HasAppSettings (HandlerSite m)) => m IP
|
|
getRemote = do
|
|
ipFromHeader <- getsYesod $ view _appIpFromHeader
|
|
wai <- waiRequest
|
|
|
|
if
|
|
| ipFromHeader
|
|
, Just ip <- byHeader wai
|
|
-> return ip
|
|
| otherwise
|
|
-> byRemoteHost wai
|
|
|
|
where
|
|
byHeader wai = listToMaybe $ do
|
|
(h, v) <- Wai.requestHeaders wai
|
|
guard $ h `elem` ["x-real-ip", "x-forwarded-for"]
|
|
v' <- either (const mzero) return $ Text.decodeUtf8' v
|
|
maybeToList $ IP.decode v'
|
|
|
|
byRemoteHost wai = 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
|
|
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
|
|
, HasAppSettings (HandlerSite m)
|
|
)
|
|
=> Transaction -- ^ Transaction to record
|
|
-> 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) = do
|
|
|
|
transactionLogTime <- liftIO getCurrentTime
|
|
transactionLogInstance <- getsYesod $ view instanceID
|
|
transactionLogInitiator <- liftHandlerT maybeAuthId
|
|
transactionLogRemote <- handle (throwM . AuditRemoteException) $ Just <$> getRemote
|
|
|
|
insert_ TransactionLog{..}
|