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 Freckle.App.Version
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 AppVersion

instance HasAppVersion AppVersion where
  appVersionL :: (AppVersion -> f AppVersion) -> AppVersion -> f AppVersion
appVersionL = (AppVersion -> f AppVersion) -> AppVersion -> f AppVersion
forall a. a -> a
id

instance HasAppVersion site =>  HasAppVersion (HandlerData child site) where
  appVersionL :: (AppVersion -> f AppVersion)
-> HandlerData child site -> f (HandlerData child site)
appVersionL = (RunHandlerEnv child site -> f (RunHandlerEnv child site))
-> HandlerData child site -> f (HandlerData child site)
forall child site.
Lens' (HandlerData child site) (RunHandlerEnv child site)
envL ((RunHandlerEnv child site -> f (RunHandlerEnv child site))
 -> HandlerData child site -> f (HandlerData child site))
-> ((AppVersion -> f AppVersion)
    -> RunHandlerEnv child site -> f (RunHandlerEnv child site))
-> (AppVersion -> f AppVersion)
-> 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. Lens' (RunHandlerEnv child site) site
siteL ((site -> f site)
 -> RunHandlerEnv child site -> f (RunHandlerEnv child site))
-> ((AppVersion -> f AppVersion) -> site -> f site)
-> (AppVersion -> f AppVersion)
-> RunHandlerEnv child site
-> f (RunHandlerEnv child site)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AppVersion -> f AppVersion) -> site -> f site
forall env. HasAppVersion env => Lens' env AppVersion
appVersionL

setAppVersion :: AppVersion -> BeforeNotify
setAppVersion :: AppVersion -> BeforeNotify
setAppVersion AppVersion {UTCTime
Text
avCreatedAt :: AppVersion -> UTCTime
avName :: AppVersion -> Text
avCreatedAt :: UTCTime
avName :: Text
..} = (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
defaultApp { app_version :: Maybe Text
app_version = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
avName } }

class HasBugsnagSettings env where
  bugsnagSettingsL :: Lens' env Settings

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

instance HasBugsnagSettings site =>  HasBugsnagSettings (HandlerData child site) where
  bugsnagSettingsL :: (Settings -> f Settings)
-> HandlerData child site -> f (HandlerData child site)
bugsnagSettingsL = (RunHandlerEnv child site -> f (RunHandlerEnv child site))
-> HandlerData child site -> f (HandlerData child site)
forall child site.
Lens' (HandlerData child site) (RunHandlerEnv 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. Lens' (RunHandlerEnv child site) 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
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 :: e -> m ()
notifyBugsnag = BeforeNotify -> e -> m ()
forall (m :: * -> *) env e.
(MonadIO m, MonadReader env m, HasBugsnagSettings env,
 Exception e) =>
BeforeNotify -> e -> m ()
notifyBugsnagWith BeforeNotify
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 :: 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
bugsnagSettingsL
  m ThreadId -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m ThreadId -> m ()) -> m ThreadId -> m ()
forall a b. (a -> b) -> a -> b
$ IO ThreadId -> m ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> m ThreadId) -> IO ThreadId -> m ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
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

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 BeforeNotify -> BeforeNotify -> BeforeNotify
forall a. Semigroup a => a -> a -> a
<> BeforeNotify
toSqlException
 where
  toSqlGrouping :: BeforeNotify
toSqlGrouping = BeforeNotify
-> (Text -> BeforeNotify) -> Maybe Text -> BeforeNotify
forall b a. b -> (a -> b) -> Maybe a -> b
maybe BeforeNotify
forall a. Monoid a => a
mempty Text -> BeforeNotify
setGroupingHash (SqlError -> Maybe Text
sqlErrorGroupingHash SqlError
err)
  toSqlException :: BeforeNotify
toSqlException = (Exception -> Exception) -> BeforeNotify
updateExceptions ((Exception -> Exception) -> BeforeNotify)
-> (Exception -> Exception) -> BeforeNotify
forall a b. (a -> b) -> a -> b
$ \Exception
ex -> Exception
ex
    { exception_errorClass :: Text
exception_errorClass = ByteString -> Text
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString
"SqlError-" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
sqlState
    , exception_message :: Maybe Text
exception_message =
      Text -> Maybe Text
forall a. a -> Maybe a
Just
      (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8
      (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString
sqlErrorMsg
      ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
": "
      ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
sqlErrorDetail
      ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" ("
      ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
sqlErrorHint
      ByteString -> ByteString -> ByteString
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 (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case ConstraintViolation
violation of
    ForeignKeyViolation ByteString
table ByteString
constraint -> ByteString -> Maybe ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
table ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"." ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
constraint
    UniqueViolation ByteString
constraint -> ByteString -> Maybe ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
constraint
    ConstraintViolation
_ -> Maybe ByteString
forall a. Maybe a
Nothing

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

-- brittany-disable-next-binding

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 -> String -> Mod Var Text -> Parser Error Text
forall e a.
AsUnset e =>
Reader e a -> String -> Mod Var a -> Parser e a
Env.var Reader Error Text
forall e s. (AsEmpty e, IsString s) => Reader e s
Env.nonempty String
"BUGSNAG_API_KEY" Mod Var Text
forall a. Monoid a => a
mempty
    Parser Error (Text -> Settings)
-> Parser Error Text -> Parser Error Settings
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Reader Error Text -> String -> Mod Var Text -> Parser Error Text
forall e a.
AsUnset e =>
Reader e a -> String -> Mod Var a -> Parser e a
Env.var Reader Error Text
forall e s. (AsEmpty e, IsString s) => Reader e s
Env.nonempty String
"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 =
  (SqlError -> BeforeNotify) -> BeforeNotify
forall e. Exception e => (e -> BeforeNotify) -> BeforeNotify
updateEventFromOriginalException SqlError -> BeforeNotify
asSqlError
    BeforeNotify -> BeforeNotify -> BeforeNotify
forall a. Semigroup a => a -> a -> a
<> (HttpException -> BeforeNotify) -> BeforeNotify
forall e. Exception e => (e -> BeforeNotify) -> BeforeNotify
updateEventFromOriginalException HttpException -> BeforeNotify
asHttpException
    BeforeNotify -> BeforeNotify -> BeforeNotify
forall a. Semigroup a => a -> a -> a
<> BeforeNotify
maskErrorHelpers