packages feed

bugsnag-haskell (empty) → 0.0.1.1

raw patch · 32 files changed

+1903/−0 lines, 32 filesdep +aesondep +aeson-qqdep +basesetup-changed

Dependencies added: aeson, aeson-qq, base, bugsnag-haskell, bytestring, case-insensitive, doctest, exceptions, hspec, http-client, http-client-tls, http-conduit, http-types, iproute, network, parsec, template-haskell, text, th-lift-instances, time, ua-parser, wai, warp, yesod-core

Files

+ DocTest.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Test.DocTest++main :: IO ()+main = doctest ["-isrc", "src/"]
+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2018 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bugsnag-haskell.cabal view
@@ -0,0 +1,166 @@+-- This file has been generated from package.yaml by hpack version 0.20.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: e315036e7d637c61b6993527c7d4251917c1a8ddb83239e62d20b29a5f999108++name:           bugsnag-haskell+version:        0.0.1.1+synopsis:       Bugsnag error reporter for Haskell+description:    Please see README.md+category:       Web+homepage:       https://github.com/pbrisbin/bugsnag-haskell#readme+author:         Patrick Brisbin+maintainer:     pbrisbin@gmail.com+license:        MIT+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10++flag examples+  description: Build the examples+  manual: False+  default: False++library+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      aeson+    , base >=4.8.0 && <5+    , bytestring+    , case-insensitive+    , http-client+    , http-client-tls+    , http-conduit+    , http-types+    , iproute+    , network+    , parsec+    , template-haskell+    , text+    , th-lift-instances+    , time+    , ua-parser+    , wai+  exposed-modules:+      Data.Aeson.Ext+      Network.Bugsnag+      Network.Bugsnag.App+      Network.Bugsnag.BeforeNotify+      Network.Bugsnag.Breadcrumb+      Network.Bugsnag.Device+      Network.Bugsnag.Event+      Network.Bugsnag.Exception+      Network.Bugsnag.Exception.Parse+      Network.Bugsnag.Notifier+      Network.Bugsnag.Notify+      Network.Bugsnag.ReleaseStage+      Network.Bugsnag.Report+      Network.Bugsnag.Reporter+      Network.Bugsnag.Request+      Network.Bugsnag.Session+      Network.Bugsnag.Settings+      Network.Bugsnag.Severity+      Network.Bugsnag.StackFrame+      Network.Bugsnag.Thread+      Network.Bugsnag.User+  other-modules:+      Paths_bugsnag_haskell+  default-language: Haskell2010++executable example-cli+  main-is: Main.hs+  hs-source-dirs:+      examples/cli+  ghc-options: -Wall+  build-depends:+      base >=4.8.0 && <5+    , bugsnag-haskell+  if !(flag(examples))+    buildable: False+  other-modules:+      Paths_bugsnag_haskell+  default-language: Haskell2010++executable example-simple+  main-is: Main.hs+  hs-source-dirs:+      examples/simple+  ghc-options: -Wall+  build-depends:+      base >=4.8.0 && <5+    , bugsnag-haskell+  if !(flag(examples))+    buildable: False+  other-modules:+      Paths_bugsnag_haskell+  default-language: Haskell2010++executable example-warp+  main-is: Main.hs+  hs-source-dirs:+      examples/warp+  ghc-options: -Wall+  build-depends:+      base >=4.8.0 && <5+    , bugsnag-haskell+    , wai+    , warp+  if !(flag(examples))+    buildable: False+  other-modules:+      Paths_bugsnag_haskell+  default-language: Haskell2010++executable example-yesod+  main-is: Main.hs+  hs-source-dirs:+      examples/yesod+  ghc-options: -Wall+  build-depends:+      base >=4.8.0 && <5+    , bugsnag-haskell+    , exceptions+    , wai+    , warp+    , yesod-core+  if !(flag(examples))+    buildable: False+  other-modules:+      Paths_bugsnag_haskell+  default-language: Haskell2010++test-suite doctest+  type: exitcode-stdio-1.0+  main-is: DocTest.hs+  hs-source-dirs:+      ./.+  ghc-options: -Wall -Wall+  build-depends:+      base >=4.8.0 && <5+    , doctest+  other-modules:+      Paths_bugsnag_haskell+  default-language: Haskell2010++test-suite spec+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  hs-source-dirs:+      test+  ghc-options: -Wall+  build-depends:+      aeson+    , aeson-qq+    , base >=4.8.0 && <5+    , bugsnag-haskell+    , hspec+    , text+    , time+  other-modules:+      Network.Bugsnag.ReportSpec+      Network.BugsnagSpec+      Paths_bugsnag_haskell+  default-language: Haskell2010
+ examples/cli/Main.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE OverloadedStrings #-}+module Main (main) where++import Control.Exception (catch)+import Network.Bugsnag+import System.Exit (die)++main :: IO ()+main = do+    settings <- newBugsnagSettings "BUGSNAG_API_KEY"++    appMain `catch` \ex -> do+        notifyBugsnag settings ex+        die $ show ex++-- Actual program logic+appMain :: IO ()+appMain = error "Whoops"
+ examples/simple/Main.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+module Main (main) where++import Control.Exception (toException)+import Network.Bugsnag++main :: IO ()+main = do+    settings <- newBugsnagSettings "BUGSNAG_API_KEY"++    notifyBugsnag settings $ toException+        $ bugsnagException "Error" "message"+            [ $(currentStackFrame) "myFunction"+            ]
+ examples/warp/Main.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings #-}+module Main (main) where++import Control.Concurrent (forkIO)+import Control.Exception (SomeException)+import Control.Monad (void, when)+import Network.Bugsnag+import Network.Wai (Application, Request)+import Network.Wai.Handler.Warp++app :: Application+app = error "Oops"++warpSettings :: IO Settings+warpSettings = do+    settings <- newBugsnagSettings "BUGSNAG_API_KEY"++    pure+        $ setPort 3000+        $ setOnException (bugsnagOnException settings) defaultSettings++-- N.B. This may some day be provided by a bugsnag-warp package+bugsnagOnException :: BugsnagSettings -> Maybe Request -> SomeException -> IO ()+bugsnagOnException settings mRequest ex =+    when (defaultShouldDisplayException ex) $ do+        let beforeNotify = maybe id updateEventFromWaiRequest mRequest+        void $ forkIO $ notifyBugsnagWith beforeNotify settings ex++main :: IO ()+main = do+    settings <- warpSettings+    runSettings settings app
+ examples/yesod/Main.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}+module Main (main) where++import Control.Exception (SomeException, fromException, toException)+import Control.Monad (unless)+import Control.Monad.Catch (catch, throwM)+import Network.Bugsnag+import Network.Wai.Handler.Warp (run)+import Yesod.Core+import Yesod.Core.Types (HandlerContents)++newtype App = App { appBugsnag :: BugsnagSettings }+mkYesod "App" [parseRoutes|/ RootR GET|]++getRootR :: Handler Html+getRootR = error "Boom"++instance Yesod App where+    defaultLayout _widget = withUrlRenderer [hamlet|<html>|]++    -- N.B. yesodMiddleware is the only way to handle things as actual+    -- exceptions. The alternative, using errorHandler, means you would only+    -- ever see  an "InternalError Text" value.+    --+    -- The main downside to this middleware is that short-circuit responses also+    -- come through the middleware as exceptions, and must be filtered. Unless+    -- of course you want to notify Bugsnag of 404s and such.+    yesodMiddleware = bugsnagYesodMiddleware . defaultYesodMiddleware++-- This may be provided by a bugsnag-yesod package some day+bugsnagYesodMiddleware :: Handler a -> Handler a+bugsnagYesodMiddleware handler = do+    settings <- getsYesod appBugsnag+    request <- waiRequest++    handler `catch` \ex -> do+        unless (isHandlerContents ex)+            $ forkHandler (const $ pure ()) $ liftIO+            $ notifyBugsnagWith (updateEventFromWaiRequest request) settings ex+        throwM $ toException ex+  where+    isHandlerContents :: SomeException -> Bool+    isHandlerContents ex =+        case (fromException ex :: Maybe HandlerContents) of+            Just _ -> True+            Nothing -> False++main :: IO ()+main = do+    appBugsnag <- newBugsnagSettings "BUGSNAG_API_KEY"++    -- N.B. You should also consider setting Warp's onException+    run 3000 =<< toWaiApp App{..}
+ src/Data/Aeson/Ext.hs view
@@ -0,0 +1,52 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+--+-- Orphan instances and shared @'Generic'@ JSON options.+--+module Data.Aeson.Ext+    ( bsAesonOptions+    ) where++import Data.Aeson+import Data.ByteString (ByteString)+import Data.CaseInsensitive (CI)+import qualified Data.CaseInsensitive as CI+import Data.Char (toLower)+import Data.List (stripPrefix)+import Data.Maybe (fromMaybe)+import Data.Text.Encoding (decodeUtf8)++instance ToJSON ByteString where+    toJSON = String . decodeUtf8++instance ToJSON a => ToJSON (CI a) where+    toJSON = toJSON . CI.original++-- | Our custom Aeson @'Options'@+--+-- Omits @'Nothing'@ fields, and drops/lowers accordingly:+--+-- >>> fieldLabelModifier (bsAesonOptions "bs") "bsReleaseStage"+-- "releaseStage"+--+-- For sums, the first argument is taken as a suffix:+--+-- >>> constructorTagModifier (bsAesonOptions "ReasonType") "UnhandledExceptionReasonType"+-- "unhandledException"+--+bsAesonOptions :: String -> Options+bsAesonOptions prefixOrSuffix = defaultOptions+    { fieldLabelModifier = lowerFirst . dropPrefix prefixOrSuffix+    , constructorTagModifier = lowerFirst . dropSuffix prefixOrSuffix+    , omitNothingFields = True+    }++dropPrefix :: String -> String -> String+dropPrefix prefix x = fromMaybe x $ stripPrefix prefix x++dropSuffix :: String -> String -> String+dropSuffix prefix = reverse . dropPrefix (reverse prefix) . reverse++lowerFirst :: String -> String+lowerFirst [] = []+lowerFirst (x:rest) = toLower x : rest
+ src/Network/Bugsnag.hs view
@@ -0,0 +1,34 @@+-- |+--+-- Module: Network.Bugsnag+-- Description: Haskell notifier for Bugsnag+-- Copyright: Patrick Brisbin, 2018+-- License: MIT+-- Maintainer: pbrisbin@gmail.com+-- Stability: experimental+-- Portability: POSIX+--+-- For examples, see <https://github.com/pbrisbin/bugsnag-haskell#examples>.+--+module Network.Bugsnag+    ( module X+    ) where++import Network.Bugsnag.App as X+import Network.Bugsnag.BeforeNotify as X+import Network.Bugsnag.Breadcrumb as X+import Network.Bugsnag.Device as X+import Network.Bugsnag.Event as X+import Network.Bugsnag.Exception as X+import Network.Bugsnag.Notifier as X+import Network.Bugsnag.Notify as X+import Network.Bugsnag.ReleaseStage as X+import Network.Bugsnag.Report as X+import Network.Bugsnag.Reporter as X+import Network.Bugsnag.Request as X+import Network.Bugsnag.Session as X+import Network.Bugsnag.Settings as X+import Network.Bugsnag.Severity as X+import Network.Bugsnag.StackFrame as X+import Network.Bugsnag.Thread as X+import Network.Bugsnag.User as X
+ src/Network/Bugsnag/App.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE DeriveGeneric #-}+module Network.Bugsnag.App+    ( BugsnagApp(..)+    , bugsnagApp+    ) where++import Data.Aeson+import Data.Aeson.Ext+import Data.Text (Text)+import Data.Version+import GHC.Generics+import Network.Bugsnag.ReleaseStage+import Numeric.Natural++data BugsnagApp = BugsnagApp+    { baId :: Maybe Text+    , baVersion :: Maybe Version+    , baBuildUUID :: Maybe Text+    , baReleaseStage :: Maybe BugsnagReleaseStage+    , baType :: Maybe Text+    , baDsymUUIDs :: Maybe [Text]+    , baDuration :: Maybe Natural+    , baDurationInForeground :: Maybe Natural+    , baInForeground :: Maybe Bool+    }+    deriving Generic++instance ToJSON BugsnagApp where+    toJSON = genericToJSON $ bsAesonOptions "ba"+    toEncoding = genericToEncoding $ bsAesonOptions "ba"++bugsnagApp :: BugsnagApp+bugsnagApp = BugsnagApp+    { baId = Nothing+    , baVersion = Nothing+    , baBuildUUID = Nothing+    , baReleaseStage = Nothing+    , baType = Nothing+    , baDsymUUIDs = Nothing+    , baDuration = Nothing+    , baDurationInForeground = Nothing+    , baInForeground = Nothing+    }
+ src/Network/Bugsnag/BeforeNotify.hs view
@@ -0,0 +1,109 @@+module Network.Bugsnag.BeforeNotify+    ( BeforeNotify++    -- * Modifying the Exception+    , updateException++    -- * Modifying the Event+    , updateEventFromSession+    , updateEventFromWaiRequest++    -- * Simple setters+    , setDevice+    , setRequest+    , setStacktrace++    -- * Setting severity+    , setWarningSeverity+    , setErrorSeverity+    , setInfoSeverity+    ) where++import Network.Bugsnag.Device+import Network.Bugsnag.Event+import Network.Bugsnag.Exception+import Network.Bugsnag.Request+import Network.Bugsnag.Session+import Network.Bugsnag.Severity+import Network.Bugsnag.StackFrame+import Network.Wai (Request)++type BeforeNotify = BugsnagEvent -> BugsnagEvent++-- | Modify just the Exception part of an Event+--+-- Technically this will modify all exceptions in the Event, but if you're using+-- this library normally, there will be only one.+--+-- This may be used to set more specific information for exception types in+-- scope in your application:+--+-- > notifyBugsnagWith (updateException forSqlError) settings ex+-- >+-- > forSqlError :: BugsnagException -> BugsnagException+-- > forSqlError ex = case fromException @SqlError ex of+-- >     Just SqlError{..} -> ex+-- >         { beErrorClass = "SqlError-" <> sqlErrorCode+-- >         , beMessage = sqlErrorMessage+-- >         }+--+updateException :: (BugsnagException -> BugsnagException) -> BeforeNotify+updateException f event = event+    { beExceptions = f <$> beExceptions event+    }++-- | Set the events @'BugsnagEvent'@ and @'BugsnagDevice'@+updateEventFromWaiRequest :: Request -> BeforeNotify+updateEventFromWaiRequest wrequest =+    let mdevice = bugsnagDeviceFromWaiRequest wrequest+        request = bugsnagRequestFromWaiRequest wrequest+    in maybe id setDevice mdevice . setRequest request++-- | Update the Event's Context and User from the Session+updateEventFromSession :: BugsnagSession -> BeforeNotify+updateEventFromSession session event = event+    { beContext = bsContext session+    , beUser = bsUser session+    }++-- | Set the Event's Request+--+-- See @'bugsnagRequestFromWaiRequest'@+--+setRequest :: BugsnagRequest -> BeforeNotify+setRequest request event = event+    { beRequest = Just request+    }++-- | Set the Event's Device+--+-- See @'bugsnagDeviceFromWaiRequest'@+--+setDevice :: BugsnagDevice -> BeforeNotify+setDevice device event = event+    { beDevice = Just device+    }++-- | Set the stacktrace on the reported exception+--+-- > notifyBugsnagWith (setStacktrace [$(currentStackFrame) "myFunc"]) ...+--+setStacktrace :: [BugsnagStackFrame] -> BeforeNotify+setStacktrace stacktrace = updateException $ \ex -> ex+    { beStacktrace = stacktrace+    }++-- | 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 :: BugsnagSeverity -> BeforeNotify+setSeverity severity event = event { beSeverity = Just severity }
+ src/Network/Bugsnag/Breadcrumb.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+module Network.Bugsnag.Breadcrumb+    ( BugsnagBreadcrumbType(..)+    , BugsnagBreadcrumb(..)+    , bugsnagBreadcrumb+    ) where++import Data.Aeson+import Data.Aeson.Ext+import Data.Text (Text)+import Data.Time+import GHC.Generics++data BugsnagBreadcrumbType+    = NavigationBreadcrumb+    | RequestBreadcrumb+    | ProcessBreadcrumb+    | LogBreadcrumb+    | UserBreadcrumb+    | StateBreadcrumb+    | ErrorBreadcrumb+    | ManualBreadcrumb+    deriving Generic++instance ToJSON BugsnagBreadcrumbType where+    toJSON = genericToJSON $ bsAesonOptions "Breadcrumb"+    toEncoding = genericToEncoding $ bsAesonOptions "Breadcrumb"++data BugsnagBreadcrumb = BugsnagBreadcrumb+    { bbTimestamp :: UTCTime+    , bbName :: Text+    , bbType :: BugsnagBreadcrumbType+    , bbMetaData :: Maybe Value+    }+    deriving Generic++instance ToJSON BugsnagBreadcrumb where+    toJSON = genericToJSON $ bsAesonOptions "bb"+    toEncoding = genericToEncoding $ bsAesonOptions "bb"++bugsnagBreadcrumb+    :: UTCTime+    -> Text+    -> BugsnagBreadcrumbType+    -> BugsnagBreadcrumb+bugsnagBreadcrumb timestamp name typ = BugsnagBreadcrumb+    { bbTimestamp = timestamp+    , bbName = name+    , bbType = typ+    , bbMetaData = Nothing+    }
+ src/Network/Bugsnag/Device.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+module Network.Bugsnag.Device+    ( Bytes(..)+    , BugsnagDevice(..)+    , bugsnagDevice+    , bugsnagDeviceFromWaiRequest+    ) where++import Data.Aeson+import Data.Aeson.Ext+import Data.ByteString (ByteString)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Version+import GHC.Generics+import Network.Wai+import Numeric.Natural+import Text.Read (readMaybe)+import Web.UAParser++newtype Bytes = Bytes Natural deriving ToJSON++data BugsnagDevice = BugsnagDevice+    { bdHostname :: Maybe Text+    , bdId :: Maybe Text+    , bdManufacturer :: Maybe Text+    , bdModel :: Maybe Text+    , bdModelNumber :: Maybe Text+    , bdOsName :: Maybe Text+    , bdOsVersion :: Maybe Version+    , bdFreeMemory :: Maybe Bytes+    , bdTotalMemory :: Maybe Bytes+    , bdFreeDisk :: Maybe Bytes+    , bdBrowserName :: Maybe Text+    , bdBrowserVersion :: Maybe Version+    , bdJailBroken :: Maybe Bool+    , bdOrientation :: Maybe Text+    }+    deriving Generic++instance ToJSON BugsnagDevice where+    toJSON = genericToJSON $ bsAesonOptions "bd"+    toEncoding = genericToEncoding $ bsAesonOptions "bd"++bugsnagDevice :: BugsnagDevice+bugsnagDevice = BugsnagDevice+    { bdHostname = Nothing+    , bdId = Nothing+    , bdManufacturer = Nothing+    , bdModel = Nothing+    , bdModelNumber = Nothing+    , bdOsName = Nothing+    , bdOsVersion = Nothing+    , bdFreeMemory = Nothing+    , bdTotalMemory = Nothing+    , bdFreeDisk = Nothing+    , bdBrowserName = Nothing+    , bdBrowserVersion = Nothing+    , bdJailBroken = Nothing+    , bdOrientation = Nothing+    }++-- | /Attempt/ to divine a @'BugsnagDevice'@ from a request's User Agent+bugsnagDeviceFromWaiRequest :: Request -> Maybe BugsnagDevice+bugsnagDeviceFromWaiRequest request = do+    userAgent <- lookup "User-Agent" $ requestHeaders request+    pure $ bugsnagDeviceFromUserAgent userAgent++-- |+--+-- >>> device = bugsnagDeviceFromUserAgent "Mozilla/5.0 (X11; Linux x86_64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/64.0.3282.119 Safari/537.36"+-- >>> bdOsName device+-- Just "Linux"+--+-- N.B. we always return a Device, it may just be lacking some or all fields.+--+-- >>> showVersion <$> bdOsVersion device+-- Nothing+--+-- >>> bdBrowserName device+-- Just "Chrome"+--+-- >>> showVersion <$> bdBrowserVersion device+-- Just "64.0.3282"+--+bugsnagDeviceFromUserAgent :: ByteString -> BugsnagDevice+bugsnagDeviceFromUserAgent userAgent = bugsnagDevice+    { bdOsName = osrFamily <$> osResult+    , bdOsVersion = do+        result <- osResult+        v1 <- readMaybe . T.unpack =<< osrV1 result+        v2 <- readMaybe . T.unpack =<< osrV2 result+        v3 <- readMaybe . T.unpack =<< osrV3 result+        v4 <- readMaybe . T.unpack =<< osrV4 result+        pure $ makeVersion [v1, v2, v3, v4]+    , bdBrowserName = uarFamily <$> uaResult+    , bdBrowserVersion = do+        result <- uaResult+        v1 <- readMaybe . T.unpack =<< uarV1 result+        v2 <- readMaybe . T.unpack =<< uarV2 result+        v3 <- readMaybe . T.unpack =<< uarV3 result+        pure $ makeVersion [v1, v2, v3]+    }+  where+    uaResult = parseUA userAgent+    osResult = parseOS userAgent
+ src/Network/Bugsnag/Event.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+module Network.Bugsnag.Event+    ( BugsnagEvent(..)+    , bugsnagEvent+    ) where++import Data.Aeson+import Data.Aeson.Ext+import Data.List.NonEmpty (NonEmpty)+import Data.Text (Text)+import GHC.Generics+import Network.Bugsnag.App+import Network.Bugsnag.Breadcrumb+import Network.Bugsnag.Device+import Network.Bugsnag.Exception+import Network.Bugsnag.Request+import Network.Bugsnag.Severity+import Network.Bugsnag.Thread+import Network.Bugsnag.User++data BugsnagEvent = BugsnagEvent+    { beExceptions :: NonEmpty BugsnagException+    , beBreadcrumbs :: Maybe [BugsnagBreadcrumb]+    , beRequest :: Maybe BugsnagRequest+    , beThreads :: Maybe [BugsnagThread]+    , beContext :: Maybe Text+    , beGroupingHash :: Maybe Text+    , beUnhandled :: Maybe Bool+    , beSeverity :: Maybe BugsnagSeverity+    , beSeverityReason :: Maybe BugsnagSeverityReason+    , beUser :: Maybe BugsnagUser+    , beApp :: Maybe BugsnagApp+    , beDevice :: Maybe BugsnagDevice+    --, beSession+    -- N.B. omitted because it's an object specific to the Session Tracking API,+    -- and I'm not sure yet how to resolve the naming clash with BugsnagSession.+    , beMetaData :: Maybe Value+    }+    deriving Generic++instance ToJSON BugsnagEvent where+    toJSON = genericToJSON $ bsAesonOptions "be"+    toEncoding = genericToEncoding $ bsAesonOptions "be"++bugsnagEvent :: NonEmpty BugsnagException -> BugsnagEvent+bugsnagEvent exceptions = BugsnagEvent+    { beExceptions = exceptions+    , beBreadcrumbs = Nothing+    , beRequest = Nothing+    , beThreads = Nothing+    , beContext = Nothing+    , beGroupingHash = Nothing+    , beUnhandled = Nothing+    , beSeverity = Nothing+    , beSeverityReason = Nothing+    , beUser = Nothing+    , beApp = Nothing+    , beDevice = Nothing+    , beMetaData = Nothing+    }
+ src/Network/Bugsnag/Exception.hs view
@@ -0,0 +1,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 (bugsnagExceptionFromException ex) exCasters+  where+    go :: Caster -> BugsnagException -> BugsnagException+    go (Caster caster) res = maybe res caster $ fromException ex++exCasters :: [Caster]+exCasters =+    [ Caster id+    , Caster bugsnagExceptionFromErrorCall+    , 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+    ]++-- | Construct a @'BugsnagException'@ from an @'ErrorCall'@+--+-- This type of exception may have @'HasCallStack'@ information.+--+bugsnagExceptionFromErrorCall :: ErrorCall -> BugsnagException+bugsnagExceptionFromErrorCall ex =+    case parseErrorCall 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
+ src/Network/Bugsnag/Exception/Parse.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedStrings #-}+-- |+--+-- Parse error messages for @'HasCallStack'@ information.+--+module Network.Bugsnag.Exception.Parse+    ( MessageWithStackFrames(..)+    , parseErrorCall+    ) where++import Control.Exception (ErrorCall)+import Control.Monad (void)+import Data.Bifunctor (first)+import Data.Text (Text)+import qualified Data.Text as T+import Network.Bugsnag.StackFrame+import Text.Parsec+import Text.Parsec.String++data MessageWithStackFrames = MessageWithStackFrames+    { mwsfMessage :: Text+    , mwsfStackFrames :: [BugsnagStackFrame]+    }++-- | Parse an @'ErrorCall'@ for @'HasCallStack'@ information+parseErrorCall :: ErrorCall -> Either String MessageWithStackFrames+parseErrorCall = first show . parse (errorCallParser <* eof) "<error>" . show++errorCallParser :: Parser MessageWithStackFrames+errorCallParser = MessageWithStackFrames+    <$> (T.pack <$> manyTill anyChar eol)+    <*> (csHeader *> manyTill stackFrameParser eof)++csHeader :: Parser ()+csHeader = string "CallStack (from HasCallStack):" *> eol++stackFrameParser :: Parser BugsnagStackFrame+stackFrameParser = do+    func <- spaces *> (T.pack <$> manyTill anyChar (char ','))+    path <- string " called at " *> manyTill anyChar (char ':')+    ln <- read <$> manyTill digit (char ':')+    cl <- read <$> manyTill digit (char ' ')++    void $ string "in " -- package:module+    void $ manyTill anyChar $ char ':'+    void $ manyTill anyChar $ eol <|> eof++    pure BugsnagStackFrame+        { bsfFile = path+        , bsfLineNumber = ln+        , bsfColumnNumber = Just cl+        , bsfMethod = func+        , bsfInProject = Just True+        , bsfCode = Nothing+        }++eol :: Parser ()+eol = void endOfLine
+ src/Network/Bugsnag/Notifier.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+-- |+--+-- Static values about this notifier itself.+--+module Network.Bugsnag.Notifier+    ( BugsnagNotifier+    , bugsnagNotifier+    ) where++import Data.Aeson+import Data.Aeson.Ext+import Data.Text (Text)+import Data.Version+import GHC.Generics++import qualified Paths_bugsnag_haskell as Pkg++data BugsnagNotifier = BugsnagNotifier+    { bnName :: Text+    , bnVersion :: Version+    , bnUrl :: Text+    }+    deriving Generic++instance ToJSON BugsnagNotifier where+    toJSON = genericToJSON $ bsAesonOptions "bn"+    toEncoding = genericToEncoding $ bsAesonOptions "bn"++bugsnagNotifier :: BugsnagNotifier+bugsnagNotifier = BugsnagNotifier+    { bnName = "bugsnag-haskell"+    , bnVersion = Pkg.version+    , bnUrl = "https://github.com/pbrisbin/bugsnag-haskell"+    }
+ src/Network/Bugsnag/Notify.hs view
@@ -0,0 +1,81 @@+module Network.Bugsnag.Notify+    ( notifyBugsnag+    , notifyBugsnagWith+    ) where++import Control.Exception (SomeException)+import Control.Monad (when)+import Network.Bugsnag.App+import Network.Bugsnag.BeforeNotify+import Network.Bugsnag.Event+import Network.Bugsnag.Exception+import Network.Bugsnag.Report+import Network.Bugsnag.Reporter+import Network.Bugsnag.Settings+import Network.Bugsnag.StackFrame++-- | Notify Bugsnag of a single exception+notifyBugsnag :: BugsnagSettings -> SomeException -> IO ()+notifyBugsnag = notifyBugsnagWith id++-- | Notify Bugsnag of a single exception, modifying the event+--+-- This is used to (e.g.) change severity for a specific error. Note that the+-- given function runs after any configured @'bsBeforeNotify'@, or changes+-- caused by other aspects of settings (e.g. grouping hash).+--+notifyBugsnagWith :: BeforeNotify -> BugsnagSettings -> SomeException -> IO ()+notifyBugsnagWith f settings ex = do+    let exception = bugsnagExceptionFromSomeException ex++    -- N.B. all notify functions should go through here. We need to maintain+    -- this as the single point where (e.g.) should-notify is checked,+    -- before-notify is applied, stack-frame filtering, etc.+    when (bugsnagShouldNotify settings exception) $ do+        let event+                = f+                . bsBeforeNotify settings+                . updateGroupingHash settings+                . updateStackFramesInProject settings+                . filterStackFrames settings+                . createApp settings+                . bugsnagEvent+                $ pure exception++            manager = bsHttpManager settings+            apiKey = bsApiKey settings+            report = bugsnagReport [event]++        reportError manager apiKey report++updateGroupingHash :: BugsnagSettings -> BeforeNotify+updateGroupingHash settings event = event+    { beGroupingHash = bsGroupingHash settings event+    }++updateStackFramesInProject :: BugsnagSettings -> BeforeNotify+updateStackFramesInProject settings = updateException $ \ex -> ex+    { beStacktrace = map updateStackFrames $ beStacktrace ex+    }+  where+    updateStackFrames :: BugsnagStackFrame -> BugsnagStackFrame+    updateStackFrames sf = sf+        { bsfInProject = Just $ bsIsInProject settings $ bsfFile sf+        }++filterStackFrames :: BugsnagSettings -> BeforeNotify+filterStackFrames settings = updateException $ \ex -> ex+    { beStacktrace = filter (bsFilterStackFrames settings) $ beStacktrace ex+    }++-- |+--+-- N.B. safe to clobber because we're only used on a fresh event.+--+createApp :: BugsnagSettings -> BeforeNotify+createApp settings event = event+    { beApp = Just $ bugsnagApp+        { baVersion = bsAppVersion settings+        , baReleaseStage = Just $ bsReleaseStage settings+        }+    }
+ src/Network/Bugsnag/ReleaseStage.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+module Network.Bugsnag.ReleaseStage+    ( BugsnagReleaseStage(..)+    ) where++import Data.Aeson+import Data.Text (Text)++data BugsnagReleaseStage+    = DevelopmentReleaseStage+    | StagingReleaseStage+    | ProductionReleaseStage+    | CustomReleaseStage Text+    deriving (Eq, Show)++instance FromJSON BugsnagReleaseStage where+    parseJSON = withText "ReleaseStage" $ \case+        "development" -> pure DevelopmentReleaseStage+        "staging" -> pure StagingReleaseStage+        "production" -> pure ProductionReleaseStage+        t -> pure $ CustomReleaseStage t++instance ToJSON BugsnagReleaseStage where+    toJSON DevelopmentReleaseStage = String "development"+    toJSON StagingReleaseStage = String "staging"+    toJSON ProductionReleaseStage = String "production"+    toJSON (CustomReleaseStage t) = String t
+ src/Network/Bugsnag/Report.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE DeriveGeneric #-}+module Network.Bugsnag.Report+    ( BugsnagReport(..)+    , bugsnagReport+    ) where++import Data.Aeson+import Data.Aeson.Ext+import GHC.Generics+import Network.Bugsnag.Event+import Network.Bugsnag.Notifier++data BugsnagReport = BugsnagReport+    { brNotifier :: BugsnagNotifier+    , brEvents :: [BugsnagEvent]+    }+    deriving Generic++instance ToJSON BugsnagReport where+    toJSON = genericToJSON $ bsAesonOptions "br"+    toEncoding = genericToEncoding $ bsAesonOptions "br"++bugsnagReport :: [BugsnagEvent] -> BugsnagReport+bugsnagReport events = BugsnagReport+    { brNotifier = bugsnagNotifier+    , brEvents = events+    }
+ src/Network/Bugsnag/Reporter.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE OverloadedStrings #-}+-- |+--+-- Report an error to Bugsnag+--+-- <https://bugsnagerrorreportingapi.docs.apiary.io/#reference/0/notify/send-error-reports>+--+-- This is the lowest level interface, where you're required to provide all+-- payload data explicitly, as well as a TLS-enabled @'Manager'@+--+module Network.Bugsnag.Reporter+    ( reportError+    ) where++import Control.Monad (void)+import Data.Text.Encoding (encodeUtf8)+import Network.Bugsnag.Report+import Network.Bugsnag.Settings+import Network.HTTP.Client+import Network.HTTP.Simple (setRequestBodyJSON, setRequestHeader)++reportError :: Manager -> BugsnagApiKey -> BugsnagReport -> IO ()+reportError manager apiKey report = do+    request <- setupRequest <$> parseRequest "POST https://notify.bugsnag.com"+    void $ httpNoBody request manager+  where+    key = encodeUtf8 $ unBugsnagApiKey apiKey+    setupRequest+        = setRequestBodyJSON report+        . setRequestHeader "Bugsnag-Api-Key" [key]+        . setRequestHeader "Bugsnag-Payload-Version" ["4"]
+ src/Network/Bugsnag/Request.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+module Network.Bugsnag.Request+    ( BugsnagRequest(..)+    , bugsnagRequest+    , bugsnagRequestFromWaiRequest+    ) where++import Control.Applicative ((<|>))+import Data.Aeson+import Data.Aeson.Ext+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as C8+import Data.IP+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import GHC.Generics+import Network.HTTP.Types+import Network.Socket+import Network.Wai++-- | The web request being handled when the error was encountered+data BugsnagRequest = BugsnagRequest+    { brClientIp :: Maybe ByteString+    , brHeaders :: Maybe RequestHeaders+    , brHttpMethod :: Maybe Method+    , brUrl :: Maybe ByteString+    , brReferer :: Maybe ByteString+    }+    deriving Generic++instance ToJSON BugsnagRequest where+    toJSON = genericToJSON $ bsAesonOptions "br"+    toEncoding = genericToEncoding $ bsAesonOptions "br"++-- | Constructs an empty @'BugsnagRequest'@+bugsnagRequest :: BugsnagRequest+bugsnagRequest = BugsnagRequest+    { brClientIp = Nothing+    , brHeaders = Nothing+    , brHttpMethod = Nothing+    , brUrl = Nothing+    , brReferer = Nothing+    }++-- | Constructs a @'BugsnagRequest'@ from a WAI @'Request'@+bugsnagRequestFromWaiRequest :: Request -> BugsnagRequest+bugsnagRequestFromWaiRequest request = bugsnagRequest+    { brClientIp = requestRealIp request+        <|> Just (sockAddrToIp $ remoteHost request)+    , brHeaders = Just $ requestHeaders request+    , brHttpMethod = Just $ requestMethod request+    , brUrl = Just $ requestUrl request+    , brReferer = requestHeaderReferer request+    }++requestRealIp :: Request -> Maybe ByteString+requestRealIp request = requestForwardedFor request+    <|> lookup "X-Real-IP" (requestHeaders request)++requestForwardedFor :: Request -> Maybe ByteString+requestForwardedFor request = readForwardedFor+    =<< lookup "X-Forwarded-For" (requestHeaders request)++-- |+--+-- >>> readForwardedFor ""+-- Nothing+--+-- >>> readForwardedFor "123.123.123"+-- Just "123.123.123"+--+-- >>> readForwardedFor "123.123.123, 45.45.45"+-- Just "123.123.123"+--+readForwardedFor :: ByteString -> Maybe ByteString+readForwardedFor bs+    | C8.null bs = Nothing+    | otherwise = Just $ fst $ C8.break (== ',') bs++requestUrl :: Request -> ByteString+requestUrl request = requestProtocol+    <> "://"+    <> requestHost request+    <> rawPathInfo request+    <> rawQueryString request+  where+    clientProtocol = if isSecure request then "https" else "http"+    requestHost = fromMaybe "<unknown>" . requestHeaderHost+    requestProtocol = fromMaybe clientProtocol+        $ lookup "X-Forwarded-Proto"+        $ requestHeaders request++sockAddrToIp :: SockAddr -> ByteString+sockAddrToIp (SockAddrInet _ h) = C8.pack $ show $ fromHostAddress h+sockAddrToIp (SockAddrInet6 _ _ h _) = C8.pack $ show $ fromHostAddress6 h+sockAddrToIp (SockAddrUnix _) = "<socket>"++-- N.B. Can't match deprecated SockAddrCan without warning. TODO: make patterns+-- exhaustive without a wildcard once it's actually removed.+sockAddrToIp _ = "<invalid>"
+ src/Network/Bugsnag/Session.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE DeriveGeneric #-}+-- |+--+-- <https://docs.bugsnag.com/api/error-reporting/#per-session-settings>+--+module Network.Bugsnag.Session+    ( BugsnagSession(..)+    , bugsnagSession+    ) where++import Data.Aeson+import Data.Aeson.Ext+import Data.Text (Text)+import GHC.Generics+import Network.Bugsnag.User++data BugsnagSession = BugsnagSession+    { bsUser :: Maybe BugsnagUser+    , bsContext :: Maybe Text+    , bsMetaData :: Maybe Value+    }+    deriving Generic++instance ToJSON BugsnagSession where+    toJSON = genericToJSON $ bsAesonOptions "bs"+    toEncoding = genericToEncoding $ bsAesonOptions "bs"++bugsnagSession :: BugsnagSession+bugsnagSession = BugsnagSession+    { bsUser = Nothing+    , bsContext = Nothing+    , bsMetaData = Nothing+    }
+ src/Network/Bugsnag/Settings.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- |+--+-- <https://docs.bugsnag.com/api/error-reporting/#application-settings>+--+module Network.Bugsnag.Settings+    ( BugsnagApiKey(..)+    , BugsnagSettings(..)+    , newBugsnagSettings+    , bugsnagSettings+    , bugsnagShouldNotify+    ) where++import Data.Aeson (FromJSON)+import Data.String+import Data.Text (Text)+import qualified Data.Text as T+import Data.Version+import Network.Bugsnag.BeforeNotify+import Network.Bugsnag.Event+import Network.Bugsnag.Exception+import Network.Bugsnag.ReleaseStage+import Network.Bugsnag.StackFrame+import Network.HTTP.Client+import Network.HTTP.Client.TLS++newtype BugsnagApiKey = BugsnagApiKey+    { unBugsnagApiKey :: Text+    }+    deriving (FromJSON, IsString)++instance Show BugsnagApiKey where+    show = T.unpack . unBugsnagApiKey++-- | Notifier settings+--+-- See @'newBugsnagSettings'@.+--+data BugsnagSettings = BugsnagSettings+    { bsApiKey :: BugsnagApiKey+    -- ^ Your Integration API Key.+    , bsAppVersion :: Maybe Version+    -- ^ The version of your application+    --+    -- Marking bugs as Fixed and having them auto-reopen in new versions+    -- requires you set this.+    --+    , bsReleaseStage :: BugsnagReleaseStage+    -- ^ The current release-stage, Production by default+    , bsNotifyReleaseStages :: [BugsnagReleaseStage]+    -- ^ Which release-stages to notify in. Only Production by default+    , bsBeforeNotify :: BeforeNotify+    -- ^ Modify any events before they are sent+    --+    -- For example to attach a user, or set the context.+    --+    , bsIgnoreException :: BugsnagException -> 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.+    --+    , bsGroupingHash :: BugsnagEvent -> Maybe Text+    -- ^ The grouping hash to use for any specific event+    --+    -- Events (exceptions) which have the same hash will be counted as the same+    -- exception. Use @Nothing@ (the default) to maintain Bugsnags automatic+    -- behavior (group by top in-project stack-frame).+    --+    , bsIsInProject :: FilePath -> Bool+    -- ^ Predicate for in-project stack frames+    --+    -- By default, all are considered in-project.+    --+    , bsFilterStackFrames :: BugsnagStackFrame -> Bool+    -- ^ Stack frame filter+    --+    -- Return @True@ for any stack-frames that should be omitted from+    -- notifications.+    --+    , bsHttpManager :: Manager+    -- ^ The HTTP @Manager@ used to emit notifications+    --+    -- It's more efficient, and ensures proper resource cleanup, to share a+    -- single manager across an application. Must be TLS-enabled.+    --+    }++-- | Construct settings purely, given an existing @'Manager'@+bugsnagSettings :: BugsnagApiKey -> Manager -> BugsnagSettings+bugsnagSettings apiKey manager = BugsnagSettings+    { bsApiKey = apiKey+    , bsAppVersion = Nothing+    , bsReleaseStage = ProductionReleaseStage+    , bsNotifyReleaseStages = [ProductionReleaseStage]+    , bsBeforeNotify = id+    , bsIgnoreException = const False+    , bsGroupingHash = const Nothing+    , bsIsInProject = const True+    , bsFilterStackFrames = const True+    , bsHttpManager = manager+    }++-- | Should this @'BugsnagException'@ trigger notification?+--+-- >>> :set -XOverloadedStrings+-- >>> settings <- newBugsnagSettings ""+-- >>> let exception = bugsnagException "" "" []+-- >>> bugsnagShouldNotify settings exception+-- True+--+-- >>> let devSettings = settings { bsReleaseStage = DevelopmentReleaseStage }+-- >>> bugsnagShouldNotify devSettings exception+-- False+--+-- >>> bugsnagShouldNotify devSettings { bsNotifyReleaseStages = [DevelopmentReleaseStage] } exception+-- True+--+-- >>> let ignore = (== "IgnoreMe") . beErrorClass+-- >>> let ignoreSettings = settings { bsIgnoreException = ignore }+-- >>> bugsnagShouldNotify ignoreSettings exception+-- True+--+-- >>> bugsnagShouldNotify ignoreSettings exception { beErrorClass = "IgnoreMe" }+-- False+--+bugsnagShouldNotify :: BugsnagSettings -> BugsnagException -> Bool+bugsnagShouldNotify settings exception+    | bsReleaseStage settings `notElem` bsNotifyReleaseStages settings = False+    | bsIgnoreException settings exception = False+    | otherwise = True++-- | Construct settings with a new, TLS-enabled @'Manager'@+--+-- >>> :set -XOverloadedStrings+-- >>> settings <- newBugsnagSettings "API_KEY"+-- >>> bsApiKey settings+-- API_KEY+--+-- >>> bsReleaseStage settings+-- ProductionReleaseStage+--+-- >>> bsNotifyReleaseStages settings+-- [ProductionReleaseStage]+--+newBugsnagSettings :: BugsnagApiKey -> IO BugsnagSettings+newBugsnagSettings apiKey = bugsnagSettings apiKey <$> newTlsManager
+ src/Network/Bugsnag/Severity.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+module Network.Bugsnag.Severity+    ( BugsnagSeverity(..)+    , BugsnagSeverityReason(..)+    , BugsnagSeverityReasonAttributes(..)+    , bugsnagSeverityReasonAttributes+    , BugsnagSeverityReasonType(..)+    ) where++import Data.Aeson+import Data.Aeson.Ext+import Data.Text (Text)+import GHC.Generics++data BugsnagSeverity+    = ErrorSeverity+    | WarningSeverity+    | InfoSeverity+    deriving Generic++instance ToJSON BugsnagSeverity where+    toJSON = genericToJSON $ bsAesonOptions "Severity"+    toEncoding = genericToEncoding $ bsAesonOptions "Severity"++data BugsnagSeverityReasonType+    = UnhandledExceptionReasonType+    | UnhandledErrorReasonType+    | LogReasonType+    | SignalReasonType+    | StrictModeReasonType+    | UnhandledPromiseRejectionReasonType+    | CallbackErrorInterceptReasonType+    | ErrorClassReasonType+    | UnhandledPanicReasonType+    | UserCallbackSetSeverityReasonType+    | UserSpecifiedSeverityReasonType+    | HandledExceptionReasonType+    | HandledErrorReasonType+    | HandledPanicReasonType+    | UserContextSetSeverityReasonType+    deriving Generic++instance ToJSON BugsnagSeverityReasonType where+    toJSON = genericToJSON $ bsAesonOptions "ReasonType"+    toEncoding = genericToEncoding $ bsAesonOptions "ReasonType"++data BugsnagSeverityReasonAttributes = BugsnagSeverityReasonAttributes+    { bsraErrorType :: Maybe Text+    , bsraLevel :: Maybe Text+    , bsraSignalType :: Maybe Text+    , bsraViolationType :: Maybe Text+    , bsraErrorClass :: Maybe Text+    }+    deriving Generic++instance ToJSON BugsnagSeverityReasonAttributes where+    toJSON = genericToJSON $ bsAesonOptions "bsra"+    toEncoding = genericToEncoding $ bsAesonOptions "bsra"++data BugsnagSeverityReason = BugsnagSeverityReason+    { bsrType :: BugsnagSeverityReasonType+    , bsrAttributes :: BugsnagSeverityReasonAttributes+    }+    deriving Generic++instance ToJSON BugsnagSeverityReason where+    toJSON = genericToJSON $ bsAesonOptions "bsr"+    toEncoding = genericToEncoding $ bsAesonOptions "bsr"++bugsnagSeverityReasonAttributes :: BugsnagSeverityReasonAttributes+bugsnagSeverityReasonAttributes = BugsnagSeverityReasonAttributes+    { bsraErrorType = Nothing+    , bsraLevel = Nothing+    , bsraSignalType = Nothing+    , bsraViolationType = Nothing+    , bsraErrorClass = Nothing+    }
+ src/Network/Bugsnag/StackFrame.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+module Network.Bugsnag.StackFrame+    ( BugsnagCode(..)+    , BugsnagStackFrame(..)+    , bugsnagStackFrame+    , currentStackFrame+    ) where++import Data.Aeson+import Data.Aeson.Ext+import Data.Text (Text)+import GHC.Generics+import Instances.TH.Lift ()+import Language.Haskell.TH.Syntax+import Numeric.Natural (Natural)++-- | Lines of code surrounding the error+--+-- Pairs of @(line-number, line-of-code)@, up to 3 on either side. There's no+-- real way to support this in Haskell, so we always send @Nothing@.+--+newtype BugsnagCode = BugsnagCode [(Natural, Text)]+    deriving (Show, ToJSON)++data BugsnagStackFrame = BugsnagStackFrame+    { bsfFile :: FilePath+    , bsfLineNumber :: Natural+    , bsfColumnNumber :: Maybe Natural+    , bsfMethod :: Text -- ^ Function, in our parlance+    , bsfInProject :: Maybe Bool+    , bsfCode :: Maybe BugsnagCode+    }+    deriving (Generic, Show)++instance ToJSON BugsnagStackFrame where+    toJSON = genericToJSON $ bsAesonOptions "bsf"+    toEncoding = genericToEncoding $ bsAesonOptions "bsf"++bugsnagStackFrame :: FilePath -> Natural -> Text -> BugsnagStackFrame+bugsnagStackFrame path ln method = BugsnagStackFrame+    { bsfFile = path+    , bsfLineNumber = ln+    , bsfColumnNumber = Nothing+    , bsfMethod = method+    , bsfInProject = Nothing+    , bsfCode = Nothing+    }++-- | Construct a @'BugsnagStackFrame'@ from the point of this splice+--+-- Unfortunately there's no way to know the function, so that must be given:+--+-- >>> :set -XOverloadedStrings -XTemplateHaskell+-- >>> :m +Control.Arrow+-- >>> (bsfFile &&& bsfMethod) $ $(currentStackFrame) "myFunc"+-- ("<interactive>","myFunc")+--+currentStackFrame :: Q Exp+currentStackFrame = [|locStackFrame $(qLocation >>= liftLoc)|]++locStackFrame :: Loc -> Text -> BugsnagStackFrame+locStackFrame (Loc path _ _ (ls, cs) _) func =+    BugsnagStackFrame+        { bsfFile = path+        , bsfLineNumber = fromIntegral ls+        , bsfColumnNumber = Just $ fromIntegral cs+        , bsfMethod = func+        , bsfInProject = 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.+        , bsfCode = Nothing+        }++-- 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))+    |]
+ src/Network/Bugsnag/Thread.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE DeriveGeneric #-}+module Network.Bugsnag.Thread+    ( BugsnagThread(..)+    , bugsnagThread+    ) where++import Data.Aeson+import Data.Aeson.Ext+import Data.Text (Text)+import GHC.Generics+import Network.Bugsnag.StackFrame++data BugsnagThread = BugsnagThread+    { btId :: Maybe Text+    , btName :: Maybe Text+    , btStacktrace :: Maybe [BugsnagStackFrame]+    }+    deriving Generic++instance ToJSON BugsnagThread where+    toJSON = genericToJSON $ bsAesonOptions "bt"+    toEncoding = genericToEncoding $ bsAesonOptions "bt"++bugsnagThread :: BugsnagThread+bugsnagThread = BugsnagThread+    { btId = Nothing+    , btName = Nothing+    , btStacktrace = Nothing+    }
+ src/Network/Bugsnag/User.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE DeriveGeneric #-}+module Network.Bugsnag.User+    ( BugsnagUser(..)+    , bugsnagUser+    ) where++import Data.Aeson+import Data.Aeson.Ext+import Data.Text (Text)+import GHC.Generics++data BugsnagUser = BugsnagUser+    { buId :: Maybe Text+    , buEmailAddress :: Maybe Text+    , buUsername :: Maybe Text+    }+    deriving Generic++instance ToJSON BugsnagUser where+    toJSON = genericToJSON $ bsAesonOptions "bu"+    toEncoding = genericToEncoding $ bsAesonOptions "bu"++bugsnagUser :: BugsnagUser+bugsnagUser = BugsnagUser+    { buId = Nothing+    , buEmailAddress = Nothing+    , buUsername = Nothing+    }
+ test/Network/Bugsnag/ReportSpec.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+module Network.Bugsnag.ReportSpec+    ( spec+    ) where++import Test.Hspec++import Data.Aeson+import Data.Aeson.QQ (aesonQQ)+import Data.Text (Text)+import Data.Time (getCurrentTime)+import Data.Version (makeVersion)+import Network.Bugsnag++spec :: Spec+spec = do+    describe "JSON payload" $ do+        it "is right for a minimally-specified report" $ do+            let report =+                    bugsnagReport+                        [ bugsnagEvent $ pure+                            $ bugsnagException+                                "errorClass"+                                "message"+                                [ bugsnagStackFrame "src/Foo/Bar.hs" 10 "myFunction"+                                ]+                        ]++            -- N.B. we don't worry about the notifier object since it would need+            -- updating on version bumps and is a simple, static value.+            toJSON report `shouldBe` [aesonQQ|+                {+                    "notifier": #{bugsnagNotifier},+                    "events": [{+                        "exceptions": [{+                            "errorClass": "errorClass",+                            "message": "message",+                            "stacktrace": [{+                                "file": "src/Foo/Bar.hs",+                                "lineNumber": 10.0,+                                "method": "myFunction"+                            }]+                        }]+                    }]+                }+            |]++        it "is right for a mostly-specified report" $ do+            now <- getCurrentTime+            let report =+                    BugsnagReport+                        { brNotifier = bugsnagNotifier+                        , brEvents =+                            [ BugsnagEvent+                                { beExceptions = pure BugsnagException+                                    { beErrorClass = "errorClass"+                                    , beMessage = Just "message"+                                    , beStacktrace =+                                        [ BugsnagStackFrame+                                            { bsfFile = "src/Foo/Bar.hs"+                                            , bsfLineNumber = 10+                                            , bsfColumnNumber = Just 12+                                            , bsfMethod = "myFunction"+                                            , bsfInProject = Just True+                                            , bsfCode = Nothing+                                            }+                                        ]+                                    , beOriginalException = Nothing+                                    }+                                , beBreadcrumbs = Just+                                    [ bugsnagBreadcrumb now "here" NavigationBreadcrumb+                                    , bugsnagBreadcrumb now "there" NavigationBreadcrumb+                                    ]+                                , beRequest = Just bugsnagRequest+                                    { brClientIp = Just "127.0.0.1"+                                    , brHeaders = Just []+                                    , brHttpMethod = Just "POST"+                                    , brUrl = Just "https://example.com"+                                    }+                                , beThreads = Just+                                    [ bugsnagThread+                                        { btId = Just "1"+                                        , btName = Just "thread-1"+                                        }+                                    ]+                                , beContext = Just "app"+                                , beGroupingHash = Nothing+                                , beUnhandled = Just False+                                , beSeverity = Just WarningSeverity+                                , beSeverityReason = Just BugsnagSeverityReason+                                    { bsrType = UnhandledExceptionReasonType+                                    , bsrAttributes = bugsnagSeverityReasonAttributes+                                        { bsraErrorType = Just "reason"+                                        , bsraLevel = Just "1"+                                        , bsraSignalType = Just "SIGKILL"+                                        }+                                    }+                                , beUser = Just bugsnagUser+                                    { buId = Just "1"+                                    , buUsername = Just "pbrisbin"+                                    }+                                , beApp = Just bugsnagApp+                                    { baId = Just "1"+                                    , baVersion = Just $ makeVersion [1, 0, 0]+                                    }+                                , beDevice = Nothing+                                , beMetaData = Just $ object+                                    [ "foo" .= ("bar" :: Text)+                                    , "baz" .= ("bat" :: Text)+                                    ]+                                }+                            ]+                        }++            toJSON report `shouldBe` [aesonQQ|+                {+                    "notifier": #{bugsnagNotifier},+                    "events": [{+                        "exceptions": [{+                            "errorClass": "errorClass",+                            "message": "message",+                            "stacktrace": [{+                                "file": "src/Foo/Bar.hs",+                                "lineNumber": 10,+                                "columnNumber": 12,+                                "method": "myFunction",+                                "inProject": true+                            }]+                        }],+                        "context": "app",+                        "breadcrumbs": [{+                            "name": "here",+                            "type": "navigation",+                            "timestamp": #{now}+                        }, {+                            "name": "there",+                            "type": "navigation",+                            "timestamp": #{now}+                        }],+                        "app": { "id": "1", "version": "1.0.0" },+                        "user": { "id": "1", "username": "pbrisbin" },+                        "severity": "warning",+                        "severityReason": {+                            "type": "unhandledException",+                            "attributes": {+                                "errorType": "reason",+                                "level": "1",+                                "signalType": "SIGKILL"+                            }+                        },+                        "threads": [{ "id": "1", "name": "thread-1" }],+                        "request": {+                            "clientIp": "127.0.0.1",+                            "httpMethod": "POST",+                            "url": "https://example.com",+                            "headers": []+                        },+                        "unhandled": false,+                        "metaData": {+                            "foo": "bar",+                            "baz": "bat"+                        }+                    }]+                }+            |]
+ test/Network/BugsnagSpec.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+module Network.BugsnagSpec+    ( spec+    ) where++import Test.Hspec++import Control.Exception+import Network.Bugsnag++brokenFunctionIO :: IO a+brokenFunctionIO = throw $ bugsnagException+    "IOException" "Something exploded" [$(currentStackFrame) "brokenFunctionIO"]++brokenFunction :: HasCallStack => a+brokenFunction = sillyHead [] `seq` undefined++sillyHead :: HasCallStack => [a] -> a+sillyHead (x:_) = x+sillyHead _ = error "empty list"++spec :: Spec+spec = do+    describe "BugsnagException" $ do+        it "can be thrown and caught" $ do+            ex <- brokenFunctionIO `catch` pure++            beErrorClass ex `shouldBe` "IOException"+            beMessage ex `shouldBe` Just "Something exploded"+            beStacktrace ex `shouldSatisfy` (not . null)++            let frame = head $ beStacktrace ex+            bsfFile frame `shouldBe` "test/Network/BugsnagSpec.hs"+            bsfLineNumber frame `shouldBe` 16+            bsfColumnNumber frame `shouldBe` Just 43+            bsfMethod frame `shouldBe` "brokenFunctionIO"+            bsfInProject frame `shouldBe` Just True++        describe "bugsnagExceptionFromSomeException" $ do+            it "can parse errors with callstacks" $ do+                e <- evaluate brokenFunction `catch` pure++                let ex = bugsnagExceptionFromSomeException e+                beErrorClass ex `shouldBe` "ErrorCall"+                beMessage ex `shouldBe` Just "empty list"+                beStacktrace ex `shouldSatisfy` ((== 3) . length)++                let frame = head $ beStacktrace ex+                bsfFile frame `shouldBe` "test/Network/BugsnagSpec.hs"+                bsfLineNumber frame `shouldBe` 23+                bsfColumnNumber frame `shouldBe` Just 15+                bsfMethod frame `shouldBe` "error"++                map bsfMethod (beStacktrace ex)+                    `shouldBe` ["error", "sillyHead", "brokenFunction"]
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}