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

-- | Construct a 'Exception' from a 'SomeException'
bugsnagExceptionFromSomeException :: SomeException -> Exception
bugsnagExceptionFromSomeException :: SomeException -> Exception
bugsnagExceptionFromSomeException SomeException
ex =
  forall a. a -> Maybe a -> a
fromMaybe Exception
defaultException forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
      [ AnnotatedException AsException -> Exception
bugsnagExceptionFromAnnotatedAsException forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Exception e => SomeException -> Maybe e
fromException SomeException
ex
      , StringException -> Exception
bugsnagExceptionFromStringException forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Exception e => SomeException -> Maybe e
fromException SomeException
ex
      , AnnotatedException StringException -> Exception
bugsnagExceptionFromAnnotatedStringException forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Exception e => SomeException -> Maybe e
fromException SomeException
ex
      , AnnotatedException SomeException -> Exception
bugsnagExceptionFromAnnotatedException forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) =
  Exception
defaultException
    { exception_errorClass :: Text
exception_errorClass = forall a. Typeable a => Text
typeName @StringException
    , exception_message :: Maybe Text
exception_message = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
message
    , exception_stacktrace :: [StackFrame]
exception_stacktrace = CallStack -> [StackFrame]
callStackToStackFrames CallStack
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} =
  Exception
defaultException
    { exception_errorClass :: Text
exception_errorClass = forall a. Typeable a => Text
typeName @StringException
    , exception_message :: Maybe Text
exception_message = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
message
    , exception_stacktrace :: [StackFrame]
exception_stacktrace =
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          (CallStack -> [StackFrame]
callStackToStackFrames CallStack
stringExceptionStack)
          CallStack -> [StackFrame]
callStackToStackFrames
          forall a b. (a -> b) -> a -> b
$ forall exception. AnnotatedException exception -> Maybe CallStack
annotatedExceptionCallStack AnnotatedException StringException
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 forall exception. AnnotatedException exception -> Maybe CallStack
annotatedExceptionCallStack AnnotatedException SomeException
ae of
    Just CallStack
stack ->
      Exception
defaultException
        { exception_errorClass :: Text
exception_errorClass = SomeException -> Text
exErrorClass forall a b. (a -> b) -> a -> b
$ forall exception. AnnotatedException exception -> exception
Annotated.exception AnnotatedException SomeException
ae
        , exception_message :: Maybe Text
exception_message =
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> String
displayException forall a b. (a -> b) -> a -> b
$ forall exception. AnnotatedException exception -> exception
Annotated.exception AnnotatedException SomeException
ae
        , exception_stacktrace :: [StackFrame]
exception_stacktrace = CallStack -> [StackFrame]
callStackToStackFrames CallStack
stack
        }
    Maybe CallStack
Nothing ->
      let parseResult :: Maybe MessageWithStackFrames
parseResult =
            forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
              [ forall e. Exception e => SomeException -> Maybe e
fromException (forall exception. AnnotatedException exception -> exception
Annotated.exception AnnotatedException SomeException
ae)
                  forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorCall -> Either String MessageWithStackFrames
parseErrorCall)
              , forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                  SomeException -> Either String MessageWithStackFrames
parseStringException (forall exception. AnnotatedException exception -> exception
Annotated.exception AnnotatedException SomeException
ae)
              ]
      in  Exception
defaultException
            { exception_errorClass :: Text
exception_errorClass =
                SomeException -> Text
exErrorClass forall a b. (a -> b) -> a -> b
$
                  forall exception. AnnotatedException exception -> exception
Annotated.exception AnnotatedException SomeException
ae
            , exception_message :: Maybe Text
exception_message =
                forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
                  [ MessageWithStackFrames -> Text
mwsfMessage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe MessageWithStackFrames
parseResult
                  , forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                      String -> Text
T.pack forall a b. (a -> b) -> a -> b
$
                        forall e. Exception e => e -> String
displayException forall a b. (a -> b) -> a -> b
$
                          forall exception. AnnotatedException exception -> exception
Annotated.exception
                            AnnotatedException SomeException
ae
                  ]
            , exception_stacktrace :: [StackFrame]
exception_stacktrace = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap MessageWithStackFrames -> [StackFrame]
mwsfStackFrames Maybe MessageWithStackFrames
parseResult
            }

-- | 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 forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep forall a b. (a -> b) -> a -> b
$ 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String, SrcLoc) -> StackFrame
callSiteToStackFrame 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 :: Text
stackFrame_method = String -> Text
T.pack String
str
    , stackFrame_file :: Text
stackFrame_file = String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ SrcLoc -> String
srcLocFile SrcLoc
loc
    , stackFrame_lineNumber :: Int
stackFrame_lineNumber = SrcLoc -> Int
srcLocStartLine SrcLoc
loc
    , stackFrame_columnNumber :: Maybe Int
stackFrame_columnNumber = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ SrcLoc -> Int
srcLocStartCol SrcLoc
loc
    }