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 = decodeUtf8 <$> clientIp
    , request_headers = Just $ fromRequestHeaders $ Wai.requestHeaders request
    , request_httpMethod = Just $ decodeUtf8 $ Wai.requestMethod request
    , request_url = Just $ decodeUtf8 $ requestUrl request
    , request_referer = decodeUtf8 <$> Wai.requestHeaderReferer request
    }
 where
  clientIp :: Maybe ByteString
clientIp =
    Request -> Maybe ByteString
requestRealIp Request
request Maybe ByteString -> Maybe ByteString -> Maybe ByteString
forall a. Maybe a -> Maybe a -> Maybe a
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 b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
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 a. Maybe a -> Maybe a -> Maybe a
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 a. a -> Maybe a
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 = redactHeaders headers <$> event_request event}

redactHeaders :: [HeaderName] -> Request -> Request
redactHeaders :: [HeaderName] -> Request -> Request
redactHeaders [HeaderName]
headers Request
request =
  Request
request
    { request_headers =
        redactBugsnagRequestHeaders headers
          <$> request_headers 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