diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,12 @@ +## [_Unreleased_](https://github.com/pbrisbin/bugsnag-haskell/compare/bugsnag-yesod-v1.0.0.0...main) + +- None + +## [v1.0.0.0](https://github.com/pbrisbin/bugsnag-haskell/tree/bugsnag-yesod-v1.0.0.0) + +First released version. + +--- + +For CHANGELOG details prior to the package re-organization, see +[`archive/CHANGELOG.md`](../archive/CHANGELOG.md). diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2022 Pat Brisbin + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,15 @@ +# Yesod integration for Bugsnag + +## Examples + +- [Yesod/Warp](./example/Main.hs) + +Examples can be built locally with: + +```console +stack build --flag bugsnag-yesod:examples +``` + +--- + +[CHANGELOG](./CHANGELOG.md) | [LICENSE](./LICENSE) diff --git a/bugsnag-yesod.cabal b/bugsnag-yesod.cabal new file mode 100644 --- /dev/null +++ b/bugsnag-yesod.cabal @@ -0,0 +1,65 @@ +cabal-version: 1.18 +name: bugsnag-yesod +version: 1.0.0.0 +license: MIT +license-file: LICENSE +maintainer: pbrisbin@gmail.com +author: Patrick Brisbin +homepage: https://github.com/pbrisbin/bugsnag-haskell#readme +synopsis: Yesod integration for Bugsnag error reporting for Haskell +description: Please see README.md +category: Web +build-type: Simple +extra-doc-files: + CHANGELOG.md + README.md + +flag examples + description: Build the examples + default: False + +library + exposed-modules: Network.Bugsnag.Yesod + hs-source-dirs: src + other-modules: Paths_bugsnag_yesod + default-language: Haskell2010 + default-extensions: + BangPatterns DataKinds DeriveAnyClass DeriveFoldable DeriveFunctor + DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies + FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving + LambdaCase MultiParamTypeClasses NoImplicitPrelude + NoMonomorphismRestriction OverloadedStrings RankNTypes + RecordWildCards ScopedTypeVariables StandaloneDeriving + TypeApplications TypeFamilies + + build-depends: + base >=4.11.0 && <5, + bugsnag >=1.0.0.0, + bugsnag-wai >=1.0.0.0, + unliftio >=0.2.12, + wai >=3.2.2.1, + yesod-core >=1.6.17.2 + +executable example-warp + main-is: Main.hs + hs-source-dirs: example + other-modules: Paths_bugsnag_yesod + default-language: Haskell2010 + default-extensions: + BangPatterns DataKinds DeriveAnyClass DeriveFoldable DeriveFunctor + DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies + FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving + LambdaCase MultiParamTypeClasses NoImplicitPrelude + NoMonomorphismRestriction OverloadedStrings RankNTypes + RecordWildCards ScopedTypeVariables StandaloneDeriving + TypeApplications TypeFamilies + + build-depends: + base >=4.11.0 && <5, + bugsnag >=1.0.0.0, + bugsnag-yesod -any, + warp >=3.3.5, + yesod-core >1.6 + + if !flag(examples) + buildable: False diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-missing-deriving-strategies #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} +{-# OPTIONS_GHC -Wno-missing-local-signatures #-} + +module Main where + +import Prelude + +import Data.Bugsnag.Settings +import Network.Bugsnag.Yesod +import Network.Wai.Handler.Warp (run) +import Yesod.Core + +newtype App = App { appBugsnag :: Settings } +mkYesod "App" [parseRoutes|/ RootR GET|] + +getRootR :: Handler Html +getRootR = error "Boom" + +instance Yesod App where + defaultLayout _widget = withUrlRenderer [hamlet||] + yesodMiddleware = + bugsnagYesodMiddleware appBugsnag . defaultYesodMiddleware + +main :: IO () +main = do + let appBugsnag = defaultSettings "BUGSNAG_API_KEY" + + -- N.B. You should also consider setting Warp's onException + run 3000 =<< toWaiApp App { .. } diff --git a/src/Network/Bugsnag/Yesod.hs b/src/Network/Bugsnag/Yesod.hs new file mode 100644 --- /dev/null +++ b/src/Network/Bugsnag/Yesod.hs @@ -0,0 +1,50 @@ +-- | A 'yesodMiddleware' that notifies Bugsnag of exceptions +-- +-- '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. +-- +module Network.Bugsnag.Yesod + ( bugsnagYesodMiddleware + , bugsnagYesodMiddlewareWith + ) where + +import Prelude + +import Control.Monad (unless) +import Control.Monad.IO.Class (liftIO) +import Data.Bugsnag.Settings +import Network.Bugsnag +import Network.Bugsnag.Wai +import qualified Network.Wai as Wai +import UnliftIO.Exception (SomeException, fromException, withException) +import Yesod.Core (forkHandler, getsYesod, waiRequest) +import Yesod.Core.Types (HandlerContents, HandlerFor) + +bugsnagYesodMiddleware + :: (app -> Settings) -> HandlerFor app a -> HandlerFor app a +bugsnagYesodMiddleware = bugsnagYesodMiddlewareWith updateEventFromWaiRequest + +bugsnagYesodMiddlewareWith + :: (Wai.Request -> BeforeNotify) + -> (app -> Settings) + -> HandlerFor app a + -> HandlerFor app a +bugsnagYesodMiddlewareWith mkBeforeNotify getSettings handler = do + settings <- getsYesod getSettings + request <- waiRequest + + handler `withException` \ex -> + unless (isHandlerContents ex) + $ forkHandler (const $ pure ()) + $ liftIO + $ notifyBugsnagWith (mkBeforeNotify request) settings ex + +isHandlerContents :: SomeException -> Bool +isHandlerContents ex = case (fromException ex :: Maybe HandlerContents) of + Just _ -> True + Nothing -> False