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

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

import Prelude

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.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
  { AsException -> Exception
unAsException :: Exception
  }
  deriving newtype (Int -> AsException -> ShowS
[AsException] -> ShowS
AsException -> String
(Int -> AsException -> ShowS)
-> (AsException -> String)
-> ([AsException] -> ShowS)
-> Show AsException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AsException -> ShowS
showsPrec :: Int -> AsException -> ShowS
$cshow :: AsException -> String
show :: AsException -> String
$cshowList :: [AsException] -> ShowS
showList :: [AsException] -> ShowS
Show)
  deriving anyclass (Show AsException
Typeable AsException
(Typeable AsException, Show AsException) =>
(AsException -> SomeException)
-> (SomeException -> Maybe AsException)
-> (AsException -> String)
-> Exception AsException
SomeException -> Maybe AsException
AsException -> String
AsException -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: AsException -> SomeException
toException :: AsException -> SomeException
$cfromException :: SomeException -> Maybe AsException
fromException :: SomeException -> Maybe AsException
$cdisplayException :: AsException -> String
displayException :: AsException -> String
Exception.Exception)

-- | Construct a 'Exception' from a 'SomeException'
bugsnagExceptionFromSomeException :: SomeException -> Exception
bugsnagExceptionFromSomeException :: SomeException -> Exception
bugsnagExceptionFromSomeException SomeException
ex =
  Exception -> Maybe Exception -> Exception
forall a. a -> Maybe a -> a
fromMaybe Exception
defaultException (Maybe Exception -> Exception) -> Maybe Exception -> Exception
forall a b. (a -> b) -> a -> b
$
    [Maybe Exception] -> Maybe Exception
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
      [ AnnotatedException AsException -> Exception
bugsnagExceptionFromAnnotatedAsException (AnnotatedException AsException -> Exception)
-> Maybe (AnnotatedException AsException) -> Maybe Exception
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SomeException -> Maybe (AnnotatedException AsException)
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
ex
      , StringException -> Exception
bugsnagExceptionFromStringException (StringException -> Exception)
-> Maybe StringException -> Maybe Exception
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SomeException -> Maybe StringException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
ex
      , AnnotatedException StringException -> Exception
bugsnagExceptionFromAnnotatedStringException (AnnotatedException StringException -> Exception)
-> Maybe (AnnotatedException StringException) -> Maybe Exception
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SomeException -> Maybe (AnnotatedException StringException)
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
ex
      , AnnotatedException SomeException -> Exception
bugsnagExceptionFromAnnotatedException (AnnotatedException SomeException -> Exception)
-> Maybe (AnnotatedException SomeException) -> Maybe Exception
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SomeException -> Maybe (AnnotatedException SomeException)
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
ex
      ]

-- | Respect 'AsException' as-is without modifications.
--   If it's wrapped in 'AnnotatedException', ignore the annotations.
bugsnagExceptionFromAnnotatedAsException
  :: AnnotatedException AsException -> Exception
bugsnagExceptionFromAnnotatedAsException :: AnnotatedException AsException -> Exception
bugsnagExceptionFromAnnotatedAsException = AsException -> Exception
unAsException (AsException -> Exception)
-> (AnnotatedException AsException -> AsException)
-> AnnotatedException AsException
-> Exception
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnnotatedException AsException -> AsException
forall exception. AnnotatedException exception -> exception
Annotated.exception

-- | When a 'StringException' is thrown, we use its message and trace.
bugsnagExceptionFromStringException :: StringException -> Exception
bugsnagExceptionFromStringException :: StringException -> Exception
bugsnagExceptionFromStringException (StringException String
message CallStack
stack) =
  (Maybe Text -> Exception
mkException (Maybe Text -> Exception) -> Maybe Text -> Exception
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
message)
    { exception_errorClass = typeName @StringException
    , exception_stacktrace = callStackToStackFrames stack
    }

