module Network.Bugsnag.Wai
    ( bugsnagOnException
    , bugsnagOnExceptionWith
    , updateEventFromWaiRequest
    , updateEventFromWaiRequestUnredacted
    , bugsnagRequestFromWaiRequest
    , bugsnagDeviceFromWaiRequest

    -- * Exported for testing
    , redactRequestHeaders
    , readForwardedFor
    ) where

import Prelude

import Control.Applicative ((<|>))
import Control.Arrow ((***))
import Control.Concurrent (forkIO)
import Control.Exception (SomeException)
import Control.Monad (void, when)
import Data.Bugsnag
import Data.Bugsnag.Settings
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as C8
import qualified Data.CaseInsensitive as CI
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.IP
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import qualified Data.Text.Encoding as TE
import Network.Bugsnag
import Network.Bugsnag.Device
import Network.HTTP.Types
import Network.Socket
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp

bugsnagOnException :: Settings -> Maybe Wai.Request -> SomeException -> IO ()
bugsnagOnException :: Settings -> Maybe Request -> SomeException -> IO ()
bugsnagOnException =
    (Maybe Request -> BeforeNotify)
-> Settings -> Maybe Request -> SomeException -> IO ()
bugsnagOnExceptionWith (BeforeNotify
-> (Request -> BeforeNotify) -> Maybe Request -> BeforeNotify
forall b a. b -> (a -> b) -> Maybe a -> b
maybe BeforeNotify
forall a. Monoid a => a
mempty Request -> BeforeNotify
updateEventFromWaiRequest)

bugsnagOnExceptionWith
    :: (Maybe Wai.Request -> BeforeNotify)
    -> Settings
    -> Maybe Wai.Request
    -> SomeException
    -> IO ()
bugsnagOnExceptionWith :: (Maybe Request -> BeforeNotify)
-> Settings -> Maybe Request -> SomeException -> IO ()
bugsnagOnExceptionWith Maybe Request -> BeforeNotify
mkBeforeNotify Settings
settings Maybe Request
mRequest SomeException
ex =
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SomeException -> Bool
Warp.defaultShouldDisplayException SomeException
ex) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ BeforeNotify -> Settings -> SomeException -> IO ()
forall e. Exception e => BeforeNotify -> Settings -> e -> IO ()
notifyBugsnagWith (Maybe Request -> BeforeNotify
mkBeforeNotify Maybe Request
mRequest) Settings
settings SomeException
ex

-- | Constructs a 'Request' from a 'Wai.Request'
bugsnagRequestFromWaiRequest :: Wai.Request -> Request
bugsnagRequestFromWaiRequest :: Request -> Request
bugsnagRequestFromWaiRequest Request
request = Request
defaultRequest
    { request_clientIp :: Maybe Text
request_clientIp = ByteString -> Text
decodeUtf8 (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
clientIp
    , request_headers :: Maybe (HashMap Text Text)
request_headers = HashMap Text Text -> Maybe (HashMap Text Text)
forall a. a -> Maybe a
Just (HashMap Text Text -> Maybe (HashMap Text Text))
-> HashMap Text Text -> Maybe (HashMap Text Text)
forall a b. (a -> b) -> a -> b
$ [(HeaderName, ByteString)] -> HashMap Text Text
fromRequestHeaders ([(HeaderName, ByteString)] -> HashMap Text Text)
-> [(HeaderName, ByteString)] -> HashMap Text Text
forall a b. (a -> b) -> a -> b
$ Request -> [(HeaderName, ByteString)]
Wai.requestHeaders Request
request
    , request_httpMethod :: Maybe Text
request_httpMethod = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
Wai.requestMethod Request
request
    , request_url :: Maybe Text
request_url = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
requestUrl Request
request
    , request_referer :: Maybe Text
request_referer = ByteString -> Text
decodeUtf8 (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> Maybe ByteString
Wai.requestHeaderReferer Request
request
    }
  where
    clientIp :: Maybe ByteString
clientIp =
        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
Wai.remoteHost Request
request)

fromRequestHeaders :: [(HeaderName, ByteString)] -> HashMap Text Text
fromRequestHeaders :: [(HeaderName, ByteString)] -> HashMap Text Text
fromRequestHeaders =
    [(Text, Text)] -> HashMap Text Text
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList ([(Text, Text)] -> HashMap Text Text)
-> ([(HeaderName, ByteString)] -> [(Text, Text)])
-> [(HeaderName, ByteString)]
-> HashMap Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((HeaderName, ByteString) -> (Text, Text))
-> [(HeaderName, ByteString)] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> (HeaderName -> ByteString) -> HeaderName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> ByteString
forall s. CI s -> s
CI.original (HeaderName -> Text)
-> (ByteString -> Text) -> (HeaderName, ByteString) -> (Text, Text)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** ByteString -> Text
decodeUtf8)

requestRealIp :: Wai.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 -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"X-Real-IP" (Request -> [(HeaderName, ByteString)]
Wai.requestHeaders Request
request)

requestForwardedFor :: Wai.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 -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"X-Forwarded-For" (Request -> [(HeaderName, ByteString)]
Wai.requestHeaders Request
request)

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 :: Wai.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
Wai.rawPathInfo Request
request)
        ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
Wai.rawQueryString Request
request
  where
    clientProtocol :: ByteString
    clientProtocol :: ByteString
clientProtocol = if Request -> Bool
Wai.isSecure Request
request then ByteString
"https" else ByteString
"http"

    requestHost :: Wai.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
Wai.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 -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"X-Forwarded-Proto"
            ([(HeaderName, ByteString)] -> Maybe ByteString)
-> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> [(HeaderName, ByteString)]
Wai.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 SockAddr
_ = ByteString
"<socket>"

-- | /Attempt/ to divine a 'Device' from a request's User Agent
bugsnagDeviceFromWaiRequest :: Wai.Request -> Maybe Device
bugsnagDeviceFromWaiRequest :: Request -> Maybe Device
bugsnagDeviceFromWaiRequest Request
request = do
    ByteString
userAgent <- HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"User-Agent" ([(HeaderName, ByteString)] -> Maybe ByteString)
-> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> [(HeaderName, ByteString)]
Wai.requestHeaders Request
request
    Device -> Maybe Device
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Device -> Maybe Device) -> Device -> Maybe Device
forall a b. (a -> b) -> a -> b
$ ByteString -> Device
bugsnagDeviceFromUserAgent ByteString
userAgent

-- | Set the events 'Event' and 'Device'
--
-- This function redacts the following Request headers:
--
-- - Authorization
-- - Cookie
-- - X-XSRF-TOKEN (CSRF token header used by Yesod)
--
-- To avoid this, use 'updateEventFromWaiRequestUnredacted'.
--
updateEventFromWaiRequest :: Wai.Request -> BeforeNotify
updateEventFromWaiRequest :: Request -> BeforeNotify
updateEventFromWaiRequest Request
wrequest =
    [HeaderName] -> BeforeNotify
redactRequestHeaders [HeaderName
"Authorization", HeaderName
"Cookie", HeaderName
"X-XSRF-TOKEN"]
        BeforeNotify -> BeforeNotify -> BeforeNotify
forall a. Semigroup a => a -> a -> a
<> Request -> BeforeNotify
updateEventFromWaiRequestUnredacted Request
wrequest

updateEventFromWaiRequestUnredacted :: Wai.Request -> BeforeNotify
updateEventFromWaiRequestUnredacted :: Request -> BeforeNotify
updateEventFromWaiRequestUnredacted Request
wrequest =
    BeforeNotify
-> (Device -> BeforeNotify) -> Maybe Device -> BeforeNotify
forall b a. b -> (a -> b) -> Maybe a -> b
maybe BeforeNotify
forall a. Monoid a => a
mempty Device -> BeforeNotify
setDevice Maybe Device
mdevice BeforeNotify -> BeforeNotify -> BeforeNotify
forall a. Semigroup a => a -> a -> a
<> Request -> BeforeNotify
setRequest Request
request BeforeNotify -> BeforeNotify -> BeforeNotify
forall a. Semigroup a => a -> a -> a
<> Text -> BeforeNotify
setContext Text
context
  where
    mdevice :: Maybe Device
mdevice = Request -> Maybe Device
bugsnagDeviceFromWaiRequest Request
wrequest
    request :: Request
request = Request -> Request
bugsnagRequestFromWaiRequest Request
wrequest
    context :: Text
context = Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"/" (Request -> [Text]
Wai.pathInfo Request
wrequest)

-- | Redact the given request headers
--
-- Headers like @Authorization@ may contain information you don't want to report
-- to Bugsnag.
--
-- > redactRequestHeaders ["Authorization", "Cookie"]
--
redactRequestHeaders :: [HeaderName] -> BeforeNotify
redactRequestHeaders :: [HeaderName] -> BeforeNotify
redactRequestHeaders [HeaderName]
headers = (Event -> Event) -> BeforeNotify
updateEvent ((Event -> Event) -> BeforeNotify)
-> (Event -> Event) -> BeforeNotify
forall a b. (a -> b) -> a -> b
$ \Event
event ->
    Event
event { event_request :: Maybe Request
event_request = [HeaderName] -> Request -> Request
redactHeaders [HeaderName]
headers (Request -> Request) -> Maybe Request -> Maybe Request
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event -> Maybe Request
event_request Event
event }

redactHeaders :: [HeaderName] -> Request -> Request
redactHeaders :: [HeaderName] -> Request -> Request
redactHeaders [HeaderName]
headers Request
request = Request
request
    { request_headers :: Maybe (HashMap Text Text)
request_headers = [HeaderName] -> HashMap Text Text -> HashMap Text Text
redactBugsnagRequestHeaders [HeaderName]
headers
        (HashMap Text Text -> HashMap Text Text)
-> Maybe (HashMap Text Text) -> Maybe (HashMap Text Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> Maybe (HashMap Text Text)
request_headers Request
request
    }

redactBugsnagRequestHeaders
    :: [HeaderName] -> HashMap Text Text -> HashMap Text Text
redactBugsnagRequestHeaders :: [HeaderName] -> HashMap Text Text -> HashMap Text Text
redactBugsnagRequestHeaders [HeaderName]
redactList = (Text -> Text -> Text) -> HashMap Text Text -> HashMap Text Text
forall k v1 v2. (k -> v1 -> v2) -> HashMap k v1 -> HashMap k v2
HashMap.mapWithKey Text -> Text -> Text
go
  where
    go :: Text -> Text -> Text
    go :: Text -> Text -> Text
go Text
k Text
_ | (HeaderName -> Bool) -> [HeaderName] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (HeaderName -> Text -> Bool
`matchesHeaderName` Text
k) [HeaderName]
redactList = Text
"<redacted>"
    go Text
_ Text
v = Text
v

matchesHeaderName :: HeaderName -> Text -> Bool
matchesHeaderName :: HeaderName -> Text -> Bool
matchesHeaderName HeaderName
h = (HeaderName
h HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
==) (HeaderName -> Bool) -> (Text -> HeaderName) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> HeaderName)
-> (Text -> ByteString) -> Text -> HeaderName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TE.encodeUtf8