-- | 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 :: (app -> Settings) -> HandlerFor app a -> HandlerFor app a
bugsnagYesodMiddleware = (Request -> BeforeNotify)
-> (app -> Settings) -> HandlerFor app a -> HandlerFor app a
forall app a.
(Request -> BeforeNotify)
-> (app -> Settings) -> HandlerFor app a -> HandlerFor app a
bugsnagYesodMiddlewareWith Request -> BeforeNotify
updateEventFromWaiRequest

bugsnagYesodMiddlewareWith
    :: (Wai.Request -> BeforeNotify)
    -> (app -> Settings)
    -> HandlerFor app a
    -> HandlerFor app a
bugsnagYesodMiddlewareWith :: (Request -> BeforeNotify)
-> (app -> Settings) -> HandlerFor app a -> HandlerFor app a
bugsnagYesodMiddlewareWith Request -> BeforeNotify
mkBeforeNotify app -> Settings
getSettings HandlerFor app a
handler = do
    Settings
settings <- (HandlerSite (HandlerFor app) -> Settings)
-> HandlerFor app Settings
forall (m :: * -> *) a.
MonadHandler m =>
(HandlerSite m -> a) -> m a
getsYesod app -> Settings
HandlerSite (HandlerFor app) -> Settings
getSettings
    Request
request <- HandlerFor app Request
forall (m :: * -> *). MonadHandler m => m Request
waiRequest

    HandlerFor app a
handler HandlerFor app a
-> (SomeException -> HandlerFor app ()) -> HandlerFor app a
forall (m :: * -> *) e a b.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m b) -> m a
`withException` \SomeException
ex ->
        Bool -> HandlerFor app () -> HandlerFor app ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SomeException -> Bool
isHandlerContents SomeException
ex)
            (HandlerFor app () -> HandlerFor app ())
-> HandlerFor app () -> HandlerFor app ()
forall a b. (a -> b) -> a -> b
$ (SomeException -> HandlerFor app ())
-> HandlerFor app () -> HandlerFor app ()
forall site.
(SomeException -> HandlerFor site ())
-> HandlerFor site () -> HandlerFor site ()
forkHandler (HandlerFor app () -> SomeException -> HandlerFor app ()
forall a b. a -> b -> a
const (HandlerFor app () -> SomeException -> HandlerFor app ())
-> HandlerFor app () -> SomeException -> HandlerFor app ()
forall a b. (a -> b) -> a -> b
$ () -> HandlerFor app ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
            (HandlerFor app () -> HandlerFor app ())
-> HandlerFor app () -> HandlerFor app ()
forall a b. (a -> b) -> a -> b
$ IO () -> HandlerFor app ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
            (IO () -> HandlerFor app ()) -> IO () -> HandlerFor app ()
forall a b. (a -> b) -> a -> b
$ BeforeNotify -> Settings -> SomeException -> IO ()
forall e. Exception e => BeforeNotify -> Settings -> e -> IO ()
notifyBugsnagWith (Request -> BeforeNotify
mkBeforeNotify Request
request) Settings
settings SomeException
ex

isHandlerContents :: SomeException -> Bool
isHandlerContents :: SomeException -> Bool
isHandlerContents SomeException
ex = case (SomeException -> Maybe HandlerContents
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
ex :: Maybe HandlerContents) of
    Just HandlerContents
_ -> Bool
True
    Maybe HandlerContents
Nothing -> Bool
False