summaryrefslogtreecommitdiff
path: root/src/Network/Bugsnag/Exception.hs
blob: 1d3d72d720888f0529cc9251fa876cdafc0a4078 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Network.Bugsnag.Exception
    ( BugsnagException(..)
    , bugsnagException
    , bugsnagExceptionFromSomeException
    ) where

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
    { beErrorClass :: Text
    , beMessage :: Maybe Text
    , beStacktrace :: [BugsnagStackFrame]
    , beOriginalException :: Maybe SomeException
    }
    deriving (Generic, Show)

instance ToJSON BugsnagException where
    toJSON BugsnagException{..} = object
        [ "errorClass" .= beErrorClass
        , "message" .= beMessage
        , "stacktrace" .= 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 errorClass message stacktrace = BugsnagException
    { beErrorClass = errorClass
    , beMessage = Just message
    , beStacktrace = stacktrace
    , beOriginalException = 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 the @'show'@n exception as
-- @message@.
--
-- >>> import Control.Arrow
-- >>> import System.IO.Error
-- >>> (beErrorClass &&& beMessage) $ bugsnagExceptionFromSomeException $ toException $ userError "Oops"
-- ("IOException",Just "user error (Oops)")
--
bugsnagExceptionFromSomeException :: SomeException -> BugsnagException
bugsnagExceptionFromSomeException ex =
    foldr go (bugsnagExceptionWithParser parseStringException ex) exCasters
  where
    go :: Caster -> BugsnagException -> BugsnagException
    go (Caster caster) res = maybe res caster $ fromException ex

exCasters :: [Caster]
exCasters =
    [ Caster id
    , Caster $ bugsnagExceptionWithParser parseErrorCall
    , Caster $ bugsnagExceptionFromException @IOException
    , Caster $ bugsnagExceptionFromException @ArithException
    , Caster $ bugsnagExceptionFromException @ArrayException
    , Caster $ bugsnagExceptionFromException @AssertionFailed
    , Caster $ bugsnagExceptionFromException @SomeAsyncException
    , Caster $ bugsnagExceptionFromException @AsyncException
    , Caster $ bugsnagExceptionFromException @NonTermination
    , Caster $ bugsnagExceptionFromException @NestedAtomically
    , Caster $ bugsnagExceptionFromException @BlockedIndefinitelyOnMVar
    , Caster $ bugsnagExceptionFromException @BlockedIndefinitelyOnSTM
    , Caster $ bugsnagExceptionFromException @AllocationLimitExceeded
    , Caster $ bugsnagExceptionFromException @Deadlock
    , Caster $ bugsnagExceptionFromException @NoMethodError
    , Caster $ bugsnagExceptionFromException @PatternMatchFail
    , Caster $ bugsnagExceptionFromException @RecConError
    , Caster $ bugsnagExceptionFromException @RecSelError
    , Caster $ bugsnagExceptionFromException @RecUpdError
    , Caster $ bugsnagExceptionFromException @TypeError
    ]

bugsnagExceptionWithParser
    :: Exception e
    => (e -> Either String MessageWithStackFrames)
    -> e
    -> BugsnagException
bugsnagExceptionWithParser p ex =
    case p ex of
        Left _ -> bugsnagExceptionFromException ex
        Right (MessageWithStackFrames message stacktrace) ->
            bugsnagException (exErrorClass ex) message 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 ex =
    (bugsnagException (exErrorClass ex) (T.pack $ show ex) [])
        { beOriginalException = Just $ toException ex
        }

-- | Show an exception's "error class"
--
-- >>> exErrorClass (undefined :: IOException)
-- "IOException"
--
-- >>> exErrorClass (undefined :: SomeException)
-- "SomeException"
--
exErrorClass :: forall e. Exception e => e -> Text
exErrorClass _ = T.pack $ show $ typeRep $ Proxy @e