bugsnag-wai (empty) → 1.0.0.0
raw patch · 8 files changed
+388/−0 lines, 8 filesdep +basedep +bugsnagdep +bugsnag-wai
Dependencies added: base, bugsnag, bugsnag-wai, bytestring, case-insensitive, hspec, http-types, iproute, network, text, unordered-containers, wai, warp
Files
- CHANGELOG.md +12/−0
- LICENSE +19/−0
- README.md +15/−0
- bugsnag-wai.cabal +95/−0
- example/Main.hs +26/−0
- src/Network/Bugsnag/Wai.hs +169/−0
- test/Network/Bugsnag/WaiSpec.hs +50/−0
- test/Spec.hs +2/−0
+ CHANGELOG.md view
@@ -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).
+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2022 Pat Brisbin <pbrisbin@gmail.com>++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.
+ README.md view
@@ -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)
+ bugsnag-wai.cabal view
@@ -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
+ example/Main.hs view
@@ -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"
+ src/Network/Bugsnag/Wai.hs view
@@ -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 "<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
+ test/Network/Bugsnag/WaiSpec.hs view
@@ -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 "<redacted>"+ 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"
+ test/Spec.hs view
@@ -0,0 +1,2 @@+{-# OPTIONS_GHC -Wno-missing-export-lists #-}+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}