module Freckle.App.Bugsnag
  ( Settings
  , HasBugsnagSettings (..)
  , notifyBugsnag
  , notifyBugsnagWith

    -- * 'AppVersion'
  , HasAppVersion (..)
  , setAppVersion

    -- * Loading settings
  , envParseBugsnagSettings

    -- * Re-exports
  , MonadReader
  , runReaderT
  , module Network.Bugsnag
  ) where

import Freckle.App.Prelude

import Control.Exception qualified as Base (Exception)
import Control.Lens (Lens', view)
import Control.Monad.Catch (MonadMask)
import Control.Monad.Reader (runReaderT)
import Data.Bugsnag (App (..), Event (..), defaultApp)
import Data.Bugsnag.Settings (Settings (..), defaultSettings)
import Data.List (isInfixOf)
import Freckle.App.Async (async)
import Freckle.App.Bugsnag.HttpException (httpExceptionBeforeNotify)
import Freckle.App.Bugsnag.SqlError (sqlErrorBeforeNotify)
import Freckle.App.Env qualified as Env
import Network.Bugsnag hiding (notifyBugsnag, notifyBugsnagWith)
import Network.Bugsnag qualified as Bugsnag
import Yesod.Core.Lens (envL, siteL)
import Yesod.Core.Types (HandlerData)

class HasAppVersion env where
  appVersionL :: Lens' env Text

instance HasAppVersion site => HasAppVersion (HandlerData child site) where
  appVersionL :: Lens' (HandlerData child site) Text
appVersionL = (RunHandlerEnv child site -> f (RunHandlerEnv child site))
-> HandlerData child site -> f (HandlerData child site)
forall child site (f :: * -> *).
Functor f =>
(RunHandlerEnv child site -> f (RunHandlerEnv child site))
-> HandlerData child site -> f (HandlerData child site)
envL ((RunHandlerEnv child site -> f (RunHandlerEnv child site))
 -> HandlerData child site -> f (HandlerData child site))
-> ((Text -> f Text)
    -> RunHandlerEnv child site -> f (RunHandlerEnv child site))
-> (Text -> f Text)
-> HandlerData child site
-> f (HandlerData child site)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (site -> f site)
-> RunHandlerEnv child site -> f (RunHandlerEnv child site)
forall child site (f :: * -> *).
Functor f =>
(site -> f site)
-> RunHandlerEnv child site -> f (RunHandlerEnv child site)
siteL ((site -> f site)
 -> RunHandlerEnv child site -> f (RunHandlerEnv child site))
-> ((Text -> f Text) -> site -> f site)
-> (Text -> f Text)
-> RunHandlerEnv child site
-> f (RunHandlerEnv child site)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> f Text) -> site -> f site
forall env. HasAppVersion env => Lens' env Text
Lens' site Text
appVersionL

setAppVersion :: Text -> BeforeNotify
setAppVersion :: Text -> BeforeNotify
setAppVersion Text
version = (Event -> Event) -> BeforeNotify
updateEvent ((Event -> Event) -> BeforeNotify)
-> (Event -> Event) -> BeforeNotify
forall a b. (a -> b) -> a -> b
$ \Event
event ->
  Event
event
    { event_app = Just $ updateApp $ fromMaybe defaultApp $ event_app event
    }
 where
  updateApp :: App -> App
updateApp App
app = App
app {app_version = Just version}

class HasBugsnagSettings env where
  bugsnagSettingsL :: Lens' env Settings

instance HasBugsnagSettings Settings where
  bugsnagSettingsL :: Lens' Settings Settings
bugsnagSettingsL = (Settings -> f Settings) -> Settings -> f Settings
forall a. a -> a
id

instance HasBugsnagSettings site => HasBugsnagSettings (HandlerData child site) where
  bugsnagSettingsL :: Lens' (HandlerData child site) Settings
bugsnagSettingsL = (RunHandlerEnv child site -> f (RunHandlerEnv child site))
-> HandlerData child site -> f (HandlerData child site)
forall child site (f :: * -> *).
Functor f =>
(RunHandlerEnv child site -> f (RunHandlerEnv child site))
-> HandlerData child site -> f (HandlerData child site)
envL ((RunHandlerEnv child site -> f (RunHandlerEnv child site))
 -> HandlerData child site -> f (HandlerData child site))
-> ((Settings -> f Settings)
    -> RunHandlerEnv child site -> f (RunHandlerEnv child site))
-> (Settings -> f Settings)
-> HandlerData child site
-> f (HandlerData child site)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (site -> f site)
-> RunHandlerEnv child site -> f (RunHandlerEnv child site)
forall child site (f :: * -> *).
Functor f =>
(site -> f site)
-> RunHandlerEnv child site -> f (RunHandlerEnv child site)
siteL ((site -> f site)
 -> RunHandlerEnv child site -> f (RunHandlerEnv child site))
