summaryrefslogtreecommitdiff
path: root/src/Network/Bugsnag/Request.hs
blob: 37d4667387f84b03f7dd9f45835852e601448156 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}
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 GHC.Generics
import Network.HTTP.Types
import Network.Socket
import Network.Wai

-- | The web request being handled when the error was encountered
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"

-- | Constructs an empty @'BugsnagRequest'@
bugsnagRequest :: BugsnagRequest
bugsnagRequest = BugsnagRequest
    { brClientIp = Nothing
    , brHeaders = Nothing
    , brHttpMethod = Nothing
    , brUrl = Nothing
    , brReferer = Nothing
    }

-- | Constructs a @'BugsnagRequest'@ from a WAI @'Request'@
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 ""
-- 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 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>"

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