{-# 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.ByteString (ByteString)
import qualified Data.ByteString.Char8 as C8
import Data.IP
import Data.Maybe (fromMaybe)
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 = Options -> BugsnagRequest -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON (Options -> BugsnagRequest -> Value)
-> Options -> BugsnagRequest -> Value
forall a b. (a -> b) -> a -> b
$ String -> Options
bsAesonOptions String
"br"
    toEncoding :: BugsnagRequest -> Encoding
toEncoding = Options -> BugsnagRequest -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding (Options -> BugsnagRequest -> Encoding)
-> Options -> BugsnagRequest -> Encoding
forall a b. (a -> b) -> a -> b
$ String -> Options
bsAesonOptions String
"br"

-- | 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>"