bugsnag 1.2.0.2 → 1.2.0.3

raw patch · 7 files changed

+253/−136 lines, 7 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +12/−1
• bugsnag.cabal +1/−1
• src/Network/Bugsnag/Exception.hs +88/−86
• src/Network/Bugsnag/Exception/Context.hs +29/−13
• src/Network/Bugsnag/Exception/Parse.hs +19/−25
• test/Examples.hs +35/−1
• test/Network/Bugsnag/ExceptionSpec.hs +69/−9

@@ -1,4 +1,15 @@-## [_Unreleased_](https://github.com/pbrisbin/bugsnag-haskell/compare/bugsnag-v1.1.0.1...main)+## [v1.2.0.0](https://github.com/pbrisbin/bugsnag-haskell/compare/bugsnag-v1.1.0.1...bugsnag-v1.2.0.0)++- Fixes stack traces in cases where multiple call stacks are present in the+  exception context.++- When a trace is present in both an exception and its context/annotation (e.g.+  `AnnotatedException StringException`), the "innermost" trace from the exception is now used+  rather than the wrapper.++- Removed `Network.Bugsnag.Exception.Parse.parseExceptionWithContext` and the+  `Network.Bugsnag.Exception.Context` module's `ExceptionWithContext` and+  `displayExceptionWithContext`.  ## [v1.1.0.1](https://github.com/pbrisbin/bugsnag-haskell/compare/bugsnag-v1.1.0.0...bugsnag-v1.1.0.1) 

@@ -1,6 +1,6 @@ cabal-version:      1.18 name:               bugsnag-version:            1.2.0.2+version:            1.2.0.3 license:            MIT license-file:       LICENSE maintainer:         pbrisbin@gmail.com

