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 qualified Control.Exception 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.CallStack (callStackBeforeNotify)
import Freckle.App.Bugsnag.HttpException (httpExceptionBeforeNotify)
import Freckle.App.Bugsnag.MetaData (metaDataAnnotationsBeforeNotify)
import Freckle.App.Bugsnag.SqlError (sqlErrorBeforeNotify)
import qualified Freckle.App.Env as Env
import Network.Bugsnag hiding (notifyBugsnag, notifyBugsnagWith)
import qualified Network.Bugsnag 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 = forall child site.
Lens' (HandlerData child site) (RunHandlerEnv child site)
envL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall child site. Lens' (RunHandlerEnv child site) site
siteL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall env. HasAppVersion env => Lens' env Text
appVersionL

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

class HasBugsnagSettings env where
  bugsnagSettingsL :: Lens' env Settings

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

instance HasBugsnagSettings site => HasBugsnagSettings (HandlerData child site) where
  bugsnagSettingsL :: Lens' (HandlerData child site) Settings
bugsnagSettingsL = forall child site.
Lens' (HandlerData child site) (RunHandlerEnv child site)
envL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall child site. Lens' (RunHandlerEnv child site) site
siteL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall env. HasBugsnagSettings env => Lens' env 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 = forall (m :: * -> *) env e.
(MonadMask m, MonadUnliftIO m, MonadReader env m,
 HasBugsnagSettings env, Exception e) =>
BeforeNotify -> e -> m ()
notifyBugsnagWith 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 <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasBugsnagSettings env => Lens' env Settings
bugsnagSettingsL
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadMask m, MonadUnliftIO m) =>
m a -> m (Async a)
async forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 (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
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e a.
AsUnset e =>
Reader e a -> [Char] -> Mod Var a -> Parser e a
Env.var forall e s. (AsEmpty e, IsString s) => Reader e s
Env.nonempty [Char]
"BUGSNAG_API_KEY" forall a. Monoid a => a
mempty
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall e a.
AsUnset e =>
Reader e a -> [Char] -> Mod Var a -> Parser e a
Env.var forall e s. (AsEmpty e, IsString s) => Reader e s
Env.nonempty [Char]
"BUGSNAG_RELEASE_STAGE" (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 :: Text
settings_releaseStage = Text
stage
      , settings_beforeNotify :: BeforeNotify
settings_beforeNotify = BeforeNotify
globalBeforeNotify
      }

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