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

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

  -- * Loading settings
  , envParseBugsnagSettings

  -- * Exported for testing
  , sqlErrorGroupingHash

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

import Freckle.App.Prelude

import Control.Concurrent (forkIO)
import Control.Lens (Lens', view)
import Control.Monad.Reader (runReaderT)
import Data.Bugsnag
import Data.Bugsnag.Settings
import qualified Data.ByteString.Char8 as BS8
import Data.List (isInfixOf)
import Database.PostgreSQL.Simple (SqlError(..))
import Database.PostgreSQL.Simple.Errors
import qualified Freckle.App.Env as Env
import Network.Bugsnag hiding (notifyBugsnag, notifyBugsnagWith)
import qualified Network.Bugsnag as Bugsnag
import Network.HTTP.Client (HttpException(..), host, method)
import qualified UnliftIO.Exception as Exception
import Yesod.Core.Lens
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 @'forkIO'@. This is
-- best-effort and we don't care to keep track of the spawned threads.
--
notifyBugsnag
  :: ( MonadIO m
     , MonadReader env m
     , HasBugsnagSettings env
     , Exception.Exception e
     )
  => e
  -> m ()
notifyBugsnag :: forall (m :: * -> *) env e.
(MonadIO m, MonadReader env m, HasBugsnagSettings env,
 Exception e) =>
e -> m ()
notifyBugsnag = forall (m :: * -> *) env e.
(MonadIO m, MonadReader env m, HasBugsnagSettings env,
 Exception e) =>
BeforeNotify -> e -> m ()
notifyBugsnagWith forall a. Monoid a => a
mempty

-- | 'notifyBugsnag' with a 'BeforeNotify'
notifyBugsnagWith
  :: ( MonadIO m
     , MonadReader env m
     , HasBugsnagSettings env
     , Exception.Exception e
     )
  => BeforeNotify
  -> e
  -> m ()
notifyBugsnagWith :: forall (m :: * -> *) env e.
(MonadIO 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. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall e. Exception e => BeforeNotify -> Settings -> e -> IO ()
Bugsnag.notifyBugsnagWith BeforeNotify
f Settings
settings e
ex

asSqlError :: SqlError -> BeforeNotify
asSqlError :: SqlError -> BeforeNotify
asSqlError err :: SqlError
err@SqlError {ByteString
ExecStatus
sqlState :: SqlError -> ByteString
sqlExecStatus :: SqlError -> ExecStatus
sqlErrorMsg :: SqlError -> ByteString
sqlErrorDetail :: SqlError -> ByteString
sqlErrorHint :: SqlError -> ByteString
sqlErrorHint :: ByteString
sqlErrorDetail :: ByteString
sqlErrorMsg :: ByteString
sqlExecStatus :: ExecStatus
sqlState :: ByteString
..} = BeforeNotify
toSqlGrouping forall a. Semigroup a => a -> a -> a
<> BeforeNotify
toSqlException
 where
  toSqlGrouping :: BeforeNotify
toSqlGrouping = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty Text -> BeforeNotify
setGroupingHash (SqlError -> Maybe Text
sqlErrorGroupingHash SqlError
err)
  toSqlException :: BeforeNotify
toSqlException = (Exception -> Exception) -> BeforeNotify
updateExceptions forall a b. (a -> b) -> a -> b
$ \Exception
ex -> Exception
ex
    { exception_errorClass :: Text
exception_errorClass = ByteString -> Text
decodeUtf8 forall a b. (a -> b) -> a -> b
$ ByteString
"SqlError-" forall a. Semigroup a => a -> a -> a
<> ByteString
sqlState
    , exception_message :: Maybe Text
exception_message =
      forall a. a -> Maybe a
Just
      forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8
      forall a b. (a -> b) -> a -> b
$ ByteString
sqlErrorMsg
      forall a. Semigroup a => a -> a -> a
<> ByteString
": "
      forall a. Semigroup a => a -> a -> a
<> ByteString
sqlErrorDetail
      forall a. Semigroup a => a -> a -> a
<> ByteString
" ("
      forall a. Semigroup a => a -> a -> a
<> ByteString
sqlErrorHint
      forall a. Semigroup a => a -> a -> a
<> ByteString
")"
    }

sqlErrorGroupingHash :: SqlError -> Maybe Text
sqlErrorGroupingHash :: SqlError -> Maybe Text
sqlErrorGroupingHash SqlError
err = do
  ConstraintViolation
violation <- SqlError -> Maybe ConstraintViolation
constraintViolation SqlError
err
  ByteString -> Text
decodeUtf8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case ConstraintViolation
violation of
    ForeignKeyViolation ByteString
table ByteString
constraint -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ByteString
table forall a. Semigroup a => a -> a -> a
<> ByteString
"." forall a. Semigroup a => a -> a -> a
<> ByteString
constraint
    UniqueViolation ByteString
constraint -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
constraint
    ConstraintViolation
_ -> forall a. Maybe a
Nothing

asHttpException :: HttpException -> BeforeNotify
asHttpException :: HttpException -> BeforeNotify
asHttpException (HttpExceptionRequest Request
req HttpExceptionContent
content) =
  Text -> BeforeNotify
setGroupingHash (ByteString -> Text
decodeUtf8 forall a b. (a -> b) -> a -> b
$ Request -> ByteString
host Request
req) forall a. Semigroup a => a -> a -> a
<> BeforeNotify
update
 where
  update :: BeforeNotify
update = (Exception -> Exception) -> BeforeNotify
updateExceptions forall a b. (a -> b) -> a -> b
$ \Exception
ex -> Exception
ex
    { exception_errorClass :: Text
exception_errorClass = Text
"HttpExceptionRequest"
    , exception_message :: Maybe Text
exception_message =
      forall a. a -> Maybe a
Just
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8
      forall a b. (a -> b) -> a -> b
$ Request -> ByteString
method Request
req
      forall a. Semigroup a => a -> a -> a
<> ByteString
" request to "
      forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
host Request
req
      forall a. Semigroup a => a -> a -> a
<> ByteString
" failed: "
      forall a. Semigroup a => a -> a -> a
<> [Char] -> ByteString
BS8.pack (forall a. Show a => a -> [Char]
show HttpExceptionContent
content)
    }
asHttpException (InvalidUrlException [Char]
url [Char]
msg) = (Exception -> Exception) -> BeforeNotify
updateExceptions forall a b. (a -> b) -> a -> b
$ \Exception
ex -> Exception
ex
  { exception_errorClass :: Text
exception_errorClass = Text
"InvalidUrlException"
  , exception_message :: Maybe Text
exception_message = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack forall a b. (a -> b) -> a -> b
$ [Char]
url forall a. Semigroup a => a -> a -> a
<> [Char]
" is invalid: " forall a. Semigroup a => a -> a -> a
<> [Char]
msg
  }

-- | 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")

-- brittany-disable-next-binding

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 =
  forall e. Exception e => (e -> BeforeNotify) -> BeforeNotify
updateEventFromOriginalException SqlError -> BeforeNotify
asSqlError
    forall a. Semigroup a => a -> a -> a
<> forall e. Exception e => (e -> BeforeNotify) -> BeforeNotify
updateEventFromOriginalException HttpException -> BeforeNotify
asHttpException
    forall a. Semigroup a => a -> a -> a
<> BeforeNotify
maskErrorHelpers