@@ -9,7 +9,8 @@ import Prelude  import Control.Exception-  ( SomeException (SomeException)+  ( ErrorCall+  , SomeException (SomeException)   , displayException   , fromException   )@@ -21,11 +22,12 @@ import qualified Control.Exception.Annotated as Annotated import Data.Bugsnag import Data.Foldable (asum)+import Data.Function ((&)) import Data.Maybe (fromMaybe)-import Data.Text (Text) import qualified Data.Text as T-import Data.Typeable (Proxy (..), Typeable, typeRep)+import Data.Typeable (typeRep) import GHC.Stack (CallStack, SrcLoc (..), getCallStack)+import qualified Network.Bugsnag.Exception.Context as Context import Network.Bugsnag.Exception.Parse import UnliftIO.Exception (StringException (StringException)) @@ -37,98 +39,98 @@   deriving anyclass (Exception.Exception)  -- | Construct a 'Exception' from a 'SomeException'+--+-- It is possible that an exception contains multiple sources of messages and stack traces. The general+-- principles for selection are:+--+--  * When exception wrappers/context are present, prefer information from the innermost exception+--  * Prefer features from more standard and commonly-used libraries bugsnagExceptionFromSomeException :: SomeException -> Exception bugsnagExceptionFromSomeException ex =-  fromMaybe defaultException $-    asum-      [ bugsnagExceptionFromAnnotatedAsException <$> fromException ex-      , bugsnagExceptionFromStringException <$> fromException ex-      , bugsnagExceptionFromAnnotatedStringException <$> fromException ex-      , bugsnagExceptionFromAnnotatedException <$> fromException ex-      ]---- | Respect 'AsException' as-is without modifications.---   If it's wrapped in 'AnnotatedException', ignore the annotations.-bugsnagExceptionFromAnnotatedAsException-  :: AnnotatedException AsException -> Exception-bugsnagExceptionFromAnnotatedAsException = unAsException . Annotated.exception+  bugsnagExceptionFromAsException ex+    & fromMaybe+      ( asum+          [ bugsnagExceptionFromErrorCall ex+          , bugsnagExceptionFromStringException ex+          , bugsnagExceptionFromSomeExceptionResemblingStringException ex+          ]+          & fromMaybe (unrecognized ex)+          & ( \be -> case exception_stacktrace be of+                [] -> case findTraceAnnotation ex of+                  Nothing -> be+                  Just frames -> be {exception_stacktrace = frames}+                _ -> be+            )+      ) --- | When a 'StringException' is thrown, we use its message and trace.-bugsnagExceptionFromStringException :: StringException -> Exception-bugsnagExceptionFromStringException (StringException message stack) =-  (mkException $ Just $ T.pack message)-    { exception_errorClass = typeName @StringException-    , exception_stacktrace = callStackToStackFrames stack-    }+-- | Respect 'AsException' as-is without modifications+--+-- If it's wrapped in 'AnnotatedException', ignore the annotations.+bugsnagExceptionFromAsException :: SomeException -> Maybe Exception+bugsnagExceptionFromAsException ex = do+  AnnotatedException {exception = AsException bugsnagException} <-+    fromException @(AnnotatedException AsException) ex+  pure bugsnagException --- | When 'StringException' is wrapped in 'AnnotatedException',---   there are two possible sources of a 'CallStack'.---   Prefer the one from 'AnnotatedException', falling back to the---   'StringException' trace if no 'CallStack' annotation is present.-bugsnagExceptionFromAnnotatedStringException-  :: AnnotatedException StringException -> Exception-bugsnagExceptionFromAnnotatedStringException ae@AnnotatedException {exception = StringException message stringExceptionStack} =-  (mkException $ Just $ T.pack message)-    { exception_errorClass = typeName @StringException-    , exception_stacktrace =-        maybe-          (callStackToStackFrames stringExceptionStack)-          callStackToStackFrames-          $ annotatedExceptionCallStack ae-    }+findTraceAnnotation :: SomeException -> Maybe [StackFrame]+findTraceAnnotation ex =+  asum+    [ Context.backtraceStackFrames ex+    , do+        ae <- fromException @(AnnotatedException SomeException) ex+        stack <- annotatedExceptionCallStack ae+        pure $ callStackToStackFrames stack+    ] --- | For an 'AnnotatedException' exception, derive the error class and message---   from the wrapped exception.---   If a 'CallStack' annotation is present, use that as the stacetrace.---   Otherwise, attempt to parse a trace from the underlying exception.-bugsnagExceptionFromAnnotatedException-  :: AnnotatedException SomeException -> Exception-bugsnagExceptionFromAnnotatedException ae =-  case annotatedExceptionCallStack ae of-    Just stack ->-      (mkException $ Just $ T.pack $ displayException $ Annotated.exception ae)-        { exception_errorClass = exErrorClass $ Annotated.exception ae-        , exception_stacktrace = callStackToStackFrames stack-        }-    Nothing ->-      let-        parseResult =-          asum-            [ fromException (Annotated.exception ae)-                >>= (either (const Nothing) Just . parseExceptionWithContext)-            , fromException (Annotated.exception ae)-                >>= (either (const Nothing) Just . parseErrorCall)-            , either (const Nothing) Just $-                parseStringException (Annotated.exception ae)-            ]+-- | When a 'StringException' is thrown, we use its message and trace.+bugsnagExceptionFromStringException :: SomeException -> Maybe Exception+bugsnagExceptionFromStringException ex = do+  AnnotatedException {exception = stringException@(StringException message stack)} <-+    fromException @(AnnotatedException StringException) ex+  pure+    defaultException+      { exception_errorClass = T.pack $ show $ typeRep $ Just stringException+      , exception_message = Just $ T.dropWhileEnd (== '\n') $ T.pack message+      , exception_stacktrace = callStackToStackFrames stack+      } -        mmessage =-          asum-            [ mwsfMessage <$> parseResult-            , Just $-                T.pack $-                  displayException $-                    Annotated.exception-                      ae-            ]-      in-        (mkException mmessage)-          { exception_errorClass = exErrorClass $ Annotated.exception ae-          , exception_stacktrace = foldMap mwsfStackFrames parseResult-          }+bugsnagExceptionFromErrorCall :: SomeException -> Maybe Exception+bugsnagExceptionFromErrorCall ex = do+  AnnotatedException {exception = errorCall} <-+    fromException @(AnnotatedException ErrorCall) ex+  messageWithStackFrames <- either (const Nothing) Just $ parseErrorCall errorCall+  pure+    defaultException+      { exception_errorClass = T.pack $ show $ typeRep $ Just errorCall+      , exception_message =+          Just $ T.dropWhileEnd (== '\n') $ mwsfMessage messageWithStackFrames+      , exception_stacktrace = mwsfStackFrames messageWithStackFrames+      }+bugsnagExceptionFromSomeExceptionResemblingStringException+  :: SomeException -> Maybe Exception+bugsnagExceptionFromSomeExceptionResemblingStringException ex = do+  AnnotatedException {exception = wrappedException} <-+    fromException @(AnnotatedException SomeException) ex+  messageWithStackFrames <-+    either (const Nothing) pure $ parseStringException wrappedException+  pure+    defaultException+      { exception_errorClass = "StringException"+      , exception_message =+          Just $ T.dropWhileEnd (== '\n') $ mwsfMessage messageWithStackFrames+      , exception_stacktrace = mwsfStackFrames messageWithStackFrames+      } -mkException :: Maybe Text -> Exception-mkException mmsg =+unrecognized :: SomeException -> Exception+unrecognized ex =   defaultException-    { exception_message = T.dropWhileEnd (== '\n') <$> mmsg+    { exception_errorClass = case fromException @(AnnotatedException SomeException) ex of+        Just (AnnotatedException {exception = SomeException e}) -> T.pack $ show $ typeRep $ Just e+        Nothing -> T.pack $ show $ typeRep $ Just ex+    , exception_message =+        Just $ T.dropWhileEnd (== '\n') $ T.pack $ displayException ex+    , exception_stacktrace = []     }---- | Unwrap the 'SomeException' newtype to get the actual underlying type name-exErrorClass :: SomeException -> Text-exErrorClass (SomeException (_ :: e)) = typeName @e--typeName :: forall a. Typeable a => Text-typeName = T.pack $ show $ typeRep $ Proxy @a  -- | Converts a GHC call stack to a list of stack frames suitable --   for use as the stacktrace in a Bugsnag exception

@@ -1,25 +1,41 @@ {-# LANGUAGE CPP #-}  module Network.Bugsnag.Exception.Context-  ( ExceptionWithContext-  , displayExceptionWithContext+  ( backtraceStackFrames   ) where  import Prelude -#if MIN_VERSION_base(4,20,0)-import Control.Exception (Exception, ExceptionWithContext(..), displayException)-import Control.Exception.Context ( displayExceptionContext)+import Data.Bugsnag hiding (Exception) -displayExceptionWithContext :: Exception e => ExceptionWithContext e -> String-displayExceptionWithContext (ExceptionWithContext anns e) =-  displayException e <> "\n" <> displayExceptionContext anns+#if MIN_VERSION_base(4,20,0)+import Control.Exception (SomeException, someExceptionContext)+import Control.Exception.Backtrace (Backtraces, displayBacktraces)+import Control.Exception.Context (getExceptionAnnotations)+import Control.Monad (guard)+import Data.Foldable (toList)+import Data.List.NonEmpty (nonEmpty)+import qualified Data.List.NonEmpty as NE+import Network.Bugsnag.Exception.Parse (backtraceParser)+import Text.Parsec (parse) #else-import Control.Exception (Exception, displayException)+import Control.Exception (SomeException)+#endif -newtype ExceptionWithContext e = ExceptionWithContext e-  deriving newtype (Eq, Show, Exception)+-- | Stack frames from an exception's attached 'Backtraces', if any+backtraceStackFrames :: SomeException -> Maybe [StackFrame] -displayExceptionWithContext :: Exception e => ExceptionWithContext e -> String-displayExceptionWithContext (ExceptionWithContext ex) = displayException ex+#if MIN_VERSION_base(4,20,0)+backtraceStackFrames ex = fmap NE.last $ nonEmpty $ do+  backtrace <- getExceptionAnnotations @Backtraces (someExceptionContext ex)+  toList @Maybe $ do+    let+      frames =+        either (const []) id $+          parse backtraceParser "" $+            displayBacktraces backtrace+    guard $ not $ null frames+    pure frames+#else+backtraceStackFrames = const Nothing #endif

@@ -4,8 +4,8 @@ module Network.Bugsnag.Exception.Parse   ( MessageWithStackFrames (..)   , parseErrorCall-  , parseExceptionWithContext   , parseStringException+  , backtraceParser   ) where  import Prelude@@ -15,7 +15,6 @@ import Data.Bifunctor (first) import Data.Bugsnag import Data.Text (Text, pack)-import qualified Network.Bugsnag.Exception.Context as Exception import Text.Parsec import Text.Parsec.String @@ -24,27 +23,19 @@   , mwsfStackFrames :: [StackFrame]   } --- | Parse an @'ErrorCall'@ for @'HasCallStack'@ information+-- | Parse an 'ErrorCall' for 'HasCallStack' information parseErrorCall :: Exception.ErrorCall -> Either String MessageWithStackFrames parseErrorCall = parse' errorCallParser . show -parseExceptionWithContext-  :: Exception.ExceptionWithContext Exception.SomeException-  -> Either String MessageWithStackFrames-parseExceptionWithContext =-  parse' backtraceParser . Exception.displayExceptionWithContext---- | Parse a @'StringException'@ for @'HasCallStack'@ information+-- | Parse a 'StringException' for 'HasCallStack' information ----- We accept this as @'SomeException'@ so that this library doesn't depend on--- any one concrete library that has @'throwString'@ (there are two right now,+-- We accept this as 'SomeException' so that this library doesn't depend on+-- any one concrete library that has 'throwString' (there are two right now, -- sigh.) parseStringException   :: Exception.SomeException -> Either String MessageWithStackFrames parseStringException = parse' stringExceptionParser . show --- brittany-disable-next-binding- errorCallParser :: Parser MessageWithStackFrames errorCallParser =   MessageWithStackFrames@@ -56,16 +47,21 @@     msg <- pack <$> manyTill anyChar eol     msg <$ (string "CallStack (from HasCallStack):" *> eol) -backtraceParser :: Parser MessageWithStackFrames+-- | Parse the @HasCallStack backtrace:@ section of a rendered+--   'Control.Exception.Backtrace.Backtraces', ignoring any other backtrace+--   mechanism's section also present+--+-- Every section header (e.g. @Native stack backtrace:@) is rendered+-- unindented, while every call site line within a section is indented by two+-- spaces. So, having found the @HasCallStack backtrace:@ header, we stop as+-- soon as we reach a line that isn't indented (or the end of the input),+-- which keeps us from parsing into a following section regardless of where+-- this section falls in the render order.+backtraceParser :: Parser [StackFrame] backtraceParser =-  MessageWithStackFrames-    <$> messageParser-    <*> manyTill hasCallStackStackFrameParser eof- where-  messageParser :: Parser Text-  messageParser = do-    msg <- pack <$> manyTill anyChar eol-    msg <$ (string "HasCallStack backtrace:" *> eol)+  option [] $ do+    _ <- try $ manyTill anyChar $ try $ string "HasCallStack backtrace:" *> eol+    manyTill hasCallStackStackFrameParser $ notFollowedBy $ char ' '  hasCallStackStackFrameParser :: Parser StackFrame hasCallStackStackFrameParser = do@@ -81,8 +77,6 @@       , stackFrame_inProject = Just True       , stackFrame_code = Nothing       }---- brittany-disable-next-binding  stringExceptionParser :: Parser MessageWithStackFrames stringExceptionParser =

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-missing-export-lists #-} @@ -12,12 +13,16 @@  import Control.Exception import Control.Exception.Annotated (checkpointCallStack)-import Data.Bugsnag+import Data.Bugsnag hiding (Exception) import GHC.Stack (HasCallStack) import Network.Bugsnag.Exception import Network.Bugsnag.StackFrame import UnliftIO.Exception (throwString) +#if MIN_VERSION_base(4,20,0)+import Control.Exception.Backtrace (collectBacktraces)+#endif+ brokenFunctionIO :: IO a brokenFunctionIO =   throw $@@ -51,3 +56,32 @@  brokenFunctionAnnotated :: HasCallStack => IO a brokenFunctionAnnotated = checkpointCallStack $ sillyHead' []++-- | An exception type distinct from any other used in this test suite,+--   so that tests can assert on its type name specifically+data Whatever = Whatever+  deriving stock (Show)+  deriving anyclass (Exception)++#if MIN_VERSION_base(4,20,0)+data Boom = Boom deriving stock (Show)+instance Exception Boom++-- | Throws with only base's native (automatic, per-throw) backtrace+-- collection attached -- no @annotated-exception@ involved+brokenFunctionBacktrace :: HasCallStack => IO a+brokenFunctionBacktrace = sillyHeadBacktrace []++sillyHeadBacktrace :: HasCallStack => [a] -> IO a+sillyHeadBacktrace (_ : _) = error "unreachable"+sillyHeadBacktrace [] = throwIO Boom++-- | Like 'brokenFunctionBacktrace', but with a second 'Control.Exception.Backtrace.Backtraces'+-- annotation attached on top, simulating an application-level checkpoint+-- (e.g. @Control.Exception.Annotated.checkpointCallStack@-style, but built on+-- base's native mechanism instead) re-collecting one further up+brokenFunctionBacktraceCheckpointed :: IO a+brokenFunctionBacktraceCheckpointed = do+  bt <- collectBacktraces+  annotateIO bt brokenFunctionBacktrace+#endif

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  module Network.Bugsnag.ExceptionSpec@@ -7,6 +8,7 @@ import Prelude  import Control.Exception+import Control.Exception.Annotated (AnnotatedException (..)) import Data.Bugsnag import Examples import Network.Bugsnag.Exception@@ -24,7 +26,7 @@        let (frame : _) = exception_stacktrace ex       stackFrame_file frame `shouldBe` "test/Examples.hs"-      stackFrame_lineNumber frame `shouldBe` 28+      stackFrame_lineNumber frame `shouldBe` 33       -- different versions of GHC disagree on where splices start       stackFrame_columnNumber frame         `shouldSatisfy` (`elem` [Just 36, Just 37])@@ -41,6 +43,19 @@       exception_errorClass ex `shouldBe` "IOException"       exception_message ex `shouldBe` Just "user error (Oops)" +    it "sets errorClass to the name of the exception type" $ do+      let ex = bugsnagExceptionFromSomeException $ toException Whatever++      exception_errorClass ex `shouldBe` "Whatever"++    it "unwraps AnnotatedException, setting errorClass to the wrapped type" $ do+      let ex =+            bugsnagExceptionFromSomeException $+              toException $+                AnnotatedException [] Whatever++      exception_errorClass ex `shouldBe` "Whatever"+     it "can parse errors with callstacks" $ do       e <- evaluate brokenFunction `catch` pure @@ -51,7 +66,7 @@        let (frame : _) = exception_stacktrace ex       stackFrame_file frame `shouldBe` "test/Examples.hs"-      stackFrame_lineNumber frame `shouldBe` 36+      stackFrame_lineNumber frame `shouldBe` 41       stackFrame_columnNumber frame `shouldBe` Just 15       stackFrame_method frame `shouldBe` "error" @@ -68,7 +83,7 @@        let (frame : _) = exception_stacktrace ex       stackFrame_file frame `shouldBe` "test/Examples.hs"-      stackFrame_lineNumber frame `shouldBe` 43+      stackFrame_lineNumber frame `shouldBe` 48       stackFrame_columnNumber frame `shouldBe` Just 16       stackFrame_method frame `shouldBe` "throwString" @@ -86,7 +101,7 @@        let (frame : _) = exception_stacktrace ex       stackFrame_file frame `shouldBe` "test/Examples.hs"-      stackFrame_lineNumber frame `shouldBe` 50+      stackFrame_lineNumber frame `shouldBe` 55       stackFrame_columnNumber frame `shouldBe` Just 17       stackFrame_method frame `shouldBe` "throwString" @@ -102,15 +117,60 @@       let ex = bugsnagExceptionFromSomeException e       exception_errorClass ex `shouldBe` "StringException"       exception_message ex `shouldBe` Just "empty list"-      exception_stacktrace ex `shouldSatisfy` ((== 2) . length)+      exception_stacktrace ex `shouldSatisfy` ((== 3) . length)        let (frame : _) = exception_stacktrace ex       stackFrame_file frame `shouldBe` "test/Examples.hs"-      stackFrame_lineNumber frame `shouldBe` 53-      stackFrame_columnNumber frame `shouldBe` Just 27-      stackFrame_method frame `shouldBe` "checkpointCallStack"+      stackFrame_lineNumber frame `shouldBe` 48+      stackFrame_columnNumber frame `shouldBe` Just 16+      stackFrame_method frame `shouldBe` "throwString"        map stackFrame_method (exception_stacktrace ex)-        `shouldBe` [ "checkpointCallStack"+        `shouldBe` [ "throwString"+                   , "sillyHead'"                    , "brokenFunctionAnnotated"                    ]++#if MIN_VERSION_base(4,20,0)+    it "extracts a trace from base's native ExceptionContext (a single Backtraces annotation)" $ do+      e <- brokenFunctionBacktrace `catch` pure++      let ex = bugsnagExceptionFromSomeException e+      exception_errorClass ex `shouldBe` "Boom"+      exception_stacktrace ex `shouldSatisfy` ((>= 3) . length)++      -- The leading frames are GHC's own internal backtrace-collection+      -- machinery, which varies across GHC versions; only our own code's+      -- frames (the tail) are asserted on exactly.+      let ourFrames = ourExampleFrames (exception_stacktrace ex)+      map stackFrame_method ourFrames+        `shouldBe` ["throwIO", "sillyHeadBacktrace", "brokenFunctionBacktrace"]++      let (lastFrame : _) = reverse ourFrames+      stackFrame_file lastFrame `shouldBe` "test/Network/Bugsnag/ExceptionSpec.hs"+      stackFrame_lineNumber lastFrame `shouldBe` 136++    it "prefers the earliest attached Backtraces when more than one is present" $ do+      e <- brokenFunctionBacktraceCheckpointed `catch` pure++      let ex = bugsnagExceptionFromSomeException e+      exception_errorClass ex `shouldBe` "Boom"++      let ourFrames = ourExampleFrames (exception_stacktrace ex)+      map stackFrame_method ourFrames+        `shouldBe` ["throwIO", "sillyHeadBacktrace", "brokenFunctionBacktrace"]++      -- The last frame is the call to brokenFunctionBacktrace from *inside*+      -- brokenFunctionBacktraceCheckpointed (in Examples.hs) -- i.e. the+      -- original/earliest-attached annotation -- not the checkpoint's own+      -- separate, later-attached one (which would show only its own single+      -- call site instead).+      let (lastFrame : _) = reverse ourFrames+      stackFrame_file lastFrame `shouldBe` "test/Examples.hs"+      stackFrame_lineNumber lastFrame `shouldBe` 86++-- | The last three frames of a stack trace, i.e. our own test code, ignoring+-- any leading frames from GHC's own internal backtrace-collection machinery+ourExampleFrames :: [StackFrame] -> [StackFrame]+ourExampleFrames frames = drop (length frames - 3) frames+#endif