freckle-app 1.0.3.0 → 1.0.4.0

raw patch · 6 files changed

+314/−4 lines, 6 filesdep +bugsnagPVP ok

version bump matches the API change (PVP)

Dependencies added: bugsnag

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−1
• freckle-app.cabal +5/−1
• library/Freckle/App/Bugsnag.hs +164/−0
• library/Freckle/App/Database.hs +1/−1
• package.yaml +3/−1
• tests/Freckle/App/BugsnagSpec.hs +135/−0

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

@@ -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

@@ -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

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

@@ -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

@@ -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\""