-> ((Settings -> f Settings) -> site -> f site)
-> (Settings -> f Settings)
-> RunHandlerEnv child site
-> f (RunHandlerEnv child site)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Settings -> f Settings) -> site -> f site
forall env. HasBugsnagSettings env => Lens' env Settings
Lens' site Settings
bugsnagSettingsL

-- | Notify Bugsnag of an exception
--
-- The notification is made asynchronously via a simple @'async'@. This is
-- best-effort and we don't care to keep track of the spawned threads.
notifyBugsnag
  :: ( MonadMask m
     , MonadUnliftIO m
     , MonadReader env m
     , HasBugsnagSettings env
     , Base.Exception e
     )
  => e
  -> m ()
notifyBugsnag :: forall (m :: * -> *) env e.
(MonadMask m, MonadUnliftIO m, MonadReader env m,
 HasBugsnagSettings env, Exception e) =>
e -> m ()
notifyBugsnag = BeforeNotify -> e -> m ()
forall (m :: * -> *) env e.
(MonadMask m, MonadUnliftIO m, MonadReader env m,
 HasBugsnagSettings env, Exception e) =>
BeforeNotify -> e -> m ()
notifyBugsnagWith BeforeNotify
forall a. Monoid a => a
mempty

-- | 'notifyBugsnag' with a 'BeforeNotify'
notifyBugsnagWith
  :: ( MonadMask m
     , MonadUnliftIO m
     , MonadReader env m
     , HasBugsnagSettings env
     , Base.Exception e
     )
  => BeforeNotify
  -> e
  -> m ()
notifyBugsnagWith :: forall (m :: * -> *) env e.
(MonadMask m, MonadUnliftIO m, MonadReader env m,
 HasBugsnagSettings env, Exception e) =>
BeforeNotify -> e -> m ()
notifyBugsnagWith BeforeNotify
f e
ex = do
  Settings
settings <- Getting Settings env Settings -> m Settings
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Settings env Settings
forall env. HasBugsnagSettings env => Lens' env Settings
Lens' env Settings
bugsnagSettingsL
  m (Async ()) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Async ()) -> m ()) -> m (Async ()) -> m ()
forall a b. (a -> b) -> a -> b
$ m () -> m (Async ())
forall (m :: * -> *) a.
(MonadMask m, MonadUnliftIO m) =>
m a -> m (Async a)
async (m () -> m (Async ())) -> m () -> m (Async ())
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ BeforeNotify -> Settings -> e -> IO ()
forall e. Exception e => BeforeNotify -> Settings -> e -> IO ()
Bugsnag.notifyBugsnagWith BeforeNotify
f Settings
settings e
ex

-- | Set StackFrame's InProject to @'False'@ for Error Helper modules
--
-- We want exceptions grouped by the the first stack-frame that is /not/ them.
-- Marking them as not in-project does this, with little downside.
maskErrorHelpers :: BeforeNotify
maskErrorHelpers :: BeforeNotify
maskErrorHelpers = ([Char] -> Bool) -> BeforeNotify
setStackFramesInProjectByFile ([Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
"Exceptions")

envParseBugsnagSettings :: Env.Parser Env.Error Settings
envParseBugsnagSettings :: Parser Error Settings
envParseBugsnagSettings =
  Text -> Text -> Settings
build
    (Text -> Text -> Settings)
-> Parser Error Text -> Parser Error (Text -> Settings)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Reader Error Text -> [Char] -> Mod Var Text -> Parser Error Text
forall e a.
AsUnset e =>
Reader e a -> [Char] -> Mod Var a -> Parser e a
Env.var Reader Error Text
forall e s. (AsEmpty e, IsString s) => Reader e s
Env.nonempty [Char]
"BUGSNAG_API_KEY" Mod Var Text
forall a. Monoid a => a
mempty
    Parser Error (Text -> Settings)
-> Parser Error Text -> Parser Error Settings
forall a b.
Parser Error (a -> b) -> Parser Error a -> Parser Error b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Reader Error Text -> [Char] -> Mod Var Text -> Parser Error Text
forall e a.
AsUnset e =>
Reader e a -> [Char] -> Mod Var a -> Parser e a
Env.var Reader Error Text
forall e s. (AsEmpty e, IsString s) => Reader e s
Env.nonempty [Char]
"BUGSNAG_RELEASE_STAGE" (Text -> Mod Var Text
forall a. a -> Mod Var a
Env.def Text
"development")
 where
  build :: Text -> Text -> Settings
build Text
key Text
stage =
    (Text -> Settings
defaultSettings Text
key)
      { settings_releaseStage = stage
      , settings_beforeNotify = globalBeforeNotify
      }

globalBeforeNotify :: BeforeNotify
globalBeforeNotify :: BeforeNotify
globalBeforeNotify =
  BeforeNotify
sqlErrorBeforeNotify
    BeforeNotify -> BeforeNotify -> BeforeNotify
forall a. Semigroup a => a -> a -> a
<> BeforeNotify
httpExceptionBeforeNotify
    BeforeNotify -> BeforeNotify -> BeforeNotify
forall a. Semigroup a => a -> a -> a
<> BeforeNotify
maskErrorHelpers