diff --git a/bugsnag-haskell.cabal b/bugsnag-haskell.cabal --- a/bugsnag-haskell.cabal +++ b/bugsnag-haskell.cabal @@ -1,13 +1,13 @@ cabal-version: 1.18 --- This file has been generated from package.yaml by hpack version 0.31.0. +-- This file has been generated from package.yaml by hpack version 0.31.2. -- -- see: https://github.com/sol/hpack -- --- hash: 5358213d15bc36742a81c0406bbf708c01be7b9579ab67a42049f7e25cd4a77f +-- hash: a71bc66ddcfe6442810073ecaf19f31bea964f76eced2a28882753d54c829618 name: bugsnag-haskell -version: 0.0.3.0 +version: 0.0.3.1 synopsis: Bugsnag error reporter for Haskell description: Please see README.md category: Web @@ -29,29 +29,6 @@ default: False library - hs-source-dirs: - src - ghc-options: -Wall - build-depends: - Glob >=0.9.0 - , aeson >=1.3.0.0 - , base >=4.8.0 && <5 - , bytestring - , case-insensitive - , containers - , http-client - , http-client-tls - , http-conduit - , http-types - , iproute - , network - , parsec - , template-haskell - , text - , th-lift-instances - , time - , ua-parser - , wai exposed-modules: Data.Aeson.Ext Network.Bugsnag @@ -77,59 +54,84 @@ Network.Bugsnag.User other-modules: Paths_bugsnag_haskell + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + Glob >=0.9.0 + , aeson >=1.3.0.0 + , base >=4.11.0 && <5 + , bytestring + , case-insensitive + , containers + , http-client + , http-client-tls + , http-conduit + , http-types + , iproute + , network + , parsec + , template-haskell + , text + , th-lift-instances + , time + , ua-parser + , wai default-language: Haskell2010 executable example-cli main-is: Main.hs + other-modules: + Paths_bugsnag_haskell hs-source-dirs: examples/cli ghc-options: -Wall build-depends: - base >=4.8.0 && <5 + base >=4.11.0 && <5 , bugsnag-haskell if !(flag(examples)) buildable: False - other-modules: - Paths_bugsnag_haskell default-language: Haskell2010 executable example-simple main-is: Main.hs + other-modules: + Paths_bugsnag_haskell hs-source-dirs: examples/simple ghc-options: -Wall build-depends: - base >=4.8.0 && <5 + base >=4.11.0 && <5 , bugsnag-haskell if !(flag(examples)) buildable: False - other-modules: - Paths_bugsnag_haskell default-language: Haskell2010 executable example-warp main-is: Main.hs + other-modules: + Paths_bugsnag_haskell hs-source-dirs: examples/warp ghc-options: -Wall build-depends: - base >=4.8.0 && <5 + base >=4.11.0 && <5 , bugsnag-haskell , wai , warp if !(flag(examples)) buildable: False - other-modules: - Paths_bugsnag_haskell default-language: Haskell2010 executable example-yesod main-is: Main.hs + other-modules: + Paths_bugsnag_haskell hs-source-dirs: examples/yesod ghc-options: -Wall build-depends: - base >=4.8.0 && <5 + base >=4.11.0 && <5 , bugsnag-haskell , exceptions , unliftio @@ -138,41 +140,39 @@ , yesod-core if !(flag(examples)) buildable: False - other-modules: - Paths_bugsnag_haskell default-language: Haskell2010 test-suite doctest type: exitcode-stdio-1.0 main-is: DocTest.hs + other-modules: + Paths_bugsnag_haskell hs-source-dirs: ./. ghc-options: -Wall -Wall build-depends: - base >=4.8.0 && <5 + base >=4.11.0 && <5 , doctest - other-modules: - Paths_bugsnag_haskell default-language: Haskell2010 test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs + other-modules: + Network.Bugsnag.CodeIndexSpec + Network.Bugsnag.ReportSpec + Network.BugsnagSpec + Paths_bugsnag_haskell hs-source-dirs: test ghc-options: -Wall build-depends: aeson , aeson-qq - , base >=4.8.0 && <5 + , base >=4.11.0 && <5 , bugsnag-haskell , hspec , text , time , unliftio - other-modules: - Network.Bugsnag.CodeIndexSpec - Network.Bugsnag.ReportSpec - Network.BugsnagSpec - Paths_bugsnag_haskell default-language: Haskell2010 diff --git a/src/Network/Bugsnag/Exception.hs b/src/Network/Bugsnag/Exception.hs --- a/src/Network/Bugsnag/Exception.hs +++ b/src/Network/Bugsnag/Exception.hs @@ -73,34 +73,19 @@ -- ("IOException",Just "user error (Oops)") -- bugsnagExceptionFromSomeException :: SomeException -> BugsnagException -bugsnagExceptionFromSomeException ex = - foldr go (bugsnagExceptionWithParser parseStringException ex) exCasters - where +bugsnagExceptionFromSomeException ex = foldr go seed exCasters + where go :: Caster -> BugsnagException -> BugsnagException go (Caster caster) res = maybe res caster $ fromException ex + seed = (bugsnagExceptionWithParser parseStringException ex) + { beErrorClass = (\(SomeException e) -> exErrorClass e) ex + } + exCasters :: [Caster] exCasters = [ Caster id , Caster $ bugsnagExceptionWithParser parseErrorCall - , Caster $ bugsnagExceptionFromException @IOException - , Caster $ bugsnagExceptionFromException @ArithException - , Caster $ bugsnagExceptionFromException @ArrayException - , Caster $ bugsnagExceptionFromException @AssertionFailed - , Caster $ bugsnagExceptionFromException @SomeAsyncException - , Caster $ bugsnagExceptionFromException @AsyncException - , Caster $ bugsnagExceptionFromException @NonTermination - , Caster $ bugsnagExceptionFromException @NestedAtomically - , Caster $ bugsnagExceptionFromException @BlockedIndefinitelyOnMVar - , Caster $ bugsnagExceptionFromException @BlockedIndefinitelyOnSTM - , Caster $ bugsnagExceptionFromException @AllocationLimitExceeded - , Caster $ bugsnagExceptionFromException @Deadlock - , Caster $ bugsnagExceptionFromException @NoMethodError - , Caster $ bugsnagExceptionFromException @PatternMatchFail - , Caster $ bugsnagExceptionFromException @RecConError - , Caster $ bugsnagExceptionFromException @RecSelError - , Caster $ bugsnagExceptionFromException @RecUpdError - , Caster $ bugsnagExceptionFromException @TypeError ] bugsnagExceptionWithParser diff --git a/src/Network/Bugsnag/Request.hs b/src/Network/Bugsnag/Request.hs --- a/src/Network/Bugsnag/Request.hs +++ b/src/Network/Bugsnag/Request.hs @@ -1,10 +1,12 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} module Network.Bugsnag.Request ( BugsnagRequest(..) , bugsnagRequest , bugsnagRequestFromWaiRequest - ) where + ) +where import Control.Applicative ((<|>)) import Data.Aeson @@ -13,7 +15,6 @@ import qualified Data.ByteString.Char8 as C8 import Data.IP import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) import GHC.Generics import Network.HTTP.Types import Network.Socket @@ -55,12 +56,12 @@ } requestRealIp :: Request -> Maybe ByteString -requestRealIp request = requestForwardedFor request - <|> lookup "X-Real-IP" (requestHeaders request) +requestRealIp request = + requestForwardedFor request <|> lookup "X-Real-IP" (requestHeaders request) requestForwardedFor :: Request -> Maybe ByteString -requestForwardedFor request = readForwardedFor - =<< lookup "X-Forwarded-For" (requestHeaders request) +requestForwardedFor request = + readForwardedFor =<< lookup "X-Forwarded-For" (requestHeaders request) -- | -- @@ -79,23 +80,24 @@ | otherwise = Just $ fst $ C8.break (== ',') bs requestUrl :: Request -> ByteString -requestUrl request = requestProtocol - <> "://" - <> requestHost request - <> rawPathInfo request - <> rawQueryString request +requestUrl request = + requestProtocol + <> "://" + <> requestHost request + <> rawPathInfo request + <> rawQueryString request where clientProtocol = if isSecure request then "https" else "http" requestHost = fromMaybe "" . requestHeaderHost - requestProtocol = fromMaybe clientProtocol - $ lookup "X-Forwarded-Proto" - $ requestHeaders request + requestProtocol = + fromMaybe clientProtocol $ lookup "X-Forwarded-Proto" $ requestHeaders + request sockAddrToIp :: SockAddr -> ByteString sockAddrToIp (SockAddrInet _ h) = C8.pack $ show $ fromHostAddress h sockAddrToIp (SockAddrInet6 _ _ h _) = C8.pack $ show $ fromHostAddress6 h sockAddrToIp (SockAddrUnix _) = "" --- N.B. Can't match deprecated SockAddrCan without warning. TODO: make patterns --- exhaustive without a wildcard once it's actually removed. +-- Matches deprecated and eventually removed SockAddrCan on older GHCs. +-- overlapping-patterns warning is disabled for this. sockAddrToIp _ = "" diff --git a/test/Network/BugsnagSpec.hs b/test/Network/BugsnagSpec.hs --- a/test/Network/BugsnagSpec.hs +++ b/test/Network/BugsnagSpec.hs @@ -78,7 +78,7 @@ e <- brokenFunction' `catch` pure let ex = bugsnagExceptionFromSomeException e - beErrorClass ex `shouldBe` "SomeException" + beErrorClass ex `shouldBe` "StringException" beMessage ex `shouldBe` Just "empty list" beStacktrace ex `shouldSatisfy` ((== 3) . length) @@ -95,7 +95,7 @@ e <- brokenFunction'' `catch` pure let ex = bugsnagExceptionFromSomeException e - beErrorClass ex `shouldBe` "SomeException" + beErrorClass ex `shouldBe` "StringException" beMessage ex `shouldBe` Just "empty list\n and message with newlines\n\n" beStacktrace ex `shouldSatisfy` ((== 3) . length)