diff --git a/bugsnag-haskell.cabal b/bugsnag-haskell.cabal --- a/bugsnag-haskell.cabal +++ b/bugsnag-haskell.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 7bf291abde6fe3bc6aa43132c387532dae5ab319f44295932acaefa836a13869 +-- hash: 36962ecc46dfa7d5ab30da6797310d06145ecdd5d2d487ab6f1ec237b259e721 name: bugsnag-haskell -version: 0.0.1.2 +version: 0.0.1.3 synopsis: Bugsnag error reporter for Haskell description: Please see README.md category: Web @@ -27,7 +27,7 @@ src ghc-options: -Wall build-depends: - aeson + aeson >=1.3.0.0 , base >=4.8.0 && <5 , bytestring , case-insensitive @@ -123,6 +123,7 @@ base >=4.8.0 && <5 , bugsnag-haskell , exceptions + , unliftio , wai , warp , yesod-core diff --git a/examples/yesod/Main.hs b/examples/yesod/Main.hs --- a/examples/yesod/Main.hs +++ b/examples/yesod/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} @@ -9,9 +10,14 @@ 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) +#if MIN_VERSION_yesod_core(1,6,0) +import UnliftIO.Exception (catch, throwIO) +#else +import Control.Monad.Catch (catch) +import UnliftIO.Exception (throwIO) +#endif import Yesod.Core import Yesod.Core.Types (HandlerContents) @@ -43,7 +49,7 @@ unless (isHandlerContents ex) $ forkHandler (const $ pure ()) $ liftIO $ notifyBugsnagWith (updateEventFromWaiRequest request) settings ex - throwM $ toException ex + throwIO $ toException ex where isHandlerContents :: SomeException -> Bool isHandlerContents ex = diff --git a/src/Network/Bugsnag/BeforeNotify.hs b/src/Network/Bugsnag/BeforeNotify.hs --- a/src/Network/Bugsnag/BeforeNotify.hs +++ b/src/Network/Bugsnag/BeforeNotify.hs @@ -1,13 +1,23 @@ +{-# LANGUAGE OverloadedStrings #-} + module Network.Bugsnag.BeforeNotify ( BeforeNotify + , defaultBeforeNotify -- * Modifying the Exception , updateException + , filterStackFrames + , setStackFramesInProject + , setGroupingHash + , setGroupingHashBy -- * Modifying the Event , updateEventFromSession , updateEventFromWaiRequest + -- * Modifying the Request + , redactRequestHeaders + -- * Simple setters , setDevice , setRequest @@ -19,6 +29,7 @@ , setInfoSeverity ) where +import Data.Text (Text) import Network.Bugsnag.Device import Network.Bugsnag.Event import Network.Bugsnag.Exception @@ -26,10 +37,30 @@ import Network.Bugsnag.Session import Network.Bugsnag.Severity import Network.Bugsnag.StackFrame +import Network.HTTP.Types.Header (Header, HeaderName) import Network.Wai (Request) type BeforeNotify = BugsnagEvent -> BugsnagEvent +-- | Used as @'bsBeforeNotify'@ the default Settings value +-- +-- Redacts the following Request headers: +-- +-- - Authorization +-- - Cookie +-- - X-XSRF-TOKEN (CSRF token header used by Yesod) +-- +-- N.B. If you override the value on @'BugsnagSettings'@, you probably want to +-- maintain this as well: +-- +-- @ +-- settings { 'bsBeforeNotify' = 'defaultBeforeNotify' . myBeforeNotify } +-- @ +-- +defaultBeforeNotify :: BeforeNotify +defaultBeforeNotify = + redactRequestHeaders ["Authorization", "Cookie", "X-XSRF-TOKEN"] + -- | Modify just the Exception part of an Event -- -- Technically this will modify all exceptions in the Event, but if you're using @@ -50,50 +81,90 @@ -- > _ -> ex -- updateException :: (BugsnagException -> BugsnagException) -> BeforeNotify -updateException f event = event - { beExceptions = f <$> beExceptions event - } +updateException f event = event { beExceptions = f <$> beExceptions event } +-- | Filter out StackFrames matching a predicate +filterStackFrames :: (BugsnagStackFrame -> Bool) -> BeforeNotify +filterStackFrames p = + updateException $ \ex -> ex { beStacktrace = filter p $ beStacktrace ex } + +-- | Set @'bsIsInProject'@ using the given predicate, applied to the Filename +setStackFramesInProject :: (FilePath -> Bool) -> BeforeNotify +setStackFramesInProject p = updateException + $ \ex -> ex { beStacktrace = map updateStackFrames $ beStacktrace ex } + where + updateStackFrames :: BugsnagStackFrame -> BugsnagStackFrame + updateStackFrames sf = sf { bsfInProject = Just $ p $ bsfFile sf } + +-- | Set @'beGroupingHash'@ +setGroupingHash :: Text -> BeforeNotify +setGroupingHash hash = setGroupingHashBy $ const $ Just hash + +-- | Set @'beGroupingHash'@ based on the Event +setGroupingHashBy :: (BugsnagEvent -> Maybe Text) -> BeforeNotify +setGroupingHashBy f event = event { beGroupingHash = f event } + -- | Set the events @'BugsnagEvent'@ and @'BugsnagDevice'@ updateEventFromWaiRequest :: Request -> BeforeNotify updateEventFromWaiRequest wrequest = - let mdevice = bugsnagDeviceFromWaiRequest 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 +updateEventFromSession session event = + event { beContext = bsContext session, beUser = bsUser session } + +-- | Redact the given request headers +-- +-- Headers like @Authorization@ may contain information you don't want to report +-- to Bugsnag. +-- +-- > redactRequestHeaders ["Authorization", "Cookie"] +-- +redactRequestHeaders :: [HeaderName] -> BeforeNotify +redactRequestHeaders headers event = + event { beRequest = redactHeaders headers <$> beRequest event } + +-- | +-- +-- >>> let headers = [("Authorization", "secret"), ("X-Foo", "Bar")] +-- >>> let req = bugsnagRequest { brHeaders = Just headers } +-- >>> brHeaders $ redactHeaders ["Authorization"] req +-- Just [("Authorization",""),("X-Foo","Bar")] +-- +redactHeaders :: [HeaderName] -> BugsnagRequest -> BugsnagRequest +redactHeaders headers request = request + { brHeaders = map redactHeader <$> brHeaders request } + where + redactHeader :: Header -> Header + redactHeader (k, _) | k `elem` headers = (k, "") + redactHeader h = h -- | Set the Event's Request -- -- See @'bugsnagRequestFromWaiRequest'@ -- setRequest :: BugsnagRequest -> BeforeNotify -setRequest request event = event - { beRequest = Just request - } +setRequest request event = event { beRequest = Just request } -- | Set the Event's Device -- -- See @'bugsnagDeviceFromWaiRequest'@ -- setDevice :: BugsnagDevice -> BeforeNotify -setDevice device event = event - { beDevice = Just device - } +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 - } +setStacktrace stacktrace = + updateException $ \ex -> ex { beStacktrace = stacktrace } -- | Set to @'ErrorSeverity'@ setErrorSeverity :: BeforeNotify diff --git a/src/Network/Bugsnag/Notify.hs b/src/Network/Bugsnag/Notify.hs --- a/src/Network/Bugsnag/Notify.hs +++ b/src/Network/Bugsnag/Notify.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-deprecations #-} + module Network.Bugsnag.Notify ( notifyBugsnag , notifyBugsnagWith @@ -12,7 +14,6 @@ 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 () @@ -26,47 +27,26 @@ -- 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 + let event = + f . bsBeforeNotify settings - . updateGroupingHash settings - . updateStackFramesInProject settings - . filterStackFrames settings + . setGroupingHashBy (bsGroupingHash settings) + . setStackFramesInProject (bsIsInProject settings) + . filterStackFrames (bsFilterStackFrames 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 - } + . pure + $ bugsnagExceptionFromSomeException ex -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 - } + manager = bsHttpManager settings + apiKey = bsApiKey settings + report = bugsnagReport [event] -filterStackFrames :: BugsnagSettings -> BeforeNotify -filterStackFrames settings = updateException $ \ex -> ex - { beStacktrace = filter (bsFilterStackFrames settings) $ beStacktrace 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 event) + $ reportError manager apiKey report -- | -- diff --git a/src/Network/Bugsnag/Settings.hs b/src/Network/Bugsnag/Settings.hs --- a/src/Network/Bugsnag/Settings.hs +++ b/src/Network/Bugsnag/Settings.hs @@ -12,6 +12,7 @@ ) where import Data.Aeson (FromJSON) +import qualified Data.List.NonEmpty as NE import Data.String import Data.Text (Text) import qualified Data.Text as T @@ -51,7 +52,9 @@ , bsBeforeNotify :: BeforeNotify -- ^ Modify any events before they are sent -- - -- For example to attach a user, or set the context. + -- For example to attach a user, or set the context. By default, we use + -- @'redactRequestHeaders'@ to strip some sensitive Headers from the + -- Request. -- , bsIgnoreException :: BugsnagException -> Bool -- ^ Exception filtering @@ -86,6 +89,10 @@ -- } +{-# DEPRECATED bsGroupingHash "use setGroupingHashBy with bsBeforeNotify" #-} +{-# DEPRECATED bsIsInProject "use setStackFramesInProject with bsBeforeNotify" #-} +{-# DEPRECATED bsFilterStackFrames "use filterStackFrames with bsBeforeNotify" #-} + -- | Construct settings purely, given an existing @'Manager'@ bugsnagSettings :: BugsnagApiKey -> Manager -> BugsnagSettings bugsnagSettings apiKey manager = BugsnagSettings @@ -93,7 +100,7 @@ , bsAppVersion = Nothing , bsReleaseStage = ProductionReleaseStage , bsNotifyReleaseStages = [ProductionReleaseStage] - , bsBeforeNotify = id + , bsBeforeNotify = defaultBeforeNotify , bsIgnoreException = const False , bsGroupingHash = const Nothing , bsIsInProject = const True @@ -101,37 +108,48 @@ , bsHttpManager = manager } --- | Should this @'BugsnagException'@ trigger notification? +-- | Should this @'BugsnagEvent'@ trigger notification? -- -- >>> :set -XOverloadedStrings -- >>> settings <- newBugsnagSettings "" --- >>> let exception = bugsnagException "" "" [] --- >>> bugsnagShouldNotify settings exception +-- >>> let event = bugsnagEvent $ pure $ bugsnagException "" "" [] +-- >>> bugsnagShouldNotify settings event -- True -- -- >>> let devSettings = settings { bsReleaseStage = DevelopmentReleaseStage } --- >>> bugsnagShouldNotify devSettings exception +-- >>> bugsnagShouldNotify devSettings event -- False -- --- >>> bugsnagShouldNotify devSettings { bsNotifyReleaseStages = [DevelopmentReleaseStage] } exception +-- >>> bugsnagShouldNotify devSettings { bsNotifyReleaseStages = [DevelopmentReleaseStage] } event -- True -- -- >>> let ignore = (== "IgnoreMe") . beErrorClass -- >>> let ignoreSettings = settings { bsIgnoreException = ignore } --- >>> bugsnagShouldNotify ignoreSettings exception +-- >>> let ignoreEvent = bugsnagEvent $ pure $ bugsnagException "IgnoreMe" "" [] +-- >>> bugsnagShouldNotify ignoreSettings event -- True -- --- >>> bugsnagShouldNotify ignoreSettings exception { beErrorClass = "IgnoreMe" } +-- >>> bugsnagShouldNotify ignoreSettings ignoreEvent -- False -- -bugsnagShouldNotify :: BugsnagSettings -> BugsnagException -> Bool -bugsnagShouldNotify settings exception +bugsnagShouldNotify :: BugsnagSettings -> BugsnagEvent -> Bool +bugsnagShouldNotify settings event | bsReleaseStage settings `notElem` bsNotifyReleaseStages settings = False | bsIgnoreException settings exception = False | otherwise = True + where + exception + | NE.length (beExceptions event) == 1 = NE.head $ beExceptions event + | otherwise = error $ unlines + [ "Library misused. Event must have exactly one Exception when" + , " going through our notifyBugsnag functions. To send more than" + , " one Exception, drop down to reportError." + ] -- | Construct settings with a new, TLS-enabled @'Manager'@ -- +-- Uses @'getGlobalManager'@. +-- -- >>> :set -XOverloadedStrings -- >>> settings <- newBugsnagSettings "API_KEY" -- >>> bsApiKey settings @@ -144,4 +162,4 @@ -- [ProductionReleaseStage] -- newBugsnagSettings :: BugsnagApiKey -> IO BugsnagSettings -newBugsnagSettings apiKey = bugsnagSettings apiKey <$> newTlsManager +newBugsnagSettings apiKey = bugsnagSettings apiKey <$> getGlobalManager