diff --git a/DocTest.hs b/DocTest.hs new file mode 100644 --- /dev/null +++ b/DocTest.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Test.DocTest + +main :: IO () +main = doctest ["-isrc", "src/"] diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2018 Pat Brisbin + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bugsnag-haskell.cabal b/bugsnag-haskell.cabal new file mode 100644 --- /dev/null +++ b/bugsnag-haskell.cabal @@ -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 diff --git a/examples/cli/Main.hs b/examples/cli/Main.hs new file mode 100644 --- /dev/null +++ b/examples/cli/Main.hs @@ -0,0 +1,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" diff --git a/examples/simple/Main.hs b/examples/simple/Main.hs new file mode 100644 --- /dev/null +++ b/examples/simple/Main.hs @@ -0,0 +1,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" + ] diff --git a/examples/warp/Main.hs b/examples/warp/Main.hs new file mode 100644 --- /dev/null +++ b/examples/warp/Main.hs @@ -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 diff --git a/examples/yesod/Main.hs b/examples/yesod/Main.hs new file mode 100644 --- /dev/null +++ b/examples/yesod/Main.hs @@ -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||] + + -- 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{..} diff --git a/src/Data/Aeson/Ext.hs b/src/Data/Aeson/Ext.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Ext.hs @@ -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 diff --git a/src/Network/Bugsnag.hs b/src/Network/Bugsnag.hs new file mode 100644 --- /dev/null +++ b/src/Network/Bugsnag.hs @@ -0,0 +1,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 . +-- +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 diff --git a/src/Network/Bugsnag/App.hs b/src/Network/Bugsnag/App.hs new file mode 100644 --- /dev/null +++ b/src/Network/Bugsnag/App.hs @@ -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 + } diff --git a/src/Network/Bugsnag/BeforeNotify.hs b/src/Network/Bugsnag/BeforeNotify.hs new file mode 100644 --- /dev/null +++ b/src/Network/Bugsnag/BeforeNotify.hs @@ -0,0 +1,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 } diff --git a/src/Network/Bugsnag/Breadcrumb.hs b/src/Network/Bugsnag/Breadcrumb.hs new file mode 100644 --- /dev/null +++ b/src/Network/Bugsnag/Breadcrumb.hs @@ -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 + } diff --git a/src/Network/Bugsnag/Device.hs b/src/Network/Bugsnag/Device.hs new file mode 100644 --- /dev/null +++ b/src/Network/Bugsnag/Device.hs @@ -0,0 +1,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 diff --git a/src/Network/Bugsnag/Event.hs b/src/Network/Bugsnag/Event.hs new file mode 100644 --- /dev/null +++ b/src/Network/Bugsnag/Event.hs @@ -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 + } diff --git a/src/Network/Bugsnag/Exception.hs b/src/Network/Bugsnag/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Network/Bugsnag/Exception.hs @@ -0,0 +1,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 diff --git a/src/Network/Bugsnag/Exception/Parse.hs b/src/Network/Bugsnag/Exception/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Network/Bugsnag/Exception/Parse.hs @@ -0,0 +1,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) "" . 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 diff --git a/src/Network/Bugsnag/Notifier.hs b/src/Network/Bugsnag/Notifier.hs new file mode 100644 --- /dev/null +++ b/src/Network/Bugsnag/Notifier.hs @@ -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" + } diff --git a/src/Network/Bugsnag/Notify.hs b/src/Network/Bugsnag/Notify.hs new file mode 100644 --- /dev/null +++ b/src/Network/Bugsnag/Notify.hs @@ -0,0 +1,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 + } + } diff --git a/src/Network/Bugsnag/ReleaseStage.hs b/src/Network/Bugsnag/ReleaseStage.hs new file mode 100644 --- /dev/null +++ b/src/Network/Bugsnag/ReleaseStage.hs @@ -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 diff --git a/src/Network/Bugsnag/Report.hs b/src/Network/Bugsnag/Report.hs new file mode 100644 --- /dev/null +++ b/src/Network/Bugsnag/Report.hs @@ -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 + } diff --git a/src/Network/Bugsnag/Reporter.hs b/src/Network/Bugsnag/Reporter.hs new file mode 100644 --- /dev/null +++ b/src/Network/Bugsnag/Reporter.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- +-- Report an error to Bugsnag +-- +-- +-- +-- 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"] diff --git a/src/Network/Bugsnag/Request.hs b/src/Network/Bugsnag/Request.hs new file mode 100644 --- /dev/null +++ b/src/Network/Bugsnag/Request.hs @@ -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 "" . 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 _) = "" + +-- N.B. Can't match deprecated SockAddrCan without warning. TODO: make patterns +-- exhaustive without a wildcard once it's actually removed. +sockAddrToIp _ = "" diff --git a/src/Network/Bugsnag/Session.hs b/src/Network/Bugsnag/Session.hs new file mode 100644 --- /dev/null +++ b/src/Network/Bugsnag/Session.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DeriveGeneric #-} +-- | +-- +-- +-- +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 + } diff --git a/src/Network/Bugsnag/Settings.hs b/src/Network/Bugsnag/Settings.hs new file mode 100644 --- /dev/null +++ b/src/Network/Bugsnag/Settings.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- | +-- +-- +-- +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 diff --git a/src/Network/Bugsnag/Severity.hs b/src/Network/Bugsnag/Severity.hs new file mode 100644 --- /dev/null +++ b/src/Network/Bugsnag/Severity.hs @@ -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 + } diff --git a/src/Network/Bugsnag/StackFrame.hs b/src/Network/Bugsnag/StackFrame.hs new file mode 100644 --- /dev/null +++ b/src/Network/Bugsnag/StackFrame.hs @@ -0,0 +1,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" +-- ("","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)) + |] diff --git a/src/Network/Bugsnag/Thread.hs b/src/Network/Bugsnag/Thread.hs new file mode 100644 --- /dev/null +++ b/src/Network/Bugsnag/Thread.hs @@ -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 + } diff --git a/src/Network/Bugsnag/User.hs b/src/Network/Bugsnag/User.hs new file mode 100644 --- /dev/null +++ b/src/Network/Bugsnag/User.hs @@ -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 + } diff --git a/test/Network/Bugsnag/ReportSpec.hs b/test/Network/Bugsnag/ReportSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Bugsnag/ReportSpec.hs @@ -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" + } + }] + } + |] diff --git a/test/Network/BugsnagSpec.hs b/test/Network/BugsnagSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/BugsnagSpec.hs @@ -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"] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}