{-# LANGUAGE ExistentialQuantification #-}

module Network.Bugsnag.Exception
    ( BugsnagException(..)
    , bugsnagException
    , bugsnagExceptionFromSomeException
    ) where

import Prelude

import Control.Exception
import Data.Aeson
import Data.Proxy (Proxy(..))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Typeable (typeRep)
import GHC.Generics
import Instances.TH.Lift ()
import Network.Bugsnag.Exception.Parse
import Network.Bugsnag.StackFrame

-- | Opaque type for @'Exception' e => e -> 'BugsnagException'@
--
-- These can be placed in a heterogenious list and then tried in turn to find
-- something better than @'SomeException'@. This is a shameless copy of the
-- @'Handler'@ type (and general approach) used by @'catches'@.
--
data Caster = forall e . Exception e => Caster (e -> BugsnagException)

data BugsnagException = BugsnagException
    { BugsnagException -> Text
beErrorClass :: Text
    , BugsnagException -> Maybe Text
beMessage :: Maybe Text
    , BugsnagException -> [BugsnagStackFrame]
beStacktrace :: [BugsnagStackFrame]
    , BugsnagException -> Maybe SomeException
beOriginalException :: Maybe SomeException
    }
    deriving stock ((forall x. BugsnagException -> Rep BugsnagException x)
-> (forall x. Rep BugsnagException x -> BugsnagException)
-> Generic BugsnagException
forall x. Rep BugsnagException x -> BugsnagException
forall x. BugsnagException -> Rep BugsnagException x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep BugsnagException x -> BugsnagException
$cfrom :: forall x. BugsnagException -> Rep BugsnagException x
Generic, Int -> BugsnagException -> ShowS
[BugsnagException] -> ShowS
BugsnagException -> String
(Int -> BugsnagException -> ShowS)
-> (BugsnagException -> String)
-> ([BugsnagException] -> ShowS)
-> Show BugsnagException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BugsnagException] -> ShowS
$cshowList :: [BugsnagException] -> ShowS
show :: BugsnagException -> String
$cshow :: BugsnagException -> String
showsPrec :: Int -> BugsnagException -> ShowS
$cshowsPrec :: Int -> BugsnagException -> ShowS
Show)

instance ToJSON BugsnagException where
    toJSON :: BugsnagException -> Value
toJSON BugsnagException {[BugsnagStackFrame]
Maybe Text
Maybe SomeException
Text
beOriginalException :: Maybe SomeException
beStacktrace :: [BugsnagStackFrame]
beMessage :: Maybe Text
beErrorClass :: Text
beOriginalException :: BugsnagException -> Maybe SomeException
beStacktrace :: BugsnagException -> [BugsnagStackFrame]
beMessage :: BugsnagException -> Maybe Text
beErrorClass :: BugsnagException -> Text
..} = [Pair] -> Value
object
        [ Key
"errorClass" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
beErrorClass
        , Key
"message" Key -> Maybe Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
beMessage
        , Key
"stacktrace" Key -> [BugsnagStackFrame] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [BugsnagStackFrame]
beStacktrace
        ]

instance Exception BugsnagException

-- | Construct a throwable @'BugsnagException'@
--
-- Note that Message is optional in the API, but we consider it required because
-- that's just silly. To include a stack frame from the location of construction
-- via Template Haskell, see @'currentStackFrame'@.
--
bugsnagException :: Text -> Text -> [BugsnagStackFrame] -> BugsnagException
bugsnagException :: Text -> Text -> [BugsnagStackFrame] -> BugsnagException
bugsnagException Text
errorClass Text
message [BugsnagStackFrame]
stacktrace = BugsnagException :: Text
-> Maybe Text
-> [BugsnagStackFrame]
-> Maybe SomeException
-> BugsnagException
BugsnagException
    { beErrorClass :: Text
beErrorClass = Text
errorClass
    , beMessage :: Maybe Text
beMessage = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
message
    , beStacktrace :: [BugsnagStackFrame]
beStacktrace = [BugsnagStackFrame]
stacktrace
    , beOriginalException :: Maybe SomeException
beOriginalException = Maybe SomeException
forall a. Maybe a
Nothing
    }

-- | Construct a @'BugsnagException'@ from a @'SomeException'@
--
-- @'BugsnagException'@s are left as-is, and @'ErrorCall'@ exceptions are parsed
-- for @'HasCallStack'@ information to use as @stacktrace@. Otherwise, we
-- attempt to determine @errorClass@ and we use @'displayException'@ as
-- @message@.
--
-- >>> import Control.Arrow
-- >>> import System.IO.Error
-- >>> (beErrorClass &&& beMessage) $ bugsnagExceptionFromSomeException $ toException $ userError "Oops"
-- ("IOException",Just "user error (Oops)")
--
bugsnagExceptionFromSomeException :: SomeException -> BugsnagException
bugsnagExceptionFromSomeException :: SomeException -> BugsnagException
bugsnagExceptionFromSomeException SomeException
ex = (Caster -> BugsnagException -> BugsnagException)
-> BugsnagException -> [Caster] -> BugsnagException
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Caster -> BugsnagException -> BugsnagException
go BugsnagException
seed [Caster]
exCasters
  where
    go :: Caster -> BugsnagException -> BugsnagException
    go :: Caster -> BugsnagException -> BugsnagException
