freckle-app 1.7.1.0 → 1.8.0.0

raw patch · 6 files changed

+63/−25 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−1
• freckle-app.cabal +1/−1
• library/Freckle/App/Database.hs +11/−3
• library/Freckle/App/Stats.hs +41/−19
• library/Freckle/App/Test.hs +3/−0
• package.yaml +1/−1

@@ -1,4 +1,9 @@-## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.7.1.0...main)+## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.8.0.0...main)++## [v1.8.0.0](https://github.com/freckle/freckle-app/compare/v1.7.1.0...v1.8.0.0)++- Fix bug: gauges not being published.+- Add HasVaultData type class to remove the dependency on Yesod's MonadHandler  ## [v1.7.1.0](https://github.com/freckle/freckle-app/compare/v1.7.0.0...v1.7.1.0) 

@@ -1,6 +1,6 @@ cabal-version:      1.18 name:               freckle-app-version:            1.7.1.0+version:            1.8.0.0 license:            MIT license-file:       LICENSE maintainer:         Freckle Education

@@ -8,6 +8,7 @@ -- | Database access for your @App@ module Freckle.App.Database   ( HasSqlPool(..)+  , HasVaultData(..)   , SqlPool   , makePostgresPool   , makePostgresPoolWith@@ -54,7 +55,8 @@ import UnliftIO.Concurrent (threadDelay) import UnliftIO.Exception (displayException) import UnliftIO.IORef-import Yesod.Core (MonadHandler, MonadUnliftIO(withRunInIO), waiRequest)+import Yesod.Core (MonadUnliftIO(withRunInIO), YesodRequest(reqWaiRequest))+import Yesod.Core.Types (HandlerData(handlerRequest))  type SqlPool = Pool SqlBackend @@ -64,6 +66,12 @@ instance HasSqlPool SqlPool where   getSqlPool = id +class HasVaultData env where+  getVaultData :: env -> Maybe XRayVaultData++instance HasVaultData (HandlerData child site) where+  getVaultData = vaultDataFromRequest . reqWaiRequest . handlerRequest+ makePostgresPool :: (MonadUnliftIO m, MonadLoggerIO m) => m SqlPool makePostgresPool = do   conf <- liftIO $ do@@ -74,7 +82,7 @@ runDB   :: ( HasSqlPool app      , HasStatsClient app-     , MonadHandler m+     , HasVaultData app      , MonadUnliftIO m      , MonadReader app m      )@@ -82,7 +90,7 @@   -> m a runDB action = do   pool <- asks getSqlPool-  mVaultData <- vaultDataFromRequest <$> waiRequest+  mVaultData <- asks getVaultData   Stats.withGauge Stats.dbConnections $     maybe       runSqlPool

@@ -18,7 +18,7 @@    -- * Gauges   , Gauges-  , GaugeName+  , Gauge   , dbConnections   , withGauge @@ -93,19 +93,18 @@         ]       <> tags --- should be data but newtype for now because there's only one and only one planned newtype Gauges = Gauges-  { gdbConnections :: EKG.Gauge+  { gdbConnections :: Gauge   -- ^ Track open db connections   } --- Opaque wrapper to hide EKG.Gauge-newtype GaugeName = GaugeName-  { unGaugeName :: Gauges -> EKG.Gauge+data Gauge = Gauge+  { gName :: Text+  , gGauge :: EKG.Gauge   } -dbConnections :: GaugeName-dbConnections = GaugeName gdbConnections+dbConnections :: Gauges -> Gauge+dbConnections = gdbConnections  data StatsClient = StatsClient   { scClient :: Datadog.StatsClient@@ -134,25 +133,48 @@   -> (StatsClient -> m a)   -> m a withStatsClient StatsSettings {..} f = do-  gauges <- liftIO $ fmap Gauges EKG.new+  gauges <- liftIO $ do+    gdbConnections <- Gauge "active_pool_connections" <$> EKG.new+    pure Gauges { .. }+   if amsEnabled     then do       tags <- (amsTags <>) <$> getEcsMetadataTags       Datadog.withDogStatsD amsSettings $ \client ->         -- Add the tags to the thread context so they're present in all logs-        withThreadContext (map toPair tags)-          $ f StatsClient { scClient = client, scTags = tags, scGauges = gauges }+        withThreadContext (map toPair tags) $ f StatsClient+          { scClient = client+          , scTags = tags+          , scGauges = gauges+          }     else do-      f $ StatsClient { scClient = Datadog.Dummy, scTags = amsTags, scGauges = gauges }+      f $ StatsClient+        { scClient = Datadog.Dummy+        , scTags = amsTags+        , scGauges = gauges+        }   where toPair = bimap (fromString . unpack) String -withGauge :: (MonadReader app m, HasStatsClient app, MonadUnliftIO m) => GaugeName -> m a -> m a-withGauge gaugeName f = do-  gauge' <- view $ statsClientL . gaugesL . to (unGaugeName gaugeName)-  bracket_ (plus1 gauge') (minus1 gauge') f-  where-    plus1 g = liftIO $ EKG.add g 1-    minus1 g = liftIO $ EKG.subtract g 1+withGauge+  :: (MonadReader app m, HasStatsClient app, MonadUnliftIO m)+  => (Gauges -> Gauge)+  -> m a+  -> m a+withGauge getGauge f = do+  gauge' <- view $ statsClientL . gaugesL . to getGauge+  bracket_ (inc gauge') (dec gauge') f+ where+  inc g@Gauge {..} = do+    liftIO $ EKG.inc gGauge+    publish g++  dec g@Gauge {..} = do+    liftIO $ EKG.dec gGauge+    publish g++  publish Gauge {..} = do+    n <- liftIO $ EKG.read gGauge+    gauge gName $ fromIntegral n  -- | Include the given tags on all metrics emitted from a block tagged

@@ -103,6 +103,9 @@     params     ($ ()) +instance HasVaultData app => HasVaultData (AppExample app a) where+  getVaultData = asks getVaultData+ -- | A type restricted version of id -- -- Like 'example', which forces the expectation to 'IO', this can be used to

@@ -1,6 +1,6 @@ --- name: freckle-app-version: 1.7.1.0+version: 1.8.0.0 maintainer: Freckle Education category: Utils github: freckle/freckle-app