Exception.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ExistentialQuantification #-}

module Network.Bugsnag.Exception
  ( AsException (..)
  , bugsnagExceptionFromSomeException
  ) where

import Prelude

import Control.Exception
  ( ErrorCall
  , 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.Function ((&))
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
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))

-- | Newtype over 'Exception', so it can be thrown and caught
newtype AsException = AsException
  { unAsException :: Exception
  }
  deriving newtype (Show)
  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 =
  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
            )
      )

-- | 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

findTraceAnnotation :: SomeException -> Maybe [StackFrame]
findTraceAnnotation ex =
  asum
    [ Context.backtraceStackFrames ex
    , do
        ae <- fromException @(AnnotatedException SomeException) ex
        stack <- annotatedExceptionCallStack ae
        pure $ callStackToStackFrames stack
    ]

-- | 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
      }

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
      }

unrecognized :: SomeException -> Exception
unrecognized ex =
  defaultException
    { 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 = []
    }

-- | 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
    }