{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.Bugsnag.Request
( BugsnagRequest(..)
, bugsnagRequest
, bugsnagRequestFromWaiRequest
) where
import Control.Applicative ((<|>))
import Data.Aeson
import Data.Aeson.Ext
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as C8
import Data.IP
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import GHC.Generics
import Network.HTTP.Types
import Network.Socket
import Network.Wai
data BugsnagRequest = BugsnagRequest
{ brClientIp :: Maybe ByteString
, brHeaders :: Maybe RequestHeaders
, brHttpMethod :: Maybe Method
, brUrl :: Maybe ByteString
, brReferer :: Maybe ByteString
}
deriving Generic
instance ToJSON BugsnagRequest where
toJSON = genericToJSON $ bsAesonOptions "br"
toEncoding = genericToEncoding $ bsAesonOptions "br"
bugsnagRequest :: BugsnagRequest
bugsnagRequest = BugsnagRequest
{ brClientIp = Nothing
, brHeaders = Nothing
, brHttpMethod = Nothing
, brUrl = Nothing
, brReferer = Nothing
}
bugsnagRequestFromWaiRequest :: Request -> BugsnagRequest
bugsnagRequestFromWaiRequest request = bugsnagRequest
{ brClientIp = requestRealIp request
<|> Just (sockAddrToIp $ remoteHost request)
, brHeaders = Just $ requestHeaders request
, brHttpMethod = Just $ requestMethod request
, brUrl = Just $ requestUrl request
, brReferer = requestHeaderReferer request
}
requestRealIp :: Request -> Maybe ByteString
requestRealIp request = requestForwardedFor request
<|> lookup "X-Real-IP" (requestHeaders request)
requestForwardedFor :: Request -> Maybe ByteString
requestForwardedFor request = readForwardedFor
=<< lookup "X-Forwarded-For" (requestHeaders request)
readForwardedFor :: ByteString -> Maybe ByteString
readForwardedFor bs
| C8.null bs = Nothing
| otherwise = Just $ fst $ C8.break (== ',') bs
requestUrl :: Request -> ByteString
requestUrl request = requestProtocol
<> "://"
<> requestHost request
<> rawPathInfo request
<> rawQueryString request
where
clientProtocol = if isSecure request then "https" else "http"
requestHost = fromMaybe "<unknown>" . requestHeaderHost
requestProtocol = fromMaybe clientProtocol
$ lookup "X-Forwarded-Proto"
$ requestHeaders request
sockAddrToIp :: SockAddr -> ByteString
sockAddrToIp (SockAddrInet _ h) = C8.pack $ show $ fromHostAddress h
sockAddrToIp (SockAddrInet6 _ _ h _) = C8.pack $ show $ fromHostAddress6 h
sockAddrToIp (SockAddrUnix _) = "<socket>"
sockAddrToIp _ = "<invalid>"