summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPatrickBrisbin <>2020-02-13 18:55:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2020-02-13 18:55:00 (GMT)
commite9e2cfd0248160cfc652093dfcd42d2de31b6a21 (patch)
tree574595445e03f7f54b516173383083229f8f32eb
parent18ba5e737f11b9fec4c03cc795f5ec6eceebd58d (diff)
version 0.0.3.1HEAD0.0.3.1master
-rw-r--r--bugsnag-haskell.cabal94
-rw-r--r--src/Network/Bugsnag/Exception.hs27
-rw-r--r--src/Network/Bugsnag/Request.hs34
-rw-r--r--test/Network/BugsnagSpec.hs4
4 files changed, 73 insertions, 86 deletions
diff --git a/bugsnag-haskell.cabal b/bugsnag-haskell.cabal
index da8cad6..62c3767 100644
--- 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 @@ flag examples
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 @@ library
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 @@ executable example-yesod
, 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
index 1d3d72d..3c2207b 100644
--- a/src/Network/Bugsnag/Exception.hs
+++ b/src/Network/Bugsnag/Exception.hs
@@ -73,34 +73,19 @@ bugsnagException errorClass message stacktrace = BugsnagException
-- ("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
index 6e25d84..37d4667 100644
--- 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 Data.ByteString (ByteString)
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 @@ bugsnagRequestFromWaiRequest request = bugsnagRequest
}
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 @@ readForwardedFor bs
| 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 "<unknown>" . 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 _) = "<socket>"
--- 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 _ = "<invalid>"
diff --git a/test/Network/BugsnagSpec.hs b/test/Network/BugsnagSpec.hs
index 21160db..59de9ba 100644
--- a/test/Network/BugsnagSpec.hs
+++ b/test/Network/BugsnagSpec.hs
@@ -78,7 +78,7 @@ spec = do
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 @@ spec = do
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)