diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,9 @@ -## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.0.2.10...main) +## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.0.4.0...main) + +## [v1.0.4.0](https://github.com/freckle/freckle-app/compare/v1.0.3.0...v1.0.4.0) + +- Add `Freckle.App.Bugsnag` for Bugsnag logging in applications. +- Increased default PG poolsize to 10. ## [v1.0.3.0](https://github.com/freckle/freckle-app/compare/v1.0.2.10...v1.0.3.0) diff --git a/freckle-app.cabal b/freckle-app.cabal --- a/freckle-app.cabal +++ b/freckle-app.cabal @@ -1,6 +1,6 @@ cabal-version: 1.18 name: freckle-app -version: 1.0.3.0 +version: 1.0.4.0 license: MIT license-file: LICENSE maintainer: Freckle Education @@ -26,6 +26,7 @@ library exposed-modules: Freckle.App + Freckle.App.Bugsnag Freckle.App.Database Freckle.App.Datadog Freckle.App.Datadog.Gauge @@ -75,6 +76,7 @@ aeson >=1.3.1.1, ansi-terminal >=0.8.2, base >=4.11.1.0 && <5, + bugsnag >=1.0.0.1, bytestring >=0.10.8.2, case-insensitive >=1.2.0.11, conduit >=1.3.1, @@ -189,6 +191,7 @@ main-is: Main.hs hs-source-dirs: tests other-modules: + Freckle.App.BugsnagSpec Freckle.App.Env.InternalSpec Freckle.App.HttpSpec Freckle.App.Memcached.ServersSpec @@ -221,6 +224,7 @@ memcache >=0.2.0.1, monad-logger >=0.3.31, mtl >=2.2.2, + postgresql-simple >=0.5.4.0, unliftio-core >=0.1.2.0, wai >=3.2.1.2, wai-extra >=3.0.24.3 diff --git a/library/Freckle/App/Bugsnag.hs b/library/Freckle/App/Bugsnag.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Bugsnag.hs @@ -0,0 +1,164 @@ +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 = id + +instance HasAppVersion site => HasAppVersion (HandlerData child site) where + appVersionL = envL . siteL . appVersionL + +setAppVersion :: AppVersion -> BeforeNotify +setAppVersion AppVersion {..} = updateEvent $ \event -> + event { event_app = Just $ defaultApp { app_version = Just avName } } + +class HasBugsnagSettings env where + bugsnagSettingsL :: Lens' env Settings + +instance HasBugsnagSettings Settings where + bugsnagSettingsL = id + +instance HasBugsnagSettings site => HasBugsnagSettings (HandlerData child site) where + bugsnagSettingsL = envL . siteL . 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 = notifyBugsnagWith mempty + +-- | 'notifyBugsnag' with a 'BeforeNotify' +notifyBugsnagWith + :: ( MonadIO m + , MonadReader env m + , HasBugsnagSettings env + , Exception.Exception e + ) + => BeforeNotify + -> e + -> m () +notifyBugsnagWith f ex = do + settings <- view bugsnagSettingsL + void $ liftIO $ forkIO $ Bugsnag.notifyBugsnagWith f settings ex + +asSqlError :: SqlError -> BeforeNotify +asSqlError err@SqlError {..} = toSqlGrouping <> toSqlException + where + toSqlGrouping = maybe mempty setGroupingHash (sqlErrorGroupingHash err) + toSqlException = updateExceptions $ \ex -> ex + { exception_errorClass = decodeUtf8 $ "SqlError-" <> sqlState + , exception_message = + Just + $ decodeUtf8 + $ sqlErrorMsg + <> ": " + <> sqlErrorDetail + <> " (" + <> sqlErrorHint + <> ")" + } + +sqlErrorGroupingHash :: SqlError -> Maybe Text +sqlErrorGroupingHash err = do + violation <- constraintViolation err + decodeUtf8 <$> case violation of + ForeignKeyViolation table constraint -> pure $ table <> "." <> constraint + UniqueViolation constraint -> pure constraint + _ -> Nothing + +asHttpException :: HttpException -> BeforeNotify +asHttpException (HttpExceptionRequest req content) = + setGroupingHash (decodeUtf8 $ host req) <> update + where + update = updateExceptions $ \ex -> ex + { exception_errorClass = "HttpExceptionRequest" + , exception_message = + Just + . decodeUtf8 + $ method req + <> " request to " + <> host req + <> " failed: " + <> BS8.pack (show content) + } +asHttpException (InvalidUrlException url msg) = updateExceptions $ \ex -> ex + { exception_errorClass = "InvalidUrlException" + , exception_message = Just $ pack $ url <> " is invalid: " <> 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 = setStackFramesInProjectByFile (`isInfixOf` "Exceptions") + +-- brittany-disable-next-binding + +envParseBugsnagSettings :: Env.Parser Settings +envParseBugsnagSettings = + build + <$> Env.var Env.str "BUGSNAG_API_KEY" Env.nonEmpty + <*> Env.var Env.str "BUGSNAG_RELEASE_STAGE" (Env.def "development") + where + build key stage = (defaultSettings key) + { settings_releaseStage = stage + , settings_beforeNotify = globalBeforeNotify + } + +globalBeforeNotify :: BeforeNotify +globalBeforeNotify = + updateEventFromOriginalException asSqlError + <> updateEventFromOriginalException asHttpException + <> maskErrorHelpers diff --git a/library/Freckle/App/Database.hs b/library/Freckle/App/Database.hs --- a/library/Freckle/App/Database.hs +++ b/library/Freckle/App/Database.hs @@ -147,7 +147,7 @@ host <- Env.var Env.str "PGHOST" Env.nonEmpty database <- Env.var Env.str "PGDATABASE" Env.nonEmpty port <- Env.var Env.auto "PGPORT" Env.nonEmpty - poolSize <- Env.var Env.auto "PGPOOLSIZE" $ Env.def 1 + poolSize <- Env.var Env.auto "PGPOOLSIZE" $ Env.def 10 statementTimeout <- Env.var (Env.eitherReader readPostgresStatementTimeout) "PGSTATEMENTTIMEOUT" $ Env.def (PostgresStatementTimeoutSeconds 120) diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -1,6 +1,6 @@ --- name: freckle-app -version: 1.0.3.0 +version: 1.0.4.0 maintainer: Freckle Education category: Utils github: freckle/freckle-app @@ -56,6 +56,7 @@ - MonadRandom - aeson - ansi-terminal + - bugsnag - bytestring - case-insensitive - conduit @@ -129,6 +130,7 @@ - memcache - monad-logger - mtl + - postgresql-simple - unliftio-core - wai - wai-extra diff --git a/tests/Freckle/App/BugsnagSpec.hs b/tests/Freckle/App/BugsnagSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Freckle/App/BugsnagSpec.hs @@ -0,0 +1,135 @@ +module Freckle.App.BugsnagSpec + ( spec + ) where + +import Freckle.App.Prelude + +import Data.ByteString (ByteString) +import Database.PostgreSQL.Simple (ExecStatus(..), SqlError(..)) +import Freckle.App.Bugsnag +import Test.Hspec + +spec :: Spec +spec = do + describe "sqlErrorGroupingHash" $ do + it "groups duplicate key errors by constraint name" $ do + let + err1 = sqlError + { sqlState = duplicateKeyState + , sqlErrorMsg = duplicateKeyErrorMsg "table_a_id_key" + , sqlErrorDetail = "Key (a, b)=(1, 2) already exists" + } + err2 = sqlError + { sqlState = duplicateKeyState + , sqlErrorMsg = duplicateKeyErrorMsg "table_a_id_key" + , sqlErrorDetail = "Key (a, b)=(3, 2) already exists" + } + err3 = sqlError + { sqlState = duplicateKeyState + , sqlErrorMsg = duplicateKeyErrorMsg "table_b_id_key" + , sqlErrorDetail = "Key (a, b)=(1, 2) already exists" + } + + -- All duplicate keys hashed + sqlErrorGroupingHash err1 `shouldSatisfy` isJust + sqlErrorGroupingHash err2 `shouldSatisfy` isJust + sqlErrorGroupingHash err3 `shouldSatisfy` isJust + + -- 1 and 2 are grouped, 3 is not (different constraint) + sqlErrorGroupingHash err1 `shouldBe` sqlErrorGroupingHash err2 + sqlErrorGroupingHash err1 `shouldNotBe` sqlErrorGroupingHash err3 + sqlErrorGroupingHash err2 `shouldNotBe` sqlErrorGroupingHash err3 + + it "groups foreign key errors by constraint name" $ do + let + err1 = sqlError + { sqlState = foreignKeyState + , sqlErrorMsg = foreignKeyErrorMsg "table_a" "table_b_id_fkey" + , sqlErrorDetail = "Key (a, b)=(1, 2) is still referenced" + } + err2 = sqlError + { sqlState = foreignKeyState + , sqlErrorMsg = foreignKeyErrorMsg "table_a" "table_b_id_fkey" + , sqlErrorDetail = "Key (a, b)=(3, 2) is still referenced" + } + err3 = sqlError + { sqlState = foreignKeyState + , sqlErrorMsg = foreignKeyErrorMsg "table_b" "table_b_id_key" + , sqlErrorDetail = "Key (a, b)=(1, 2) is still referenced" + } + err4 = sqlError + { sqlState = foreignKeyState + , sqlErrorMsg = foreignKeyErrorMsg "table_a" "table_a_id_key" + , sqlErrorDetail = "Key (a, b)=(1, 2) is still referenced" + } + + -- All errors hashed + sqlErrorGroupingHash err1 `shouldSatisfy` isJust + sqlErrorGroupingHash err2 `shouldSatisfy` isJust + sqlErrorGroupingHash err3 `shouldSatisfy` isJust + sqlErrorGroupingHash err4 `shouldSatisfy` isJust + + -- 1 and 2 are grouped, 3 and 4 are not (different table or constraint) + sqlErrorGroupingHash err1 `shouldBe` sqlErrorGroupingHash err2 + sqlErrorGroupingHash err1 `shouldNotBe` sqlErrorGroupingHash err3 + sqlErrorGroupingHash err2 `shouldNotBe` sqlErrorGroupingHash err3 + sqlErrorGroupingHash err1 `shouldNotBe` sqlErrorGroupingHash err4 + sqlErrorGroupingHash err2 `shouldNotBe` sqlErrorGroupingHash err4 + sqlErrorGroupingHash err3 `shouldNotBe` sqlErrorGroupingHash err4 + + it "does not group other SqlErrors" $ do + let + err = sqlError + { sqlState = "9999" + , sqlErrorMsg = duplicateKeyErrorMsg "table_a_id_key" + , sqlErrorDetail = "Key (a, b)=(1, 2) already exists" + } + + sqlErrorGroupingHash err `shouldBe` Nothing + + it "does not group other states" $ do + let + err = sqlError + { sqlState = "12345" + , sqlErrorMsg = "State is wrong, \"table_a_id_key\"" + , sqlErrorDetail = "Key (a, b)=(1, 2) already exists" + } + + sqlErrorGroupingHash err `shouldBe` Nothing + + it "does not group when unable to parse" $ do + let + err = sqlError + { sqlState = foreignKeyState + , sqlErrorMsg = "FK needs two quoted values, \"table_a_id_fkey\"" + , sqlErrorDetail = "Key (a, b)=(1, 2) already exists" + } + + sqlErrorGroupingHash err `shouldBe` Nothing + +sqlError :: SqlError +sqlError = SqlError + { sqlState = "" + , sqlExecStatus = FatalError + , sqlErrorMsg = "" + , sqlErrorDetail = "" + , sqlErrorHint = "" + } + +duplicateKeyState :: ByteString +duplicateKeyState = "23505" + +duplicateKeyErrorMsg :: ByteString -> ByteString +duplicateKeyErrorMsg constraint = + "duplicate key value violates unique constraint \"" <> constraint <> "\"" + +foreignKeyState :: ByteString +foreignKeyState = "23503" + +foreignKeyErrorMsg :: ByteString -> ByteString -> ByteString +foreignKeyErrorMsg table constraint = + "update or delete on table \"" + <> table + <> "\" violates foreign key constraint \"" + <> constraint + <> "\" on table \"unused\""