-- | 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 :: AnnotatedException StringException -> Exception
bugsnagExceptionFromAnnotatedStringException ae :: AnnotatedException StringException
ae@AnnotatedException {exception :: forall exception. AnnotatedException exception -> exception
exception = StringException String
message CallStack
stringExceptionStack} =
  (Maybe Text -> Exception
mkException (Maybe Text -> Exception) -> Maybe Text -> Exception
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
message)
    { exception_errorClass = typeName @StringException
    , 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 :: AnnotatedException SomeException -> Exception
bugsnagExceptionFromAnnotatedException AnnotatedException SomeException
ae =
  case AnnotatedException SomeException -> Maybe CallStack
forall exception. AnnotatedException exception -> Maybe CallStack
annotatedExceptionCallStack AnnotatedException SomeException
ae of
    Just CallStack
stack ->
      (Maybe Text -> Exception
mkException (Maybe Text -> Exception) -> Maybe Text -> Exception
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall e. Exception e => e -> String
displayException (SomeException -> String) -> SomeException -> String
forall a b. (a -> b) -> a -> b
$ AnnotatedException SomeException -> SomeException
forall exception. AnnotatedException exception -> exception
Annotated.exception AnnotatedException SomeException
ae)
        { exception_errorClass = exErrorClass $ Annotated.exception ae
        , exception_stacktrace = callStackToStackFrames stack
        }
    Maybe CallStack
Nothing ->
      let
        parseResult :: Maybe MessageWithStackFrames
parseResult =
          [Maybe MessageWithStackFrames] -> Maybe MessageWithStackFrames
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
            [ SomeException -> Maybe ErrorCall
forall e. Exception e => SomeException -> Maybe e
fromException (AnnotatedException SomeException -> SomeException
forall exception. AnnotatedException exception -> exception
Annotated.exception AnnotatedException SomeException
ae)
                Maybe ErrorCall
-> (ErrorCall -> Maybe MessageWithStackFrames)
-> Maybe MessageWithStackFrames
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((String -> Maybe MessageWithStackFrames)
-> (MessageWithStackFrames -> Maybe MessageWithStackFrames)
-> Either String MessageWithStackFrames
-> Maybe MessageWithStackFrames
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe MessageWithStackFrames
-> String -> Maybe MessageWithStackFrames
forall a b. a -> b -> a
const Maybe MessageWithStackFrames
forall a. Maybe a
Nothing) MessageWithStackFrames -> Maybe MessageWithStackFrames
forall a. a -> Maybe a
Just (Either String MessageWithStackFrames
 -> Maybe MessageWithStackFrames)
-> (ErrorCall -> Either String MessageWithStackFrames)
-> ErrorCall
-> Maybe MessageWithStackFrames
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorCall -> Either String MessageWithStackFrames
parseErrorCall)
            , (String -> Maybe MessageWithStackFrames)
-> (MessageWithStackFrames -> Maybe MessageWithStackFrames)
-> Either String MessageWithStackFrames
-> Maybe MessageWithStackFrames
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe MessageWithStackFrames
-> String -> Maybe MessageWithStackFrames
forall a b. a -> b -> a
const Maybe MessageWithStackFrames
forall a. Maybe a
Nothing) MessageWithStackFrames -> Maybe MessageWithStackFrames
forall a. a -> Maybe a
Just (Either String MessageWithStackFrames
 -> Maybe MessageWithStackFrames)
-> Either String MessageWithStackFrames
-> Maybe MessageWithStackFrames
forall a b. (a -> b) -> a -> b
$
                SomeException -> Either String MessageWithStackFrames
parseStringException (AnnotatedException SomeException -> SomeException
forall exception. AnnotatedException exception -> exception
Annotated.exception AnnotatedException SomeException
ae)
            ]

        mmessage :: Maybe Text
mmessage =
          [Maybe Text] -> Maybe Text
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
            [ MessageWithStackFrames -> Text
mwsfMessage (MessageWithStackFrames -> Text)
-> Maybe MessageWithStackFrames -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe MessageWithStackFrames
parseResult
            , Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$
                String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
                  SomeException -> String
forall e. Exception e => e -> String
displayException (SomeException -> String) -> SomeException -> String
forall a b. (a -> b) -> a -> b
$
                    AnnotatedException SomeException -> SomeException
forall exception. AnnotatedException exception -> exception
Annotated.exception
                      AnnotatedException SomeException
ae
            ]
      in
        (Maybe Text -> Exception
mkException Maybe Text
mmessage)
          { exception_errorClass = exErrorClass $ Annotated.exception ae
          , exception_stacktrace = foldMap mwsfStackFrames parseResult
          }

mkException :: Maybe Text -> Exception
mkException :: Maybe Text -> Exception
mkException Maybe Text
mmsg =
  Exception
defaultException
    { exception_message = T.dropWhileEnd (== '\n') <$> mmsg
    }

-- | Unwrap the 'SomeException' newtype to get the actual underlying type name
exErrorClass :: SomeException -> Text
exErrorClass :: SomeException -> Text
exErrorClass (SomeException (e
_ :: e)) = forall a. Typeable a => Text
typeName @e

typeName :: forall a. Typeable a => Text
typeName :: forall a. Typeable a => Text
typeName = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> TypeRep -> String
forall a b. (a -> b) -> a -> b
$ Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a -> TypeRep) -> Proxy a -> TypeRep
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
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 :: CallStack -> [StackFrame]
callStackToStackFrames = ((String, SrcLoc) -> StackFrame)
-> [(String, SrcLoc)] -> [StackFrame]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String, SrcLoc) -> StackFrame
callSiteToStackFrame ([(String, SrcLoc)] -> [StackFrame])
-> (CallStack -> [(String, SrcLoc)]) -> CallStack -> [StackFrame]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallStack -> [(String, SrcLoc)]
getCallStack

callSiteToStackFrame :: (String, SrcLoc) -> StackFrame
callSiteToStackFrame :: (String, SrcLoc) -> StackFrame
callSiteToStackFrame (String
str, SrcLoc
loc) =
  StackFrame
defaultStackFrame
    { stackFrame_method = T.pack str
    , stackFrame_file = T.pack $ srcLocFile loc
    , stackFrame_lineNumber = srcLocStartLine loc
    , stackFrame_columnNumber = Just $ srcLocStartCol loc
    }