diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,12 @@ +## [_Unreleased_](https://github.com/pbrisbin/bugsnag-haskell/compare/bugsnag-wai-v1.0.0.0...main) + +- None + +## [v1.0.0.0](https://github.com/pbrisbin/bugsnag-haskell/tree/bugsnag-wai-v1.0.0.0) + +First released version. + +--- + +For CHANGELOG details prior to the package re-organization, see +[`archive/CHANGELOG.md`](../archive/CHANGELOG.md). diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2022 Pat Brisbin + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,15 @@ +# WAI integration for Bugsnag + +## Examples + +- [WAI/Warp](./example/Main.hs) + +Examples can be built locally with: + +```console +stack build --flag bugsnag-wai:examples +``` + +--- + +[CHANGELOG](./CHANGELOG.md) | [LICENSE](./LICENSE) diff --git a/bugsnag-wai.cabal b/bugsnag-wai.cabal new file mode 100644 --- /dev/null +++ b/bugsnag-wai.cabal @@ -0,0 +1,95 @@ +cabal-version: 1.18 +name: bugsnag-wai +version: 1.0.0.0 +license: MIT +license-file: LICENSE +maintainer: pbrisbin@gmail.com +author: Patrick Brisbin +homepage: https://github.com/pbrisbin/bugsnag-haskell#readme +synopsis: WAI integration for Bugsnag error reporting for Haskell +description: Please see README.md +category: Web +build-type: Simple +extra-doc-files: + CHANGELOG.md + README.md + +flag examples + description: Build the examples + default: False + +library + exposed-modules: Network.Bugsnag.Wai + hs-source-dirs: src + other-modules: Paths_bugsnag_wai + default-language: Haskell2010 + default-extensions: + BangPatterns DataKinds DeriveAnyClass DeriveFoldable DeriveFunctor + DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies + FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving + LambdaCase MultiParamTypeClasses NoImplicitPrelude + NoMonomorphismRestriction OverloadedStrings RankNTypes + RecordWildCards ScopedTypeVariables StandaloneDeriving + TypeApplications TypeFamilies + + build-depends: + base >=4.11.0 && <5, + bugsnag >=1.0.0.0, + bytestring >=0.10.8.2, + case-insensitive >=1.2.0.11, + http-types >=0.12.3, + iproute >=1.7.8, + network >=2.8.0.1, + text >=1.2.3.1, + unordered-containers >=0.2.10.0, + wai >=3.2.2.1, + warp >=3.3.5 + +executable example-warp + main-is: Main.hs + hs-source-dirs: example + other-modules: Paths_bugsnag_wai + default-language: Haskell2010 + default-extensions: + BangPatterns DataKinds DeriveAnyClass DeriveFoldable DeriveFunctor + DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies + FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving + LambdaCase MultiParamTypeClasses NoImplicitPrelude + NoMonomorphismRestriction OverloadedStrings RankNTypes + RecordWildCards ScopedTypeVariables StandaloneDeriving + TypeApplications TypeFamilies + + build-depends: + base >=4.11.0 && <5, + bugsnag >=1.0.0.0, + bugsnag-wai -any, + wai >=3.2.2.1, + warp >=3.3.5 + + if !flag(examples) + buildable: False + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + other-modules: + Network.Bugsnag.WaiSpec + Paths_bugsnag_wai + + default-language: Haskell2010 + default-extensions: + BangPatterns DataKinds DeriveAnyClass DeriveFoldable DeriveFunctor + DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies + FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving + LambdaCase MultiParamTypeClasses NoImplicitPrelude + NoMonomorphismRestriction OverloadedStrings RankNTypes + RecordWildCards ScopedTypeVariables StandaloneDeriving + TypeApplications TypeFamilies + + build-depends: + base >=4.11.0 && <5, + bugsnag >=1.0.0.0, + bugsnag-wai -any, + hspec >=2.7.1, + unordered-containers >=0.2.10.0 diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -0,0 +1,26 @@ +module Main + ( main + ) where + +import Prelude + +import qualified Data.Bugsnag.Settings as Bugsnag +import Network.Bugsnag.Wai (bugsnagOnException) +import Network.Wai (Application) +import Network.Wai.Handler.Warp + +main :: IO () +main = do + settings <- warpSettings + runSettings settings app + +warpSettings :: IO Settings +warpSettings = do + let settings = Bugsnag.defaultSettings "BUGSNAG_API_KEY" + + pure $ setPort 3000 $ setOnException + (bugsnagOnException settings) + defaultSettings + +app :: Application +app = error "Oops" diff --git a/src/Network/Bugsnag/Wai.hs b/src/Network/Bugsnag/Wai.hs new file mode 100644 --- /dev/null +++ b/src/Network/Bugsnag/Wai.hs @@ -0,0 +1,169 @@ +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 "" . 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 _ = "" + +-- | /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 = "" + go _ v = v + +matchesHeaderName :: HeaderName -> Text -> Bool +matchesHeaderName h = (h ==) . CI.mk . TE.encodeUtf8 diff --git a/test/Network/Bugsnag/WaiSpec.hs b/test/Network/Bugsnag/WaiSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Bugsnag/WaiSpec.hs @@ -0,0 +1,50 @@ +module Network.Bugsnag.WaiSpec + ( spec + ) where + +import Prelude + +import qualified Control.Exception as Exception +import Data.Bugsnag +import qualified Data.HashMap.Strict as HashMap +import Network.Bugsnag +import Network.Bugsnag.Wai +import Test.Hspec + +data TestException = TestException + deriving stock Show + deriving anyclass Exception.Exception + +spec :: Spec +spec = do + describe "redactRequestHeaders" $ do + it "redacts the given headers" $ do + let bn = redactRequestHeaders ["Authorization"] + + event = runBeforeNotify bn TestException $ defaultEvent + { event_request = Just defaultRequest + { request_headers = + Just $ HashMap.fromList + [("Authorization", "secret"), ("X-Foo", "Bar")] + } + } + + lookupEventRequestHeader k e = do + r <- event_request e + hs <- request_headers r + HashMap.lookup k hs + + lookupEventRequestHeader "Authorization" event + `shouldBe` Just "" + lookupEventRequestHeader "X-Foo" event `shouldBe` Just "Bar" + + describe "readForwardedFor" $ do + it "handles empty" $ do + readForwardedFor "" `shouldBe` Nothing + + it "reads a single value" $ do + readForwardedFor "123.123.123" `shouldBe` Just "123.123.123" + + it "reads the first of many values" $ do + readForwardedFor "123.123.123, 45.45.45" + `shouldBe` Just "123.123.123" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -Wno-missing-export-lists #-} +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}