bugsnag-wai 1.0.0.1 → 1.0.0.2
raw patch · 6 files changed
+121/−106 lines, 6 filesdep ~bugsnagPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: bugsnag
API changes (from Hackage documentation)
Files
- README.md +5/−0
- bugsnag-wai.cabal +6/−6
- example/Main.hs +8/−6
- src/Network/Bugsnag/Wai.hs +66/−64
- test/Network/Bugsnag/WaiSpec.hs +35/−29
- test/Spec.hs +1/−1
README.md view
@@ -1,5 +1,10 @@ # WAI integration for Bugsnag +[](https://hackage.haskell.org/package/bugsnag-wai)+[](http://stackage.org/nightly/package/bugsnag-wai)+[](http://stackage.org/lts/package/bugsnag-wai)++ ## Examples - [WAI/Warp](./example/Main.hs)
bugsnag-wai.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.18 name: bugsnag-wai-version: 1.0.0.1+version: 1.0.0.2 license: MIT license-file: LICENSE maintainer: pbrisbin@gmail.com@@ -34,7 +34,7 @@ build-depends: base >=4.11.0 && <5,- bugsnag >=1.0.0.1,+ bugsnag >=1.1.0.1, bytestring >=0.10.8.2, case-insensitive >=1.2.0.11, http-types >=0.12.2,@@ -61,8 +61,8 @@ build-depends: base >=4.11.0 && <5,- bugsnag >=1.0.0.1,- bugsnag-wai -any,+ bugsnag >=1.1.0.1,+ bugsnag-wai, wai >=3.2.1.2, warp >=3.2.25 @@ -89,7 +89,7 @@ build-depends: base >=4.11.0 && <5,- bugsnag >=1.0.0.1,- bugsnag-wai -any,+ bugsnag >=1.1.0.1,+ bugsnag-wai, hspec >=2.5.5, unordered-containers >=0.2.9.0
example/Main.hs view
@@ -1,6 +1,6 @@ module Main- ( main- ) where+ ( main+ ) where import Prelude @@ -11,14 +11,16 @@ main :: IO () main = do- settings <- warpSettings- runSettings settings app+ settings <- warpSettings+ runSettings settings app warpSettings :: IO Settings warpSettings = do- let settings = Bugsnag.defaultSettings "BUGSNAG_API_KEY"+ let settings = Bugsnag.defaultSettings "BUGSNAG_API_KEY" - pure $ setPort 3000 $ setOnException+ pure $+ setPort 3000 $+ setOnException (bugsnagOnException settings) defaultSettings
src/Network/Bugsnag/Wai.hs view
@@ -1,15 +1,15 @@ module Network.Bugsnag.Wai- ( bugsnagOnException- , bugsnagOnExceptionWith- , updateEventFromWaiRequest- , updateEventFromWaiRequestUnredacted- , bugsnagRequestFromWaiRequest- , bugsnagDeviceFromWaiRequest+ ( bugsnagOnException+ , bugsnagOnExceptionWith+ , updateEventFromWaiRequest+ , updateEventFromWaiRequestUnredacted+ , bugsnagRequestFromWaiRequest+ , bugsnagDeviceFromWaiRequest -- * Exported for testing- , redactRequestHeaders- , readForwardedFor- ) where+ , redactRequestHeaders+ , readForwardedFor+ ) where import Prelude @@ -40,71 +40,73 @@ bugsnagOnException :: Settings -> Maybe Wai.Request -> SomeException -> IO () bugsnagOnException =- bugsnagOnExceptionWith (maybe mempty updateEventFromWaiRequest)+ bugsnagOnExceptionWith (maybe mempty updateEventFromWaiRequest) bugsnagOnExceptionWith- :: (Maybe Wai.Request -> BeforeNotify)- -> Settings- -> Maybe Wai.Request- -> SomeException- -> IO ()+ :: (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+ 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+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)+ where+ clientIp =+ requestRealIp request <|> Just (sockAddrToIp $ Wai.remoteHost request) fromRequestHeaders :: [(HeaderName, ByteString)] -> HashMap Text Text fromRequestHeaders =- HashMap.fromList . map (decodeUtf8 . CI.original *** decodeUtf8)+ HashMap.fromList . map (decodeUtf8 . CI.original *** decodeUtf8) requestRealIp :: Wai.Request -> Maybe ByteString-requestRealIp request = requestForwardedFor request+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 =<< lookup "X-Forwarded-For" (Wai.requestHeaders request) readForwardedFor :: ByteString -> Maybe ByteString readForwardedFor bs- | C8.null bs = Nothing- | otherwise = Just $ fst $ C8.break (== ',') 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"+ 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+ requestHost :: Wai.Request -> ByteString+ requestHost = fromMaybe "<unknown>" . Wai.requestHeaderHost - requestProtocol :: ByteString- requestProtocol =- fromMaybe clientProtocol- $ lookup "X-Forwarded-Proto"- $ Wai.requestHeaders request+ requestProtocol :: ByteString+ requestProtocol =+ fromMaybe clientProtocol $+ lookup "X-Forwarded-Proto" $+ Wai.requestHeaders request - prependIfNecessary c x- | c `C8.isPrefixOf` x = x- | otherwise = c <> x+ prependIfNecessary c x+ | c `C8.isPrefixOf` x = x+ | otherwise = c <> x sockAddrToIp :: SockAddr -> ByteString sockAddrToIp (SockAddrInet _ h) = C8.pack $ show $ fromHostAddress h@@ -114,8 +116,8 @@ -- | /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+ userAgent <- lookup "User-Agent" $ Wai.requestHeaders request+ pure $ bugsnagDeviceFromUserAgent userAgent -- | Set the events 'Event' and 'Device' --@@ -126,19 +128,18 @@ -- - 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+ 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)+ 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 --@@ -146,24 +147,25 @@ -- to Bugsnag. -- -- > redactRequestHeaders ["Authorization", "Cookie"]--- redactRequestHeaders :: [HeaderName] -> BeforeNotify redactRequestHeaders headers = updateEvent $ \event ->- event { event_request = redactHeaders headers <$> event_request event }+ event {event_request = redactHeaders headers <$> event_request event} redactHeaders :: [HeaderName] -> Request -> Request-redactHeaders headers request = request- { request_headers = redactBugsnagRequestHeaders headers- <$> request_headers request+redactHeaders headers request =+ request+ { request_headers =+ redactBugsnagRequestHeaders headers+ <$> request_headers request } redactBugsnagRequestHeaders- :: [HeaderName] -> HashMap Text Text -> HashMap Text Text+ :: [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+ 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
@@ -1,6 +1,6 @@ module Network.Bugsnag.WaiSpec- ( spec- ) where+ ( spec+ ) where import Prelude @@ -12,39 +12,45 @@ import Test.Hspec data TestException = TestException- deriving stock Show- deriving anyclass Exception.Exception+ deriving stock (Show)+ deriving anyclass (Exception.Exception) spec :: Spec spec = do- describe "redactRequestHeaders" $ do- it "redacts the given headers" $ do- let bn = redactRequestHeaders ["Authorization"]+ 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")]- }- }+ 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 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"+ lookupEventRequestHeader "Authorization" event+ `shouldBe` Just "<redacted>"+ lookupEventRequestHeader "X-Foo" event `shouldBe` Just "Bar" - describe "readForwardedFor" $ do- it "handles empty" $ do- readForwardedFor "" `shouldBe` Nothing+ 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 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"+ it "reads the first of many values" $ do+ readForwardedFor "123.123.123, 45.45.45"+ `shouldBe` Just "123.123.123"
test/Spec.hs view
@@ -1,2 +1,2 @@-{-# OPTIONS_GHC -Wno-missing-export-lists #-} {-# OPTIONS_GHC -F -pgmF hspec-discover #-}+{-# OPTIONS_GHC -Wno-missing-export-lists #-}