Main.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-missing-local-signatures #-}
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}

#if __GLASGOW_HASKELL__ >= 808
{-# OPTIONS_GHC -fno-warn-missing-deriving-strategies #-}
#endif

module Main (main) where

import Prelude

import Control.Exception (SomeException, fromException, toException)
import Control.Monad (unless)
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)

newtype App = App { appBugsnag :: BugsnagSettings }
mkYesod "App" [parseRoutes|/ RootR GET|]

getRootR :: Handler Html
getRootR = error "Boom"

instance Yesod App where
    defaultLayout _widget = withUrlRenderer [hamlet|<html>|]

    -- 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
        throwIO $ 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{..}