{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}

module Network.Bugsnag.Request
    ( BugsnagRequest(..)
    , bugsnagRequest
    , bugsnagRequestFromWaiRequest
    ) where

import Prelude

import Control.Applicative ((<|>))
import Data.Aeson
import Data.Aeson.Ext
import Data.Aeson.Types
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as C8
import Data.IP
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import GHC.Generics
import Network.Bugsnag.BugsnagRequestHeaders
import Network.HTTP.Types
import Network.Socket
import Network.Wai

-- | The web request being handled when the error was encountered
data BugsnagRequest = BugsnagRequest
    { BugsnagRequest -> Maybe ByteString
brClientIp :: Maybe ByteString
    , BugsnagRequest -> Maybe BugsnagRequestHeaders
brHeaders :: Maybe BugsnagRequestHeaders
    , BugsnagRequest -> Maybe ByteString
brHttpMethod :: Maybe Method
    , BugsnagRequest -> Maybe ByteString
brUrl :: Maybe ByteString
    , BugsnagRequest -> Maybe ByteString
brReferer :: Maybe ByteString
    }
    deriving stock (forall x. BugsnagRequest -> Rep BugsnagRequest x)
-> (forall x. Rep BugsnagRequest x -> BugsnagRequest)
-> Generic BugsnagRequest
forall x. Rep BugsnagRequest x -> BugsnagRequest
forall x. BugsnagRequest -> Rep BugsnagRequest x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep BugsnagRequest x -> BugsnagRequest
$cfrom :: forall x. BugsnagRequest -> Rep BugsnagRequest x
Generic

instance ToJSON BugsnagRequest where
    toJSON :: BugsnagRequest -> Value
