Yesod.hs

{-# LANGUAGE AllowAmbiguousTypes #-}

-- | 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.Exception.Annotated (AnnotatedException)
import Control.Monad (unless)
import Control.Monad.IO.Class (liftIO)
import Data.Bugsnag.Settings
import Data.Maybe (isJust)
import Network.Bugsnag
import Network.Bugsnag.Wai
import qualified Network.Wai as Wai
import UnliftIO.Exception
    (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 =
    is @HandlerContents ex || is @(AnnotatedException HandlerContents) ex

is :: forall e . Exception e => SomeException -> Bool
is = isJust . fromException @e