Support annotated-exception (#82)

pbrisbin · Dec 11, 2023 · 02283d8 · 02283d8
1 parent d61e405
commit 02283d8
Show file tree

Hide file tree

Showing 10 changed files with 398 additions and 108 deletions.
diff --git a/bugsnag/CHANGELOG.md b/bugsnag/CHANGELOG.md
@@ -1,7 +1,24 @@
-## [_Unreleased_](https://github.com/pbrisbin/bugsnag-haskell/compare/bugsnag-v1.0.0.1...main)
+## [_Unreleased_](https://github.com/pbrisbin/bugsnag-haskell/compare/bugsnag-v1.1.0.0...main)
 
 - None
 
+## [v1.0.1.0](https://github.com/pbrisbin/bugsnag-haskell/compare/bugsnag-v1.0.0.0...bugsnag-v1.1.0.0)
+
+- New module: `Network.Bugsnag.MetaData`
+
+- Adds some support for the `annotated-exception` package.
+  `updateEventFromOriginalException` now catches either `e` or `AnnotatedException e`.
+
+  - `bugsnagExceptionFromSomeException` now has special cases to handle
+    `AnnotatedException` well.
+  - Annotations of type `CallStack` and `MetaData` are included in the bugsnag
+    report; other annotations are ignored.
+
+- Adds explicit support for `StringException` from the `unliftio` package.
+
+  - `bugsnagExceptionFromSomeException` now has special cases to handle
+    `StringException` well.
+
 ## [v1.0.0.1](https://github.com/pbrisbin/bugsnag-haskell/compare/bugsnag-v1.0.0.0...bugsnag-v1.0.0.1)
 
 - Support GHCs 9.0 and 9.2

diff --git a/bugsnag/bugsnag.cabal b/bugsnag/bugsnag.cabal
@@ -5,7 +5,7 @@ cabal-version: 1.18
 -- see: https://github.com/sol/hpack
 
 name:           bugsnag
-version:        1.0.0.1
+version:        1.1.0.0
 synopsis:       Bugsnag error reporter for Haskell
 description:    Please see README.md
 category:       Web
@@ -36,10 +36,11 @@ library
       Network.Bugsnag.Device
       Network.Bugsnag.Exception
       Network.Bugsnag.Exception.Parse
+      Network.Bugsnag.MetaData
       Network.Bugsnag.Notify
       Network.Bugsnag.StackFrame
   other-modules:
-      Paths_bugsnag
+      Data.Aeson.Compat
   hs-source-dirs:
       src
   default-extensions:
@@ -69,6 +70,8 @@ library
       TypeFamilies
   build-depends:
       Glob >=0.9.0
+    , aeson
+    , annotated-exception
     , base >=4.11.0 && <5
     , bugsnag-hs
     , bytestring
@@ -80,6 +83,7 @@ library
     , text
     , th-lift-instances
     , ua-parser
+    , unliftio
     , unordered-containers
   default-language: Haskell2010
 
@@ -197,7 +201,8 @@ test-suite spec
       TypeApplications
       TypeFamilies
   build-depends:
-      base >=4.11.0 && <5
+      annotated-exception
+    , base >=4.11.0 && <5
     , bugsnag
     , hspec
     , unliftio

diff --git a/bugsnag/package.yaml b/bugsnag/package.yaml
@@ -1,5 +1,5 @@
 name: bugsnag
-version: 1.0.0.1
+version: 1.1.0.0
 synopsis: Bugsnag error reporter for Haskell
 description: Please see README.md
 homepage: https://github.com/pbrisbin/bugsnag-haskell#readme
@@ -46,8 +46,12 @@ default-extensions:
 
 library:
   source-dirs: src
+  other-modules:
+    - Data.Aeson.Compat
   dependencies:
     - Glob >= 0.9.0
+    - aeson
+    - annotated-exception
     - bugsnag-hs
     - bytestring
     - containers
@@ -58,6 +62,7 @@ library:
     - text
     - th-lift-instances
     - ua-parser
+    - unliftio
     - unordered-containers
 
 executables:
@@ -84,6 +89,7 @@ tests:
     main: Spec.hs
     source-dirs: test
     dependencies:
+      - annotated-exception
       - hspec
       - bugsnag
       - unliftio

diff --git a/bugsnag/src/Data/Aeson/Compat.hs b/bugsnag/src/Data/Aeson/Compat.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE CPP #-}
+
+module Data.Aeson.Compat
+  ( -- * Key
+    Key
+  , fromText
+  , toText
+
+    -- * KeyMap
+  , KeyMap
+  , empty
+  , null
+  , singleton
+  , fromList
+  , toList
+  , unionWith
+
+    -- * Etc.
+  , Pair
+  , Value (Object)
+  , Object
+  , object
+  , (.=)
+  ) where
+
+import Data.Aeson.Types (Object, Pair, Value (Object), object, (.=))
+#if MIN_VERSION_aeson(2, 0, 0)
+import Data.Aeson.Key (Key, fromText, toText)
+import Data.Aeson.KeyMap (KeyMap, empty, fromList, null, singleton, toList, unionWith)
+-- Avoid unused-packages (unordered-containers) warning for this path
+import Data.HashMap.Strict ()
+#else
+import Prelude (id)
+
+import Data.HashMap.Strict (HashMap, empty, fromList, null, singleton, toList, unionWith)
+import Data.Text (Text)
+
+type Key = Text
+type KeyMap = HashMap Text
+
+fromText :: Text -> Key
+fromText = id
+
+toText :: Key -> Text
+toText = id
+#endif
diff --git a/bugsnag/src/Network/Bugsnag/BeforeNotify.hs b/bugsnag/src/Network/Bugsnag/BeforeNotify.hs
@@ -29,6 +29,7 @@ module Network.Bugsnag.BeforeNotify
 import Prelude
 
 import qualified Control.Exception as Exception
+import qualified Control.Exception.Annotated as Annotated
 import Data.Bugsnag
 import Data.Maybe (isJust)
 import Data.Text (Text, unpack)
@@ -121,10 +122,15 @@ updateEvent f = beforeNotify $ \_e event -> f event
 -- @
 --
 -- If the cast fails, the event is unchanged.
+--
+-- The cast will match either @e@ or @'AnnotatedException' e@.
 updateEventFromOriginalException
   :: forall e. Exception.Exception e => (e -> BeforeNotify) -> BeforeNotify
 updateEventFromOriginalException f = beforeNotify $ \e event ->
-  let bn = maybe mempty f $ Exception.fromException $ Exception.toException e
+  let bn =
+        maybe mempty (f . Annotated.exception) $
+          Exception.fromException $
+            Exception.toException e
   in  runBeforeNotify bn e event
 
 setGroupingHash :: Text -> BeforeNotify

diff --git a/bugsnag/src/Network/Bugsnag/Exception.hs b/bugsnag/src/Network/Bugsnag/Exception.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE ExistentialQuantification #-}
 
 module Network.Bugsnag.Exception
@@ -7,16 +8,26 @@ module Network.Bugsnag.Exception
 
 import Prelude
 
-import Control.Exception hiding (Exception)
+import Control.Exception
+  ( SomeException (SomeException)
+  , displayException
+  , fromException
+  )
 import qualified Control.Exception as Exception
+import Control.Exception.Annotated
+  ( AnnotatedException (AnnotatedException)
+  , annotatedExceptionCallStack
+  )
+import qualified Control.Exception.Annotated as Annotated
 import Data.Bugsnag
 import Data.Foldable (asum)
 import Data.Maybe (fromMaybe)
-import Data.Proxy (Proxy (..))
-import Data.Text (Text, pack)
-import Data.Typeable (typeRep)
-import Instances.TH.Lift ()
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Typeable (Proxy (..), Typeable, typeRep)
+import GHC.Stack (CallStack, SrcLoc (..), getCallStack)
 import Network.Bugsnag.Exception.Parse
+import UnliftIO.Exception (StringException (StringException))
 
 -- | Newtype over 'Exception', so it can be thrown and caught
 newtype AsException = AsException
@@ -28,39 +39,102 @@ newtype AsException = AsException
 -- | Construct a 'Exception' from a 'SomeException'
 bugsnagExceptionFromSomeException :: SomeException -> Exception
 bugsnagExceptionFromSomeException ex =
-  fromMaybe fallback $
+  fromMaybe defaultException $
     asum
-      [ unAsException <$> fromException ex
-      , bugsnagExceptionWithParser parseErrorCall <$> fromException ex
+      [ bugsnagExceptionFromAnnotatedAsException <$> fromException ex
+      , bugsnagExceptionFromStringException <$> fromException ex
+      , bugsnagExceptionFromAnnotatedStringException <$> fromException ex
+      , bugsnagExceptionFromAnnotatedException <$> fromException ex
       ]
- where
-  fallback =
-    (bugsnagExceptionWithParser parseStringException ex)
-      { exception_errorClass = (\(SomeException e) -> exErrorClass e) ex
-      }
 
-bugsnagExceptionWithParser
-  :: Exception.Exception e
-  => (e -> Either String MessageWithStackFrames)
-  -> e
-  -> Exception
-bugsnagExceptionWithParser p ex = case p ex of
-  Left _ -> bugsnagExceptionFromException ex
-  Right (MessageWithStackFrames message stacktrace) ->
-    defaultException
-      { exception_errorClass = exErrorClass ex
-      , exception_message = Just message
-      , exception_stacktrace = stacktrace
-      }
+-- | Respect 'AsException' as-is without modifications.
+--   If it's wrapped in 'AnnotatedException', ignore the annotations.
+bugsnagExceptionFromAnnotatedAsException
+  :: AnnotatedException AsException -> Exception
+bugsnagExceptionFromAnnotatedAsException = unAsException . Annotated.exception
 
-bugsnagExceptionFromException :: Exception.Exception e => e -> Exception
-bugsnagExceptionFromException ex =
+-- | When a 'StringException' is thrown, we use its message and trace.
+bugsnagExceptionFromStringException :: StringException -> Exception
+bugsnagExceptionFromStringException (StringException message stack) =
   defaultException
-    { exception_errorClass = exErrorClass ex
-    , exception_message = Just $ pack $ displayException ex
-    , exception_stacktrace = []
+    { exception_errorClass = typeName @StringException
+    , exception_message = Just $ T.pack message
+    , exception_stacktrace = callStackToStackFrames stack
     }
 
--- | Show an exception's "error class"
-exErrorClass :: forall e. Exception.Exception e => e -> Text
-exErrorClass _ = pack $ show $ typeRep $ Proxy @e
+-- | 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} =
+  defaultException
+    { exception_errorClass = typeName @StringException
+    , exception_message = Just $ T.pack message
+    , exception_stacktrace =
+        maybe
+          (callStackToStackFrames stringExceptionStack)
+          callStackToStackFrames
+          $ annotatedExceptionCallStack ae
+    }
+
+-- | 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 ->
+      defaultException
+        { exception_errorClass = exErrorClass $ Annotated.exception ae
+        , exception_message =
+            Just $ T.pack $ displayException $ Annotated.exception ae
+        , exception_stacktrace = callStackToStackFrames stack
+        }
+    Nothing ->
+      let parseResult =
+            asum
+              [ fromException (Annotated.exception ae)
+                  >>= (either (const Nothing) Just . parseErrorCall)
+              , either (const Nothing) Just $
+                  parseStringException (Annotated.exception ae)
+              ]
+      in  defaultException
+            { exception_errorClass =
+                exErrorClass $
+                  Annotated.exception ae
+            , exception_message =
+                asum
+                  [ mwsfMessage <$> parseResult
+                  , Just $
+                      T.pack $
+                        displayException $
+                          Annotated.exception
+                            ae
+                  ]
+            , exception_stacktrace = foldMap mwsfStackFrames parseResult
+            }
+
+-- | 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
+callStackToStackFrames :: CallStack -> [StackFrame]
+callStackToStackFrames = fmap callSiteToStackFrame . getCallStack
+
+callSiteToStackFrame :: (String, SrcLoc) -> StackFrame
+callSiteToStackFrame (str, loc) =
+  defaultStackFrame
+    { stackFrame_method = T.pack str
+    , stackFrame_file = T.pack $ srcLocFile loc
+    , stackFrame_lineNumber = srcLocStartLine loc
+    , stackFrame_columnNumber = Just $ srcLocStartCol loc
+    }