toJSON BugsnagRequest {Maybe ByteString
Maybe BugsnagRequestHeaders
brReferer :: Maybe ByteString
brUrl :: Maybe ByteString
brHttpMethod :: Maybe ByteString
brHeaders :: Maybe BugsnagRequestHeaders
brClientIp :: Maybe ByteString
brReferer :: BugsnagRequest -> Maybe ByteString
brUrl :: BugsnagRequest -> Maybe ByteString
brHttpMethod :: BugsnagRequest -> Maybe ByteString
brHeaders :: BugsnagRequest -> Maybe BugsnagRequestHeaders
brClientIp :: BugsnagRequest -> Maybe ByteString
..} = [Pair] -> Value
object
        ((Text
"clientIp" Text -> Maybe Text -> [Pair]
forall v. ToJSON v => Text -> Maybe v -> [Pair]
.=? (ByteString -> Text
decodeUtf8 (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
brClientIp))
        [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> (Text
"headers" Text -> Maybe BugsnagRequestHeaders -> [Pair]
forall v. ToJSON v => Text -> Maybe v -> [Pair]
.=? Maybe BugsnagRequestHeaders
brHeaders)
        [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> (Text
"httpMethod" Text -> Maybe Text -> [Pair]
forall v. ToJSON v => Text -> Maybe v -> [Pair]
.=? (ByteString -> Text
decodeUtf8 (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
brHttpMethod))
        [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> (Text
"url" Text -> Maybe Text -> [Pair]
forall v. ToJSON v => Text -> Maybe v -> [Pair]
.=? (ByteString -> Text
decodeUtf8 (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
brUrl))
        [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> (Text
"referer" Text -> Maybe Text -> [Pair]
forall v. ToJSON v => Text -> Maybe v -> [Pair]
.=? (ByteString -> Text
decodeUtf8 (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
brReferer))
        )
      where
        -- For implementing "omit Nothing fields"
        (.=?) :: ToJSON v => Text -> Maybe v -> [Pair]
        .=? :: Text -> Maybe v -> [Pair]
(.=?) Text
k = [Pair] -> (v -> [Pair]) -> Maybe v -> [Pair]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Pair -> [Pair]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pair -> [Pair]) -> (v -> Pair) -> v -> [Pair]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Key
fromText Text
k Key -> v -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=))
    toEncoding :: BugsnagRequest -> Encoding
toEncoding BugsnagRequest {Maybe ByteString
Maybe BugsnagRequestHeaders
brReferer :: Maybe ByteString
brUrl :: Maybe ByteString
brHttpMethod :: Maybe ByteString
brHeaders :: Maybe BugsnagRequestHeaders
brClientIp :: Maybe ByteString
brReferer :: BugsnagRequest -> Maybe ByteString
brUrl :: BugsnagRequest -> Maybe ByteString
brHttpMethod :: BugsnagRequest -> Maybe ByteString
brHeaders :: BugsnagRequest -> Maybe BugsnagRequestHeaders
brClientIp :: BugsnagRequest -> Maybe ByteString
..} = Series -> Encoding
pairs
        ((Text
"clientIp" Text -> Maybe Text -> Series
forall v. ToJSON v => Text -> Maybe v -> Series
.=? (ByteString -> Text
decodeUtf8 (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
brClientIp))
        Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> (Text
"headers" Text -> Maybe BugsnagRequestHeaders -> Series
forall v. ToJSON v => Text -> Maybe v -> Series
.=? Maybe BugsnagRequestHeaders
brHeaders)
        Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> (Text
"httpMethod" Text -> Maybe Text -> Series
forall v. ToJSON v => Text -> Maybe v -> Series
.=? (ByteString -> Text
decodeUtf8 (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
brHttpMethod))
        Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> (Text
"url" Text -> Maybe Text -> Series
forall v. ToJSON v => Text -> Maybe v -> Series
.=? (ByteString -> Text
decodeUtf8 (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
brUrl))
        Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> (Text
"referer" Text -> Maybe Text -> Series
forall v. ToJSON v => Text -> Maybe v -> Series
.=? (ByteString -> Text
decodeUtf8 (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
brReferer))
        )
      where
        -- For implementing "omit Nothing fields"
        (.=?) :: ToJSON v => Text -> Maybe v -> Series
        Text
k .=? :: Text -> Maybe v -> Series
.=? Maybe v
mv = Series -> (v -> Series) -> Maybe v -> Series
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Series
forall a. Monoid a => a
mempty (\v
v -> Text -> Key
fromText Text
k Key -> v -> Series
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= v
v) Maybe v
mv

-- | Constructs an empty @'BugsnagRequest'@
bugsnagRequest :: BugsnagRequest
bugsnagRequest :: BugsnagRequest
bugsnagRequest = BugsnagRequest :: Maybe ByteString
-> Maybe BugsnagRequestHeaders
-> Maybe ByteString
-> Maybe ByteString
-> Maybe ByteString
-> BugsnagRequest
BugsnagRequest
    { brClientIp :: Maybe ByteString
brClientIp = Maybe ByteString
forall a. Maybe a
Nothing
    , brHeaders :: Maybe BugsnagRequestHeaders
brHeaders = Maybe BugsnagRequestHeaders
forall a. Maybe a
Nothing
    , brHttpMethod :: Maybe ByteString
brHttpMethod = Maybe ByteString
forall a. Maybe a
Nothing
    , brUrl :: Maybe ByteString
brUrl = Maybe ByteString
forall a. Maybe a
Nothing
    , brReferer :: Maybe ByteString
brReferer = Maybe ByteString
forall a. Maybe a
Nothing
    }

-- | Constructs a @'BugsnagRequest'@ from a WAI @'Request'@
bugsnagRequestFromWaiRequest :: Request -> BugsnagRequest
bugsnagRequestFromWaiRequest :: Request -> BugsnagRequest
bugsnagRequestFromWaiRequest Request
request = BugsnagRequest
bugsnagRequest
    { brClientIp :: Maybe ByteString
brClientIp = Request -> Maybe ByteString
requestRealIp Request
request
        Maybe ByteString -> Maybe ByteString -> Maybe ByteString
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (SockAddr -> ByteString
sockAddrToIp (SockAddr -> ByteString) -> SockAddr -> ByteString
forall a b. (a -> b) -> a -> b
$ Request -> SockAddr
remoteHost Request
request)
    , brHeaders :: Maybe BugsnagRequestHeaders
brHeaders = BugsnagRequestHeaders -> Maybe BugsnagRequestHeaders
forall a. a -> Maybe a
Just (BugsnagRequestHeaders -> Maybe BugsnagRequestHeaders)
-> BugsnagRequestHeaders -> Maybe BugsnagRequestHeaders
forall a b. (a -> b) -> a -> b
$ RequestHeaders -> BugsnagRequestHeaders
bugsnagRequestHeaders (RequestHeaders -> BugsnagRequestHeaders)
-> RequestHeaders -> BugsnagRequestHeaders
forall a b. (a -> b) -> a -> b
$ Request -> RequestHeaders
requestHeaders Request
request
    , brHttpMethod :: Maybe ByteString
brHttpMethod = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
requestMethod Request
request
    , brUrl :: Maybe ByteString
brUrl = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
requestUrl Request
request
    , brReferer :: Maybe ByteString
brReferer = Request -> Maybe ByteString
requestHeaderReferer Request
request
    }

requestRealIp :: Request -> Maybe ByteString
requestRealIp :: Request -> Maybe ByteString
requestRealIp Request
request =
    Request -> Maybe ByteString
requestForwardedFor Request
request Maybe ByteString -> Maybe ByteString -> Maybe ByteString
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"X-Real-IP" (Request -> RequestHeaders
requestHeaders Request
request)

requestForwardedFor :: Request -> Maybe ByteString
requestForwardedFor :: Request -> Maybe ByteString
requestForwardedFor Request
request =
    ByteString -> Maybe ByteString
readForwardedFor (ByteString -> Maybe ByteString)
-> Maybe ByteString -> Maybe ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"X-Forwarded-For" (Request -> RequestHeaders
requestHeaders Request
request)

-- |
--
-- >>> readForwardedFor ""
-- Nothing
--
-- >>> readForwardedFor "123.123.123"
-- Just "123.123.123"
--
-- >>> readForwardedFor "123.123.123, 45.45.45"
-- Just "123.123.123"
--
readForwardedFor :: ByteString -> Maybe ByteString
readForwardedFor :: ByteString -> Maybe ByteString
readForwardedFor ByteString
bs
    | ByteString -> Bool
C8.null ByteString
bs = Maybe ByteString
forall a. Maybe a
Nothing
    | Bool
otherwise = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, ByteString) -> ByteString)
-> (ByteString, ByteString) -> ByteString
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> (ByteString, ByteString)
C8.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',') ByteString
bs

requestUrl :: Request -> ByteString
requestUrl :: Request -> ByteString
requestUrl Request
request =
    ByteString
requestProtocol
        ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"://"
        ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
requestHost Request
request
        ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString -> ByteString
prependIfNecessary ByteString
"/" (Request -> ByteString
rawPathInfo Request
request)
        ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
rawQueryString Request
request
  where
    clientProtocol :: ByteString
    clientProtocol :: ByteString
clientProtocol = if Request -> Bool
isSecure Request
request then ByteString
"https" else ByteString
"http"

    requestHost :: Request -> ByteString
    requestHost :: Request -> ByteString
requestHost = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"<unknown>" (Maybe ByteString -> ByteString)
-> (Request -> Maybe ByteString) -> Request -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Maybe ByteString
requestHeaderHost

    requestProtocol :: ByteString
    requestProtocol :: ByteString
requestProtocol =
        ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
clientProtocol (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"X-Forwarded-Proto" (RequestHeaders -> Maybe ByteString)
-> RequestHeaders -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> RequestHeaders
requestHeaders
            Request
request

    prependIfNecessary :: ByteString -> ByteString -> ByteString
prependIfNecessary ByteString
c ByteString
x
        | ByteString
c ByteString -> ByteString -> Bool
`C8.isPrefixOf` ByteString
x = ByteString
x
        | Bool
otherwise = ByteString
c ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
x

sockAddrToIp :: SockAddr -> ByteString
sockAddrToIp :: SockAddr -> ByteString
sockAddrToIp (SockAddrInet PortNumber
_ HostAddress
h) = String -> ByteString
C8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ IPv4 -> String
forall a. Show a => a -> String
show (IPv4 -> String) -> IPv4 -> String
forall a b. (a -> b) -> a -> b
$ HostAddress -> IPv4
fromHostAddress HostAddress
h
sockAddrToIp (SockAddrInet6 PortNumber
_ HostAddress
_ HostAddress6
h HostAddress
_) = String -> ByteString
C8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ IPv6 -> String
forall a. Show a => a -> String
show (IPv6 -> String) -> IPv6 -> String
forall a b. (a -> b) -> a -> b
$ HostAddress6 -> IPv6
fromHostAddress6 HostAddress6
h
sockAddrToIp (SockAddrUnix String
_) = ByteString
"<socket>"

-- Matches deprecated and eventually removed SockAddrCan on older GHCs.
-- overlapping-patterns warning is disabled for this.
sockAddrToIp SockAddr
_ = ByteString
"<invalid>"