packages feed

bugsnag (empty) → 1.0.0.0

raw patch · 23 files changed

+1210/−0 lines, 23 filesdep +Globdep +basedep +bugsnag

Dependencies added: Glob, base, bugsnag, bugsnag-hs, bytestring, containers, hspec, http-client, http-client-tls, parsec, template-haskell, text, th-lift-instances, ua-parser, unliftio, unordered-containers

Files

+ CHANGELOG.md view
@@ -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).
+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2022 Pat Brisbin <pbrisbin@gmail.com>++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.
+ README.md view
@@ -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)
+ bugsnag.cabal view
@@ -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
+ examples/cli/Main.hs view
@@ -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"
+ examples/simple/Main.hs view
@@ -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"]+        }
+ src/Data/Bugsnag.hs view
@@ -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
+ src/Data/Bugsnag/Settings.hs view
@@ -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+    }
+ src/Network/Bugsnag.hs view
@@ -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
+ src/Network/Bugsnag/BeforeNotify.hs view
@@ -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 }
+ src/Network/Bugsnag/CodeIndex.hs view
@@ -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
+ src/Network/Bugsnag/Device.hs view
@@ -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
+ src/Network/Bugsnag/Exception.hs view
@@ -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
+ src/Network/Bugsnag/Exception/Parse.hs view
@@ -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) "<error>" . show++eol :: Parser ()+eol = void endOfLine
+ src/Network/Bugsnag/Notify.hs view
@@ -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+            }+        }
+ src/Network/Bugsnag/StackFrame.hs view
@@ -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))+    |]
+ test/Examples.hs view
@@ -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"
+ test/Network/Bugsnag/BeforeNotifySpec.hs view
@@ -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
+ test/Network/Bugsnag/CodeIndexSpec.hs view
@@ -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
+ test/Network/Bugsnag/DeviceSpec.hs view
@@ -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"
+ test/Network/Bugsnag/ExceptionSpec.hs view
@@ -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''"+                               ]
+ test/Spec.hs view
@@ -0,0 +1,2 @@+{-# OPTIONS_GHC -Wno-missing-export-lists #-}+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/fixtures/index-project/Foo.hs view
@@ -0,0 +1,8 @@+module Foo where++data What = What+    deriving Show++what :: Int -> Maybe What+what 0 = Just What+what _ = Nothing