go (Caster e -> BugsnagException
caster) BugsnagException
res = BugsnagException
-> (e -> BugsnagException) -> Maybe e -> BugsnagException
forall b a. b -> (a -> b) -> Maybe a -> b
maybe BugsnagException
res e -> BugsnagException
caster (Maybe e -> BugsnagException) -> Maybe e -> BugsnagException
forall a b. (a -> b) -> a -> b
$ SomeException -> Maybe e
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
ex

    seed :: BugsnagException
seed = ((SomeException -> Either String MessageWithStackFrames)
-> SomeException -> BugsnagException
forall e.
Exception e =>
(e -> Either String MessageWithStackFrames)
-> e -> BugsnagException
bugsnagExceptionWithParser SomeException -> Either String MessageWithStackFrames
parseStringException SomeException
ex)
        { beErrorClass :: Text
beErrorClass = (\(SomeException e
e) -> e -> Text
forall e. Exception e => e -> Text
exErrorClass e
e) SomeException
ex
        }

exCasters :: [Caster]
exCasters :: [Caster]
exCasters = [(BugsnagException -> BugsnagException) -> Caster
forall e. Exception e => (e -> BugsnagException) -> Caster
Caster BugsnagException -> BugsnagException
forall a. a -> a
id, (ErrorCall -> BugsnagException) -> Caster
forall e. Exception e => (e -> BugsnagException) -> Caster
Caster ((ErrorCall -> BugsnagException) -> Caster)
-> (ErrorCall -> BugsnagException) -> Caster
forall a b. (a -> b) -> a -> b
$ (ErrorCall -> Either String MessageWithStackFrames)
-> ErrorCall -> BugsnagException
forall e.
Exception e =>
(e -> Either String MessageWithStackFrames)
-> e -> BugsnagException
bugsnagExceptionWithParser ErrorCall -> Either String MessageWithStackFrames
parseErrorCall]

bugsnagExceptionWithParser
    :: Exception e
    => (e -> Either String MessageWithStackFrames)
    -> e
    -> BugsnagException
bugsnagExceptionWithParser :: (e -> Either String MessageWithStackFrames)
-> e -> BugsnagException
bugsnagExceptionWithParser e -> Either String MessageWithStackFrames
p e
ex = case e -> Either String MessageWithStackFrames
p e
ex of
    Left String
_ -> e -> BugsnagException
forall e. Exception e => e -> BugsnagException
bugsnagExceptionFromException e
ex
    Right (MessageWithStackFrames Text
message [BugsnagStackFrame]
stacktrace) ->
        Text -> Text -> [BugsnagStackFrame] -> BugsnagException
bugsnagException (e -> Text
forall e. Exception e => e -> Text
exErrorClass e
ex) Text
message [BugsnagStackFrame]
stacktrace

-- | Construct a @'BugsnagException'@ from an @'Exception'@
--
-- This exists mostly as a way to provide the type hint.
--
-- > bugsnagExceptionFromException @IOException ex
--
bugsnagExceptionFromException :: Exception e => e -> BugsnagException
bugsnagExceptionFromException :: e -> BugsnagException
bugsnagExceptionFromException e
ex =
    (Text -> Text -> [BugsnagStackFrame] -> BugsnagException
bugsnagException (e -> Text
forall e. Exception e => e -> Text
exErrorClass e
ex) (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ e -> String
forall e. Exception e => e -> String
displayException e
ex) [])
        { beOriginalException :: Maybe SomeException
beOriginalException = SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just (SomeException -> Maybe SomeException)
-> SomeException -> Maybe SomeException
forall a b. (a -> b) -> a -> b
$ e -> SomeException
forall e. Exception e => e -> SomeException
toException e
ex
        }

-- | Show an exception's "error class"
--
-- >>> exErrorClass (undefined :: IOException)
-- "IOException"
--
-- >>> exErrorClass (undefined :: SomeException)
-- "SomeException"
--
exErrorClass :: forall e . Exception e => e -> Text
exErrorClass :: e -> Text
exErrorClass e
_ = 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 e -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy e -> TypeRep) -> Proxy e -> TypeRep
forall a b. (a -> b) -> a -> b
$ Proxy e
forall k (t :: k). Proxy t
Proxy @e