Wai.hs

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 =
  bugsnagOnExceptionWith (maybe mempty updateEventFromWaiRequest)

bugsnagOnExceptionWith
  :: (Maybe Wai.Request -> BeforeNotify)
  -> Settings
  -> Maybe Wai.Request
  -> SomeException
  -> IO ()
bugsnagOnExceptionWith mkBeforeNotify settings mRequest ex =
  when (Warp.defaultShouldDisplayException ex) $ do
    void $ forkIO $ notifyBugsnagWith (mkBeforeNotify mRequest) settings ex

-- | Constructs a 'Request' from a 'Wai.Request'
bugsnagRequestFromWaiRequest :: Wai.Request -> Request
bugsnagRequestFromWaiRequest 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 =
    requestRealIp request <|> Just (sockAddrToIp $ Wai.remoteHost request)

fromRequestHeaders :: [(HeaderName, ByteString)] -> HashMap Text Text
fromRequestHeaders =
  HashMap.fromList . map (decodeUtf8 . CI.original *** decodeUtf8)

requestRealIp :: Wai.Request -> Maybe ByteString
requestRealIp request =
  requestForwardedFor request
    <|> lookup "X-Real-IP" (Wai.requestHeaders request)

requestForwardedFor :: Wai.Request -> Maybe ByteString
requestForwardedFor request =
  readForwardedFor =<< lookup "X-Forwarded-For" (Wai.requestHeaders request)

readForwardedFor :: ByteString -> Maybe ByteString
readForwardedFor bs
  | C8.null bs = Nothing
  | otherwise = Just $ fst $ C8.break (== ',') bs

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

  requestHost :: Wai.Request -> ByteString
  requestHost = fromMaybe "<unknown>" . Wai.requestHeaderHost

  requestProtocol :: ByteString
  requestProtocol =
    fromMaybe clientProtocol $
      lookup "X-Forwarded-Proto" $
        Wai.requestHeaders request

  prependIfNecessary c x
    | c `C8.isPrefixOf` x = x
    | otherwise = c <> x

sockAddrToIp :: SockAddr -> ByteString
sockAddrToIp (SockAddrInet _ h) = C8.pack $ show $ fromHostAddress h
sockAddrToIp (SockAddrInet6 _ _ h _) = C8.pack $ show $ fromHostAddress6 h
sockAddrToIp _ = "<socket>"

-- | /Attempt/ to divine a 'Device' from a request's User Agent
bugsnagDeviceFromWaiRequest :: Wai.Request -> Maybe Device
bugsnagDeviceFromWaiRequest request = do
  userAgent <- lookup "User-Agent" $ Wai.requestHeaders request
  pure $ bugsnagDeviceFromUserAgent 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 wrequest =
  redactRequestHeaders ["Authorization", "Cookie", "X-XSRF-TOKEN"]
    <> updateEventFromWaiRequestUnredacted wrequest

updateEventFromWaiRequestUnredacted :: Wai.Request -> BeforeNotify
updateEventFromWaiRequestUnredacted wrequest =
  maybe mempty setDevice mdevice <> setRequest request <> setContext context
 where
  mdevice = bugsnagDeviceFromWaiRequest wrequest
  request = bugsnagRequestFromWaiRequest wrequest
  context = "/" <> T.intercalate "/" (Wai.pathInfo 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 headers = updateEvent $ \event ->
  event {event_request = redactHeaders headers <$> event_request event}

redactHeaders :: [HeaderName] -> Request -> Request
redactHeaders headers request =
  request
    { request_headers =
        redactBugsnagRequestHeaders headers
          <$> request_headers request
    }

redactBugsnagRequestHeaders
  :: [HeaderName] -> HashMap Text Text -> HashMap Text Text
redactBugsnagRequestHeaders redactList = HashMap.mapWithKey go
 where
  go :: Text -> Text -> Text
  go k _ | any (`matchesHeaderName` k) redactList = "<redacted>"
  go _ v = v

matchesHeaderName :: HeaderName -> Text -> Bool
matchesHeaderName h = (h ==) . CI.mk . TE.encodeUtf8