diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,12 @@ +## [_Unreleased_](https://github.com/pbrisbin/bugsnag-haskell/compare/bugsnag-v1.0.0.0...main) + +- None + +## [v1.0.0.0](https://github.com/pbrisbin/bugsnag-haskell/tree/bugsnag-v1.0.0.0) + +First released version. + +--- + +For CHANGELOG details prior to the package re-organization, see +[`archive/CHANGELOG.md`](../archive/CHANGELOG.md). diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2022 Pat Brisbin + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,71 @@ +# Bugsnag error reporter for Haskell + +Catch exceptions in your Haskell code and report then to Bugsnag. + +## Configuration + +```hs +let settings = defaultSettings "A_BUGSNAG_API_KEY" +``` + +## Manual Reporting + +`Data.Bugsnag.Exception` is the type of actual exceptions included in the event +reported to Bugsnag. Constructing it directly can be useful to attach the +current source location as a stack frame. + +```hs +let + ex = defaultException + { exception_errorClass = "Error" + , exception_message = Just "message" + , exception_stacktrace = [$(currentStackFrame) "myFunction"] + } +``` + +In order to treat it like an actual Haskell `Exception` (including to report +it), wrap it in `AsException`: + +```hs +notifyBugsnag settings $ AsException ex +``` + +## Catching & Throwing + +Catch any exceptions, notify, and re-throw: + +```hs +myFunction `withException` notifyBugsnag @SomeException settings +``` + +Throw a manually-built exception: + +```hs +throwIO $ AsException ex +``` + +## Examples + +- [Simple](./examples/simple/Main.hs) +- [Command-Line](./examples/cli/Main.hs) + +Examples can be built locally with: + +```console +stack build --flag bugsnag:examples +``` + +## `bugsnag-hs` + +We depend on `bugsnag-hs` to define the types for the full reporting API +payload. Unfortunately, it exposes them from its own `Network.Bugsnag` module, +which conflicts with ourselves. + +To get around this, we re-export that whole module as `Data.Bugsnag`. If you are +currently depending on `bugsnag-hs` and wish to use our package too, we +recommend you only depend on us and use its types through the `Data.Bugsnag` +re-export. + +--- + +[CHANGELOG](./CHANGELOG.md) | [LICENSE](./LICENSE) diff --git a/bugsnag.cabal b/bugsnag.cabal new file mode 100644 --- /dev/null +++ b/bugsnag.cabal @@ -0,0 +1,131 @@ +cabal-version: 1.18 +name: bugsnag +version: 1.0.0.0 +license: MIT +license-file: LICENSE +maintainer: pbrisbin@gmail.com +author: Patrick Brisbin +homepage: https://github.com/pbrisbin/bugsnag-haskell#readme +synopsis: Bugsnag error reporter for Haskell +description: Please see README.md +category: Web +build-type: Simple +extra-source-files: test/fixtures/index-project/Foo.hs +extra-doc-files: + CHANGELOG.md + README.md + +flag examples + description: Build the examples + default: False + +library + exposed-modules: + Data.Bugsnag + Data.Bugsnag.Settings + Network.Bugsnag + Network.Bugsnag.BeforeNotify + Network.Bugsnag.CodeIndex + Network.Bugsnag.Device + Network.Bugsnag.Exception + Network.Bugsnag.Exception.Parse + Network.Bugsnag.Notify + Network.Bugsnag.StackFrame + + hs-source-dirs: src + other-modules: Paths_bugsnag + default-language: Haskell2010 + default-extensions: + BangPatterns DataKinds DeriveAnyClass DeriveFoldable DeriveFunctor + DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies + FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving + LambdaCase MultiParamTypeClasses NoImplicitPrelude + NoMonomorphismRestriction OverloadedStrings RankNTypes + RecordWildCards ScopedTypeVariables StandaloneDeriving + TypeApplications TypeFamilies + + build-depends: + Glob >=0.9.0, + base >=4.11.0 && <5, + bugsnag-hs >=0.2.0.8, + bytestring >=0.10.8.2, + containers >=0.6.0.1, + http-client >=0.6.4, + http-client-tls >=0.3.5.3, + parsec >=3.1.14.0, + template-haskell >=2.14.0.0, + text >=1.2.3.1, + th-lift-instances >=0.1.14, + ua-parser >=0.7.5.1, + unordered-containers >=0.2.10.0 + +executable example-cli + main-is: Main.hs + hs-source-dirs: examples/cli + other-modules: Paths_bugsnag + default-language: Haskell2010 + default-extensions: + BangPatterns DataKinds DeriveAnyClass DeriveFoldable DeriveFunctor + DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies + FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving + LambdaCase MultiParamTypeClasses NoImplicitPrelude + NoMonomorphismRestriction OverloadedStrings RankNTypes + RecordWildCards ScopedTypeVariables StandaloneDeriving + TypeApplications TypeFamilies + + build-depends: + base >=4.11.0 && <5, + bugsnag -any + + if !flag(examples) + buildable: False + +executable example-simple + main-is: Main.hs + hs-source-dirs: examples/simple + other-modules: Paths_bugsnag + default-language: Haskell2010 + default-extensions: + BangPatterns DataKinds DeriveAnyClass DeriveFoldable DeriveFunctor + DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies + FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving + LambdaCase MultiParamTypeClasses NoImplicitPrelude + NoMonomorphismRestriction OverloadedStrings RankNTypes + RecordWildCards ScopedTypeVariables StandaloneDeriving + TypeApplications TypeFamilies + + build-depends: + base >=4.11.0 && <5, + bugsnag -any + + if !flag(examples) + buildable: False + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + other-modules: + Examples + Network.Bugsnag.BeforeNotifySpec + Network.Bugsnag.CodeIndexSpec + Network.Bugsnag.DeviceSpec + Network.Bugsnag.ExceptionSpec + Paths_bugsnag + + default-language: Haskell2010 + default-extensions: + BangPatterns DataKinds DeriveAnyClass DeriveFoldable DeriveFunctor + DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies + FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving + LambdaCase MultiParamTypeClasses NoImplicitPrelude + NoMonomorphismRestriction OverloadedStrings RankNTypes + RecordWildCards ScopedTypeVariables StandaloneDeriving + TypeApplications TypeFamilies + + build-depends: + base >=4.11.0 && <5, + bugsnag -any, + hspec >=2.7.1, + text >=1.2.3.1, + unliftio >=0.2.12 diff --git a/examples/cli/Main.hs b/examples/cli/Main.hs new file mode 100644 --- /dev/null +++ b/examples/cli/Main.hs @@ -0,0 +1,22 @@ +module Main + ( main + ) where + +import Prelude + +import Control.Exception (SomeException, catch) +import Data.Bugsnag.Settings +import Network.Bugsnag +import System.Exit (die) + +main :: IO () +main = do + let settings = defaultSettings "BUGSNAG_API_KEY" + + appMain `catch` \ex -> do + notifyBugsnag @SomeException settings ex + die $ show ex + +-- Actual program logic +appMain :: IO () +appMain = error "Whoops" diff --git a/examples/simple/Main.hs b/examples/simple/Main.hs new file mode 100644 --- /dev/null +++ b/examples/simple/Main.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Main + ( main + ) where + +import Prelude + +import Data.Bugsnag +import Data.Bugsnag.Settings +import Network.Bugsnag +import Network.Bugsnag.Exception +import Network.Bugsnag.StackFrame + +main :: IO () +main = do + let settings = defaultSettings "BUGSNAG_API_KEY" + + notifyBugsnag settings $ AsException $ defaultException + { exception_errorClass = "Error" + , exception_message = Just "message" + , exception_stacktrace = [$(currentStackFrame) "myFunction"] + } diff --git a/src/Data/Bugsnag.hs b/src/Data/Bugsnag.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bugsnag.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE PackageImports #-} + +-- | Re-exports the @Network.Bugsnag@ provided by @bugsnag-hs@ as @Data.Bugsnag@ +module Data.Bugsnag + ( module Network.Bugsnag + ) where + +import "bugsnag-hs" Network.Bugsnag diff --git a/src/Data/Bugsnag/Settings.hs b/src/Data/Bugsnag/Settings.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bugsnag/Settings.hs @@ -0,0 +1,63 @@ +module Data.Bugsnag.Settings + ( Settings(..) + , defaultSettings + ) where + +import Prelude + +import Data.Bugsnag +import Data.Text (Text) +import Network.Bugsnag.BeforeNotify +import Network.Bugsnag.CodeIndex +import Network.HTTP.Client (HttpException) + +data Settings = Settings + { settings_apiKey :: ApiKey + -- ^ Your Integration API Key + , settings_appVersion :: Maybe Text + -- ^ The version of your application + -- + -- Marking bugs as Fixed and having them auto-reopen in new versions + -- requires you set this. + -- + , settings_releaseStage :: Text + -- ^ The current release-stage, Production by default + , settings_enabledReleaseStages :: [Text] + -- ^ Which release-stages to notify in. Only Production by default + , settings_beforeNotify :: BeforeNotify + -- ^ Modify any events before they are sent + -- + -- For example to attach a user, or set the context. + -- + , settings_ignoreException :: Exception -> Bool + -- ^ Exception filtering + -- + -- Functions like 'notifyBugsnag' will do nothing with exceptions that pass + -- this predicate. N.B. Something lower-level, like 'reportError' won't be + -- aware of this. + -- + , settings_onNotifyException :: HttpException -> IO () + -- ^ How to handle an exception reporting error events + -- + -- Default is to ignore. + -- + , settings_codeIndex :: Maybe CodeIndex + -- ^ A 'CodeIndex' built at compile-time from project sources + -- + -- If set, this will be used to update StackFrames to include lines of + -- source code context as read out of this value. N.B. using this means + -- loading and keeping the source code for the entire project in memory. + -- + } + +defaultSettings :: Text -> Settings +defaultSettings k = Settings + { settings_apiKey = apiKey k + , settings_appVersion = Nothing + , settings_releaseStage = "production" + , settings_enabledReleaseStages = ["production"] + , settings_beforeNotify = mempty + , settings_ignoreException = const False + , settings_onNotifyException = const $ pure () + , settings_codeIndex = Nothing + } diff --git a/src/Network/Bugsnag.hs b/src/Network/Bugsnag.hs new file mode 100644 --- /dev/null +++ b/src/Network/Bugsnag.hs @@ -0,0 +1,12 @@ +module Network.Bugsnag + ( + -- * Notifying + notifyBugsnag + , notifyBugsnagWith + + -- * Modifying events on notification + , module Network.Bugsnag.BeforeNotify + ) where + +import Network.Bugsnag.BeforeNotify +import Network.Bugsnag.Notify diff --git a/src/Network/Bugsnag/BeforeNotify.hs b/src/Network/Bugsnag/BeforeNotify.hs new file mode 100644 --- /dev/null +++ b/src/Network/Bugsnag/BeforeNotify.hs @@ -0,0 +1,173 @@ +module Network.Bugsnag.BeforeNotify + ( BeforeNotify + , beforeNotify + , runBeforeNotify + + -- * Modifying the underlying Exceptions + , updateExceptions + , filterExceptions + , updateStackFrames + , filterStackFrames + , setStackFramesCode + , setStackFramesInProject + , setStackFramesInProjectByFile + , setStackFramesInProjectBy + + -- * Modifying the Event + , updateEvent + , updateEventFromOriginalException + , setGroupingHash + , setGroupingHashBy + , setDevice + , setContext + , setRequest + , setWarningSeverity + , setErrorSeverity + , setInfoSeverity + ) where + +import Prelude + +import qualified Control.Exception as Exception +import Data.Bugsnag +import Data.Maybe (isJust) +import Data.Text (Text, unpack) +import Network.Bugsnag.CodeIndex +import Network.Bugsnag.StackFrame + +-- | A function from 'Event' to 'Event' that is applied before notifying +-- +-- The wrapped function also accepts the original exception, for cases in which +-- that's useful -- but it's often not. Most 'BeforeNotify's use 'updateEvent', +-- which discards it. +-- +-- 'BeforeNotify' implements 'Semigroup' and 'Monoid', which means the /do +-- nothing/ 'BeforeNotify' is 'mempty' and two 'BeforeNotify's @doThis@ then +-- @doThat@ can be implemented as @doThat <> doThis@. +-- +newtype BeforeNotify = BeforeNotify + { _unBeforeNotify :: forall e. Exception.Exception e => e -> Event -> Event + } + +instance Semigroup BeforeNotify where + BeforeNotify f <> BeforeNotify g = BeforeNotify $ \e -> f e . g e + +instance Monoid BeforeNotify where + mempty = BeforeNotify $ const id + +beforeNotify + :: (forall e . Exception.Exception e => e -> Event -> Event) + -> BeforeNotify +beforeNotify = BeforeNotify + +runBeforeNotify :: Exception.Exception e => BeforeNotify -> e -> Event -> Event +runBeforeNotify (BeforeNotify f) = f + +updateExceptions :: (Exception -> Exception) -> BeforeNotify +updateExceptions f = updateEvent + $ \event -> event { event_exceptions = map f $ event_exceptions event } + +filterExceptions :: (Exception -> Bool) -> BeforeNotify +filterExceptions p = updateEvent $ \event -> + event { event_exceptions = filter p $ event_exceptions event } + +updateStackFrames :: (StackFrame -> StackFrame) -> BeforeNotify +updateStackFrames f = updateExceptions + $ \e -> e { exception_stacktrace = map f $ exception_stacktrace e } + +filterStackFrames :: (StackFrame -> Bool) -> BeforeNotify +filterStackFrames p = updateExceptions + $ \e -> e { exception_stacktrace = filter p $ exception_stacktrace e } + +setStackFramesCode :: CodeIndex -> BeforeNotify +setStackFramesCode = + (setStackFramesInProjectBy (isJust . stackFrame_code) <>) + . updateStackFrames + . attachBugsnagCode + +setStackFramesInProject :: Bool -> BeforeNotify +setStackFramesInProject = setStackFramesInProjectBy . const + +setStackFramesInProjectByFile :: (FilePath -> Bool) -> BeforeNotify +setStackFramesInProjectByFile f = + setStackFramesInProjectBy $ f . unpack . stackFrame_file + +setStackFramesInProjectBy :: (StackFrame -> Bool) -> BeforeNotify +setStackFramesInProjectBy f = + updateStackFrames $ \sf -> sf { stackFrame_inProject = Just $ f sf } + +updateEvent :: (Event -> Event) -> BeforeNotify +updateEvent f = beforeNotify $ \_e event -> f event + +-- | Update the 'Event' based on the original exception +-- +-- This allows updating the Event after casting to an exception type that this +-- library doesn't know about (e.g. @SqlError@). Because the result of your +-- function is itself a 'BeforeNotify', you can (and should) use other +-- helpers: +-- +-- @ +-- myBeforeNotify = +-- 'defaultBeforeNotify' +-- <> 'updateEventFromOriginalException' asSqlError +-- <> 'updateEventFromOriginalException' asHttpError +-- <> -- ... +-- +-- asSqlError :: SqlError -> BeforeNotify +-- asSqlError SqlError{..} = +-- 'setGroupingHash' sqlErrorCode <> 'updateException' (\e -> e +-- { exception_errorClass = sqlErrorCode +-- , exception_message = Just sqlErrorMessage +-- }) +-- @ +-- +-- If the cast fails, the event is unchanged. +-- +updateEventFromOriginalException + :: forall e . Exception.Exception e => (e -> BeforeNotify) -> BeforeNotify +updateEventFromOriginalException f = beforeNotify $ \e event -> + let bn = maybe mempty f $ Exception.fromException $ Exception.toException e + in runBeforeNotify bn e event + +setGroupingHash :: Text -> BeforeNotify +setGroupingHash hash = setGroupingHashBy $ const $ Just hash + +setGroupingHashBy :: (Event -> Maybe Text) -> BeforeNotify +setGroupingHashBy f = + updateEvent $ \event -> event { event_groupingHash = f event } + +-- | Set the Event's Context +setContext :: Text -> BeforeNotify +setContext context = + updateEvent $ \event -> event { event_context = Just context } + +-- | Set the Event's Request +-- +-- See 'bugsnagRequestFromWaiRequest' +-- +setRequest :: Request -> BeforeNotify +setRequest request = + updateEvent $ \event -> event { event_request = Just request } + +-- | Set the Event's Device +-- +-- See 'bugsnagDeviceFromWaiRequest' +-- +setDevice :: Device -> BeforeNotify +setDevice device = updateEvent $ \event -> event { event_device = Just device } + +-- | Set to 'ErrorSeverity' +setErrorSeverity :: BeforeNotify +setErrorSeverity = setSeverity errorSeverity + +-- | Set to 'WarningSeverity' +setWarningSeverity :: BeforeNotify +setWarningSeverity = setSeverity warningSeverity + +-- | Set to 'InfoSeverity' +setInfoSeverity :: BeforeNotify +setInfoSeverity = setSeverity infoSeverity + +setSeverity :: Severity -> BeforeNotify +setSeverity severity = + updateEvent $ \event -> event { event_severity = Just severity } diff --git a/src/Network/Bugsnag/CodeIndex.hs b/src/Network/Bugsnag/CodeIndex.hs new file mode 100644 --- /dev/null +++ b/src/Network/Bugsnag/CodeIndex.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +-- | Compile-time snapshot of your project source +-- +-- This is necessary to attach source code snippets to exceptions reported to +-- Bugsnag. We do this by reading the project source at compile-time and +-- stashing the result in 'Settings'. +-- +-- **WARNING**: This feature (probably) means you will be holding all indexed +-- source code in memory during the life of your process. And in larger +-- projects, it will embed substantial amounts of source code in a single file, +-- which can significantly degrade compilation time. +-- +module Network.Bugsnag.CodeIndex + ( CodeIndex + , buildCodeIndex + , findSourceRange + ) where + +import Prelude + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Traversable (for) +import Instances.TH.Lift () +import Language.Haskell.TH.Syntax +import System.FilePath.Glob (glob) + +newtype CodeIndex = CodeIndex + { unCodeIndex :: Map FilePath FileIndex + } + deriving stock (Lift, Show) + +buildCodeIndex :: String -> Q Exp +buildCodeIndex p = do + index <- qRunIO $ buildCodeIndex' p + [|index|] + +buildCodeIndex' :: String -> IO CodeIndex +buildCodeIndex' p = do + paths <- glob p + CodeIndex . Map.fromList <$> traverse indexPath paths + where + indexPath :: FilePath -> IO (FilePath, FileIndex) + indexPath fp = (fp, ) <$> buildFileIndex fp + +data FileIndex = FileIndex + { fiSourceLines :: Map Int Text + , fiLastLine :: Int + } + deriving stock (Lift, Show) + +buildFileIndex :: FilePath -> IO FileIndex +buildFileIndex path = do + lns <- T.lines <$> T.readFile path + + pure FileIndex + { fiSourceLines = Map.fromList $ zip [0 ..] lns + , fiLastLine = length lns - 1 + } + +findSourceRange :: FilePath -> (Int, Int) -> CodeIndex -> Maybe [(Int, Text)] +findSourceRange path (begin, end) index = do + FileIndex {..} <- Map.lookup path $ unCodeIndex index + + for [begin .. min end fiLastLine] + $ \n -> (n, ) <$> Map.lookup n fiSourceLines diff --git a/src/Network/Bugsnag/Device.hs b/src/Network/Bugsnag/Device.hs new file mode 100644 --- /dev/null +++ b/src/Network/Bugsnag/Device.hs @@ -0,0 +1,34 @@ +module Network.Bugsnag.Device + ( bugsnagDeviceFromUserAgent + ) where + +import Prelude + +import Data.Bugsnag +import Data.ByteString (ByteString) +import Data.Text (pack, unpack) +import Data.Version +import Text.Read (readMaybe) +import Web.UAParser + +bugsnagDeviceFromUserAgent :: ByteString -> Device +bugsnagDeviceFromUserAgent userAgent = defaultDevice + { device_osName = osrFamily <$> osResult + , device_osVersion = do + result <- osResult + v1 <- readMaybe . unpack =<< osrV1 result + v2 <- readMaybe . unpack =<< osrV2 result + v3 <- readMaybe . unpack =<< osrV3 result + v4 <- readMaybe . unpack =<< osrV4 result + pure $ pack $ showVersion $ makeVersion [v1, v2, v3, v4] + , device_browserName = uarFamily <$> uaResult + , device_browserVersion = do + result <- uaResult + v1 <- readMaybe . unpack =<< uarV1 result + v2 <- readMaybe . unpack =<< uarV2 result + v3 <- readMaybe . unpack =<< uarV3 result + pure $ pack $ showVersion $ makeVersion [v1, v2, v3] + } + where + uaResult = parseUA userAgent + osResult = parseOS userAgent diff --git a/src/Network/Bugsnag/Exception.hs b/src/Network/Bugsnag/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Network/Bugsnag/Exception.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE ExistentialQuantification #-} + +module Network.Bugsnag.Exception + ( AsException(..) + , bugsnagExceptionFromSomeException + ) where + +import Prelude + +import Control.Exception hiding (Exception) +import qualified Control.Exception as Exception +import Data.Bugsnag +import Data.Foldable (asum) +import Data.Maybe (fromMaybe) +import Data.Proxy (Proxy(..)) +import Data.Text (Text, pack) +import Data.Typeable (typeRep) +import Instances.TH.Lift () +import Network.Bugsnag.Exception.Parse + +-- | 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' +bugsnagExceptionFromSomeException :: SomeException -> Exception +bugsnagExceptionFromSomeException ex = fromMaybe fallback $ asum + [ unAsException <$> fromException ex + , bugsnagExceptionWithParser parseErrorCall <$> fromException ex + ] + where + fallback = (bugsnagExceptionWithParser parseStringException ex) + { exception_errorClass = (\(SomeException e) -> exErrorClass e) ex + } + +bugsnagExceptionWithParser + :: Exception.Exception e + => (e -> Either String MessageWithStackFrames) + -> e + -> Exception +bugsnagExceptionWithParser p ex = case p ex of + Left _ -> bugsnagExceptionFromException ex + Right (MessageWithStackFrames message stacktrace) -> defaultException + { exception_errorClass = exErrorClass ex + , exception_message = Just message + , exception_stacktrace = stacktrace + } + +bugsnagExceptionFromException :: Exception.Exception e => e -> Exception +bugsnagExceptionFromException ex = defaultException + { exception_errorClass = exErrorClass ex + , exception_message = Just $ pack $ displayException ex + , exception_stacktrace = [] + } + +-- | Show an exception's "error class" +exErrorClass :: forall e . Exception.Exception e => e -> Text +exErrorClass _ = pack $ show $ typeRep $ Proxy @e diff --git a/src/Network/Bugsnag/Exception/Parse.hs b/src/Network/Bugsnag/Exception/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Network/Bugsnag/Exception/Parse.hs @@ -0,0 +1,119 @@ +-- | +-- +-- Parse error messages for @'HasCallStack'@ information. +-- +module Network.Bugsnag.Exception.Parse + ( MessageWithStackFrames(..) + , parseErrorCall + , parseStringException + ) where + +import Prelude + +import qualified Control.Exception as Exception + (ErrorCall, Exception, SomeException) +import Control.Monad (void) +import Data.Bifunctor (first) +import Data.Bugsnag +import Data.Text (Text, pack) +import Text.Parsec +import Text.Parsec.String + +data MessageWithStackFrames = MessageWithStackFrames + { mwsfMessage :: Text + , mwsfStackFrames :: [StackFrame] + } + +-- | Parse an @'ErrorCall'@ for @'HasCallStack'@ information +parseErrorCall :: Exception.ErrorCall -> Either String MessageWithStackFrames +parseErrorCall = parse' errorCallParser + +-- | Parse a @'StringException'@ for @'HasCallStack'@ information +-- +-- We accept this as @'SomeException'@ so that this library doesn't depend on +-- any one concrete library that has @'throwString'@ (there are two right now, +-- sigh.) +-- +parseStringException + :: Exception.SomeException -> Either String MessageWithStackFrames +parseStringException = parse' stringExceptionParser + +-- brittany-disable-next-binding + +errorCallParser :: Parser MessageWithStackFrames +errorCallParser = MessageWithStackFrames + <$> messageParser + <*> manyTill stackFrameParser eof + where + messageParser :: Parser Text + messageParser = do + msg <- pack <$> manyTill anyChar eol + msg <$ (string "CallStack (from HasCallStack):" *> eol) + + stackFrameParser :: Parser StackFrame + stackFrameParser = do + func <- stackFrameFunctionTill $ string ", called at " + (path, ln, cl) <- stackFrameLocationTill $ eol <|> eof + + pure defaultStackFrame + { stackFrame_file = pack path + , stackFrame_lineNumber = ln + , stackFrame_columnNumber = Just cl + , stackFrame_method = func + , stackFrame_inProject = Just True + , stackFrame_code = Nothing + } + +-- brittany-disable-next-binding + +stringExceptionParser :: Parser MessageWithStackFrames +stringExceptionParser = MessageWithStackFrames + <$> messageParser + <*> manyTill stackFrameParser eof + where + messageParser :: Parser Text + messageParser = do + manyTill anyChar (try $ string "throwString called with:") *> eol *> eol + pack <$> manyTill anyChar (try $ eol *> string "Called from:" *> eol) + + stackFrameParser :: Parser StackFrame + stackFrameParser = do + func <- stackFrameFunctionTill $ string " (" + (path, ln, cl) <- stackFrameLocationTill $ char ')' *> eol <|> eof + + pure defaultStackFrame + { stackFrame_file = pack path + , stackFrame_lineNumber = ln + , stackFrame_columnNumber = Just cl + , stackFrame_method = func + , stackFrame_inProject = Just True + , stackFrame_code = Nothing + } + +stackFrameFunctionTill :: Parser a -> Parser Text +stackFrameFunctionTill p = spaces *> (pack <$> manyTill anyChar p) + +stackFrameLocationTill :: Parser a -> Parser (FilePath, Int, Int) +stackFrameLocationTill p = do + result <- + (,,) + <$> manyTill anyChar (char ':') + <*> (read <$> manyTill digit (char ':')) + <*> (read <$> manyTill digit (char ' ')) + + -- Ignore the "in package:module" part. TODO: we could use this to set + -- bsfInProject if we had some more knowledge about project packages. + void $ string "in " + void $ manyTill anyChar $ char ':' + void $ manyTill anyChar p + pure result + +parse' + :: Exception.Exception e + => Parser MessageWithStackFrames + -> e + -> Either String MessageWithStackFrames +parse' p = first show . parse (p <* eof) "" . show + +eol :: Parser () +eol = void endOfLine diff --git a/src/Network/Bugsnag/Notify.hs b/src/Network/Bugsnag/Notify.hs new file mode 100644 --- /dev/null +++ b/src/Network/Bugsnag/Notify.hs @@ -0,0 +1,51 @@ +module Network.Bugsnag.Notify + ( notifyBugsnag + , notifyBugsnagWith + ) where + +import Prelude + +import qualified Control.Exception as Exception +import Control.Monad (unless) +import Data.Bugsnag +import Data.Bugsnag.Settings +import Network.Bugsnag.BeforeNotify +import Network.Bugsnag.Exception +import Network.HTTP.Client.TLS (getGlobalManager) + +notifyBugsnag :: Exception.Exception e => Settings -> e -> IO () +notifyBugsnag = notifyBugsnagWith mempty + +notifyBugsnagWith + :: Exception.Exception e => BeforeNotify -> Settings -> e -> IO () +notifyBugsnagWith f settings = reportEvent settings . buildEvent bn + where bn = f <> globalBeforeNotify settings + +reportEvent :: Settings -> Event -> IO () +reportEvent Settings {..} event = unless (null $ event_exceptions event) $ do + m <- getGlobalManager + result <- sendEvents m settings_apiKey [event] + either settings_onNotifyException pure result + +buildEvent :: Exception.Exception e => BeforeNotify -> e -> Event +buildEvent bn e = runBeforeNotify bn e + $ defaultEvent { event_exceptions = [ex] } + where ex = bugsnagExceptionFromSomeException $ Exception.toException e + +globalBeforeNotify :: Settings -> BeforeNotify +globalBeforeNotify Settings {..} = + filterExceptions (not . ignoreException) + <> settings_beforeNotify + <> maybe mempty setStackFramesCode settings_codeIndex + <> updateEvent setApp + where + ignoreException e + | settings_releaseStage `notElem` settings_enabledReleaseStages = True + | otherwise = settings_ignoreException e + + setApp event = event + { event_app = Just $ defaultApp + { app_version = settings_appVersion + , app_releaseStage = Just settings_releaseStage + } + } diff --git a/src/Network/Bugsnag/StackFrame.hs b/src/Network/Bugsnag/StackFrame.hs new file mode 100644 --- /dev/null +++ b/src/Network/Bugsnag/StackFrame.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Network.Bugsnag.StackFrame + ( attachBugsnagCode + , currentStackFrame + ) where + +import Prelude + +import Data.Bugsnag +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.Text (Text, pack, unpack) +import Instances.TH.Lift () +import Language.Haskell.TH.Syntax +import Network.Bugsnag.CodeIndex + +-- | Attempt to attach code to a 'StackFrame' +-- +-- Looks up the content in the Index by File/LineNumber and, if found, sets it +-- on the record. +-- +attachBugsnagCode :: CodeIndex -> StackFrame -> StackFrame +attachBugsnagCode index sf = sf + { stackFrame_code = findBugsnagCode + (unpack $ stackFrame_file sf) + (stackFrame_lineNumber sf) + index + } + +findBugsnagCode :: FilePath -> Int -> CodeIndex -> Maybe (HashMap Int Text) +findBugsnagCode path n = fmap HashMap.fromList + . findSourceRange path (begin, n + 3) + where + begin + | n < 3 = 0 + | otherwise = n - 3 + +-- | Construct a 'StackFrame' from the point of this splice +-- +-- Unfortunately there's no way to know the function, so that must be given: +-- +currentStackFrame :: Q Exp +currentStackFrame = [|locStackFrame $(qLocation >>= liftLoc)|] + +-- brittany-disable-next-binding + +locStackFrame :: Loc -> Text -> StackFrame +locStackFrame (Loc path _ _ (ls, cs) _) func = + defaultStackFrame + { stackFrame_file = pack path + , stackFrame_lineNumber = ls + , stackFrame_columnNumber = Just cs + , stackFrame_method = func + , stackFrame_inProject = Just True + -- N.B. this assumes we're unlikely to see adoption within libraries, or + -- that such a thing would even work. If this function's used, it's + -- assumed to be in end-user code. + , stackFrame_code = Nothing + } + +-- brittany-disable-next-binding + +-- Taken from monad-logger +liftLoc :: Loc -> Q Exp +liftLoc (Loc a b c (d1, d2) (e1, e2)) = [|Loc + $(lift a) + $(lift b) + $(lift c) + ($(lift d1), $(lift d2)) + ($(lift e1), $(lift e2)) + |] diff --git a/test/Examples.hs b/test/Examples.hs new file mode 100644 --- /dev/null +++ b/test/Examples.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} + +-- | Functions that throw +-- +-- These are used in the test suite but are define here so that, hopefully, the +-- path/line/column will remain stable even if we re-organize the tests +-- themselves +-- +module Examples where + +import Prelude + +import Control.Exception +import Data.Bugsnag +import GHC.Stack (HasCallStack) +import Network.Bugsnag.Exception +import Network.Bugsnag.StackFrame +import UnliftIO.Exception (throwString) + +brokenFunctionIO :: IO a +brokenFunctionIO = throw $ AsException $ defaultException + { exception_errorClass = "IOException" + , exception_message = Just "Something exploded" + , exception_stacktrace = [$(currentStackFrame) "brokenFunctionIO"] + } + +brokenFunction :: HasCallStack => a +brokenFunction = sillyHead [] `seq` undefined + +sillyHead :: HasCallStack => [a] -> a +sillyHead (x : _) = x +sillyHead _ = error "empty list" + +brokenFunction' :: HasCallStack => IO a +brokenFunction' = sillyHead' [] + +sillyHead' :: HasCallStack => [a] -> IO a +sillyHead' (x : _) = pure x +sillyHead' _ = throwString "empty list" + +brokenFunction'' :: HasCallStack => IO a +brokenFunction'' = sillyHead'' [] + +sillyHead'' :: HasCallStack => [a] -> IO a +sillyHead'' (x : _) = pure x +sillyHead'' _ = throwString "empty list\n and message with newlines\n\n" diff --git a/test/Network/Bugsnag/BeforeNotifySpec.hs b/test/Network/Bugsnag/BeforeNotifySpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Bugsnag/BeforeNotifySpec.hs @@ -0,0 +1,44 @@ +module Network.Bugsnag.BeforeNotifySpec + ( spec + ) where + + +import Prelude + +import Control.Exception +import Data.Bugsnag hiding (Exception) +import Network.Bugsnag.BeforeNotify +import Test.Hspec + +data FooException = FooException + deriving stock Show + deriving anyclass Exception + +data BarException = BarException + deriving stock Show + deriving anyclass Exception + +data BazException = BazException + deriving stock Show + deriving anyclass Exception + +spec :: Spec +spec = do + describe "updateEventFromOriginalException" $ do + it "can update based on unknown exception types" $ do + let asFoo FooException = setGroupingHash "Saw Foo" + asBar BarException = setGroupingHash "Saw Bar" + + bn = mconcat + [ updateEventFromOriginalException asFoo + , updateEventFromOriginalException asBar + ] + + event_groupingHash (runBeforeNotify bn FooException defaultEvent) + `shouldBe` Just "Saw Foo" + + event_groupingHash (runBeforeNotify bn BarException defaultEvent) + `shouldBe` Just "Saw Bar" + + event_groupingHash (runBeforeNotify bn BazException defaultEvent) + `shouldBe` Nothing diff --git a/test/Network/Bugsnag/CodeIndexSpec.hs b/test/Network/Bugsnag/CodeIndexSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Bugsnag/CodeIndexSpec.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-missing-local-signatures #-} + +module Network.Bugsnag.CodeIndexSpec + ( spec + ) where + +import Prelude + +import Network.Bugsnag.CodeIndex +import Test.Hspec + +spec :: Spec +spec = do + describe "CodeIndex" $ do + let index = $(buildCodeIndex "test/fixtures/index-project/**/*.hs") + + it "can find ranges within the file" $ do + let path = "test/fixtures/index-project/Foo.hs" + range = (0, 3) + sourceLines = + [ (0, "module Foo where") + , (1, "") + , (2, "data What = What") + , (3, " deriving Show") + ] + + findSourceRange path range index `shouldBe` Just sourceLines + + it "handles ranges that extend beyond bounds" $ do + let path = "test/fixtures/index-project/Foo.hs" + range = (6, 10) + sourceLines = + [(6, "what 0 = Just What"), (7, "what _ = Nothing")] + + findSourceRange path range index `shouldBe` Just sourceLines + + it "handles ranges that are totally beyond bounds" $ do + let path = "test/fixtures/index-project/Foo.hs" + range = (10, 12) + + findSourceRange path range index `shouldBe` Just [] + + it "handles missing files" $ do + findSourceRange "nope.hs" (0, 3) index `shouldBe` Nothing diff --git a/test/Network/Bugsnag/DeviceSpec.hs b/test/Network/Bugsnag/DeviceSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Bugsnag/DeviceSpec.hs @@ -0,0 +1,23 @@ +module Network.Bugsnag.DeviceSpec + ( spec + ) where + +import Prelude + +import Data.Bugsnag (Device(..)) +import Network.Bugsnag.Device +import Test.Hspec + +spec :: Spec +spec = do + describe "bugsnagDeviceFromUserAgent" $ do + it "best-effort sniffs from UserAgent" $ do + let + device = + bugsnagDeviceFromUserAgent + "Mozilla/5.0 (X11; Linux x86_64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/64.0.3282.119 Safari/537.36" + + device_osName device `shouldBe` Just "Linux" + device_osVersion device `shouldBe` Nothing + device_browserName device `shouldBe` Just "Chrome" + device_browserVersion device `shouldBe` Just "64.0.3282" diff --git a/test/Network/Bugsnag/ExceptionSpec.hs b/test/Network/Bugsnag/ExceptionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Bugsnag/ExceptionSpec.hs @@ -0,0 +1,96 @@ +module Network.Bugsnag.ExceptionSpec + ( spec + ) where + +import Prelude + +import Control.Exception +import Data.Bugsnag +import Examples +import Network.Bugsnag.Exception +import Test.Hspec + +spec :: Spec +spec = do + describe "AsException" $ do + it "can throw and catch a Bugsnag.Exception" $ do + AsException ex <- brokenFunctionIO `catch` pure + + exception_errorClass ex `shouldBe` "IOException" + exception_message ex `shouldBe` Just "Something exploded" + exception_stacktrace ex `shouldSatisfy` (not . null) + + let frame = head $ exception_stacktrace ex + stackFrame_file frame `shouldBe` "test/Examples.hs" + stackFrame_lineNumber frame `shouldBe` 25 + -- different versions of GHC disagree on where splices start + stackFrame_columnNumber frame + `shouldSatisfy` (`elem` [Just 32, Just 33]) + stackFrame_method frame `shouldBe` "brokenFunctionIO" + stackFrame_inProject frame `shouldBe` Just True + + describe "bugsnagExceptionFromSomeException" $ do + it "sets errorClass" $ do + let + ex = + bugsnagExceptionFromSomeException + $ toException + $ userError "Oops" + + exception_errorClass ex `shouldBe` "IOException" + exception_message ex `shouldBe` Just "user error (Oops)" + + it "can parse errors with callstacks" $ do + e <- evaluate brokenFunction `catch` pure + + let ex = bugsnagExceptionFromSomeException e + exception_errorClass ex `shouldBe` "ErrorCall" + exception_message ex `shouldBe` Just "empty list" + exception_stacktrace ex `shouldSatisfy` ((== 3) . length) + + let frame = head $ exception_stacktrace ex + stackFrame_file frame `shouldBe` "test/Examples.hs" + stackFrame_lineNumber frame `shouldBe` 33 + stackFrame_columnNumber frame `shouldBe` Just 15 + stackFrame_method frame `shouldBe` "error" + + map stackFrame_method (exception_stacktrace ex) + `shouldBe` ["error", "sillyHead", "brokenFunction"] + + it "also parses StringException" $ do + e <- brokenFunction' `catch` pure + + let ex = bugsnagExceptionFromSomeException e + exception_errorClass ex `shouldBe` "StringException" + exception_message ex `shouldBe` Just "empty list" + exception_stacktrace ex `shouldSatisfy` ((== 3) . length) + + let frame = head $ exception_stacktrace ex + stackFrame_file frame `shouldBe` "test/Examples.hs" + stackFrame_lineNumber frame `shouldBe` 40 + stackFrame_columnNumber frame `shouldBe` Just 16 + stackFrame_method frame `shouldBe` "throwString" + + map stackFrame_method (exception_stacktrace ex) + `shouldBe` ["throwString", "sillyHead'", "brokenFunction'"] + + it "also parses StringExceptions with newlines" $ do + e <- brokenFunction'' `catch` pure + + let ex = bugsnagExceptionFromSomeException e + exception_errorClass ex `shouldBe` "StringException" + exception_message ex `shouldBe` Just + "empty list\n and message with newlines\n\n" + exception_stacktrace ex `shouldSatisfy` ((== 3) . length) + + let frame = head $ exception_stacktrace ex + stackFrame_file frame `shouldBe` "test/Examples.hs" + stackFrame_lineNumber frame `shouldBe` 47 + stackFrame_columnNumber frame `shouldBe` Just 17 + stackFrame_method frame `shouldBe` "throwString" + + map stackFrame_method (exception_stacktrace ex) + `shouldBe` [ "throwString" + , "sillyHead''" + , "brokenFunction''" + ] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -Wno-missing-export-lists #-} +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/fixtures/index-project/Foo.hs b/test/fixtures/index-project/Foo.hs new file mode 100644 --- /dev/null +++ b/test/fixtures/index-project/Foo.hs @@ -0,0 +1,8 @@ +module Foo where + +data What = What + deriving Show + +what :: Int -> Maybe What +what 0 = Just What +what _ = Nothing