diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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) diff --git a/bugsnag.cabal b/bugsnag.cabal --- a/bugsnag.cabal +++ b/bugsnag.cabal @@ -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 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 @@ -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 diff --git a/src/Network/Bugsnag/Exception/Context.hs b/src/Network/Bugsnag/Exception/Context.hs --- a/src/Network/Bugsnag/Exception/Context.hs +++ b/src/Network/Bugsnag/Exception/Context.hs @@ -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 diff --git a/src/Network/Bugsnag/Exception/Parse.hs b/src/Network/Bugsnag/Exception/Parse.hs --- a/src/Network/Bugsnag/Exception/Parse.hs +++ b/src/Network/Bugsnag/Exception/Parse.hs @@ -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 = diff --git a/test/Examples.hs b/test/Examples.hs --- a/test/Examples.hs +++ b/test/Examples.hs @@ -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 diff --git a/test/Network/Bugsnag/ExceptionSpec.hs b/test/Network/Bugsnag/ExceptionSpec.hs --- a/test/Network/Bugsnag/ExceptionSpec.hs +++ b/test/Network/Bugsnag/ExceptionSpec.hs @@ -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