module Freckle.App.Bugsnag
( Settings
, HasBugsnagSettings (..)
, notifyBugsnag
, notifyBugsnagWith
, HasAppVersion (..)
, setAppVersion
, envParseBugsnagSettings
, 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.HttpException (httpExceptionBeforeNotify)
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 = (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 :: Maybe App
event_app = App -> Maybe App
forall a. a -> Maybe a
Just (App -> Maybe App) -> App -> Maybe App
forall a b. (a -> b) -> a -> b
$ App -> App
updateApp (App -> App) -> App -> App
forall a b. (a -> b) -> a -> b
$ App -> Maybe App -> App
forall a. a -> Maybe a -> a
fromMaybe App
defaultApp (Maybe App -> App) -> Maybe App -> App
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 = Text -> Maybe Text
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 = (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
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
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
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 :: Text
settings_releaseStage = Text
stage
, settings_beforeNotify :: BeforeNotify
settings_beforeNotify = 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