freckle-app 1.21.0.0 → 1.22.0.0

raw patch · 8 files changed

+33/−552 lines, 8 filesdep +freckle-statsdep −datadogdep −ekg-coredep −extradep ~persistentPVP ok

version bump matches the API change (PVP)

Dependencies added: freckle-stats

Dependencies removed: datadog, ekg-core, extra, time

Dependency ranges changed: persistent

API changes (from Hackage documentation)

Files

• CHANGELOG.md +17/−1
• freckle-app.cabal +6/−11
• library/Freckle/App/Database.hs +2/−3
• library/Freckle/App/Ecs.hs +0/−92
• library/Freckle/App/Stats.hs +0/−390
• library/Freckle/App/Stats/Rts.hs +0/−47
• library/Freckle/App/Yesod.hs +5/−3
• package.yaml +3/−5

@@ -1,4 +1,20 @@-## [_Unreleased_](https://github.com/freckle/freckle-app/compare/freckle-app-v1.21.0.0...main)+## [_Unreleased_](https://github.com/freckle/freckle-app/compare/freckle-app-v1.22.0.0...main)++## [v1.22.0.0](https://github.com/freckle/freckle-app/compare/freckle-app-v1.21.0.0...freckle-app-v1.22.0.0)++`Freckle.App.Stats` has moved to a separate package `freckle-stats`.++When migrating to `freckle-stats`, note that the instance++```hs+instance HasStatsClient site => HasStatsClient (HandlerData child site) where+  statsClientL = envL . siteL . statsClientL+```++has been removed. If you are using Yesod, you may need to copy this definition+into your own code.++`Freckle.App.Ecs` has moved to a separate package `freckle-ecs`.  ## [v1.21.0.0](https://github.com/freckle/freckle-app/compare/freckle-app-v1.20.3.0...freckle-app-v1.21.0.0) 

@@ -1,6 +1,6 @@ cabal-version:      1.22 name:               freckle-app-version:            1.21.0.0+version:            1.22.0.0 license:            MIT license-file:       LICENSE maintainer:         Freckle Education@@ -29,15 +29,12 @@         Freckle.App.Bugsnag.SqlError         Freckle.App.Csv         Freckle.App.Database-        Freckle.App.Ecs         Freckle.App.Faktory.ProducerPool         Freckle.App.Ghci         Freckle.App.GlobalCache         Freckle.App.Json.Empty         Freckle.App.Random         Freckle.App.Scientist-        Freckle.App.Stats-        Freckle.App.Stats.Rts         Freckle.App.Test         Freckle.App.Test.DocTest         Freckle.App.Test.Hspec.AnnotatedException@@ -111,17 +108,15 @@         conduit-extra >=1.3.6,         containers >=0.6.5.1,         cookie >=0.4.6,-        datadog >=0.3.0.0,         doctest >=0.20.1,-        ekg-core >=0.1.1.7,         exceptions >=0.10.4,-        extra >=1.7.13,         faktory >=1.1.2.4,         freckle-env >=0.0.1.1,         freckle-exception >=0.0.0.0,         freckle-http >=0.0.0.0,         freckle-otel >=0.0.0.2,         freckle-prelude >=0.0.1.1,+        freckle-stats >=0.0.0.0,         hs-opentelemetry-api >=0.1.0.0,         hs-opentelemetry-instrumentation-persistent >=0.1.0.0,         hs-opentelemetry-instrumentation-wai >=0.1.0.0,@@ -140,9 +135,9 @@         nonempty-containers >=0.3.4.4,         openapi3 >=3.2.3,         path-pieces >=0.2.1,-        persistent >=2.13.3.5,+        persistent >=2.14.0.1,         persistent-postgresql >=2.13.5.2,-        persistent-sql-lifted >=1.20.3.0,+        persistent-sql-lifted >=0.1.0.0,         postgresql-simple >=0.6.4,         primitive >=0.7.3.0,         resource-pool >=0.4.0.0,@@ -152,7 +147,6 @@         servant-server >=0.19.2,         template-haskell >=2.18.0.0,         text >=1.2.5.0,-        time >=1.11.1.1,         transformers >=0.5.6.2,         transformers-base >=0.4.6,         typed-process >=0.2.11.0,@@ -242,13 +236,14 @@         cassava >=0.5.3.0,         conduit >=1.3.5,         freckle-app,+        freckle-stats >=0.0.0.0,         hs-opentelemetry-api >=0.1.0.0,         hspec >=2.10.10,         http-types >=0.12.3,         monad-validate >=1.3.0.0,         nonempty-containers >=0.3.4.4,         path-pieces >=0.2.1,-        persistent >=2.13.3.5,+        persistent >=2.14.0.1,         postgresql-simple >=0.6.4,         servant-server >=0.19.2,         vector >=0.12.3.1,

@@ -48,15 +48,14 @@ import Data.Pool import Data.Text qualified as T import Database.Persist.Postgresql-  ( SqlBackend-  , SqlPersistT+  ( SqlPersistT   , createPostgresqlPoolModified   , createSqlPool   , openSimpleConn   , runSqlPool   , runSqlPoolWithExtensibleHooks   )-import Database.Persist.Sql.Lifted+import Database.Persist.Sql.Lifted.Core import Database.Persist.SqlBackend.Internal.SqlPoolHooks (SqlPoolHooks (..)) import Database.Persist.SqlBackend.SqlPoolHooks import Database.PostgreSQL.Simple

@@ -1,92 +0,0 @@-module Freckle.App.Ecs-  ( EcsMetadata (..)-  , EcsMetadataError (..)-  , EcsContainerMetadata (..)-  , EcsContainerTaskMetadata (..)-  , getEcsMetadata-  ) where--import Freckle.App.Prelude--import Control.Monad.Except (MonadError (..))-import Data.Aeson-import Data.List.Extra (dropPrefix)-import Freckle.App.Http-import System.Environment (lookupEnv)--data EcsMetadata = EcsMetadata-  { emContainerMetadata :: EcsContainerMetadata-  , emContainerTaskMetadata :: EcsContainerTaskMetadata-  }--data EcsMetadataError-  = EcsMetadataErrorNotEnabled-  | EcsMetadataErrorInvalidURI String-  | EcsMetadataErrorUnexpectedStatus Request Status-  | EcsMetadataErrorInvalidJSON Request HttpDecodeError-  deriving stock (Show)---- | Parsing for the @/@ response------ <https://docs.aws.amazon.com/AmazonECS/latest/developerguide/task-metadata-endpoint-v4.html#task-metadata-endpoint-v4-examples>-data EcsContainerMetadata = EcsContainerMetadata-  { ecmDockerId :: Text-  , ecmDockerName :: Text-  , ecmImage :: Text-  , ecmImageID :: Text-  }-  deriving stock (Generic)--instance FromJSON EcsContainerMetadata where-  parseJSON = genericParseJSON $ aesonDropPrefix "ecm"---- | Parsing of the @/task@ response------ <https://docs.aws.amazon.com/AmazonECS/latest/developerguide/task-metadata-endpoint-v4.html#task-metadata-endpoint-v4-response>-data EcsContainerTaskMetadata = EcsContainerTaskMetadata-  { ectmCluster :: Text-  , ectmTaskARN :: Text-  , ectmFamily :: Text-  , ectmRevision :: Text-  }-  deriving stock (Generic)--instance FromJSON EcsContainerTaskMetadata where-  parseJSON = genericParseJSON $ aesonDropPrefix "ectm"--aesonDropPrefix :: String -> Options-aesonDropPrefix x = defaultOptions {fieldLabelModifier = dropPrefix x}--getEcsMetadata :: (MonadIO m, MonadError EcsMetadataError m) => m EcsMetadata-getEcsMetadata = do-  mURI <--    liftIO $-      (<|>)-        <$> lookupEnv "ECS_CONTAINER_METADATA_URI_V4"-        <*> lookupEnv-          "ECS_CONTAINER_METADATA_URI"--  uri <- maybe (throwError EcsMetadataErrorNotEnabled) pure mURI--  EcsMetadata-    <$> makeContainerMetadataRequest uri-    <*> makeContainerMetadataRequest (uri <> "/task")--makeContainerMetadataRequest-  :: (MonadIO m, MonadError EcsMetadataError m, FromJSON a) => String -> m a-makeContainerMetadataRequest uri = do-  req <--    mapEither (EcsMetadataErrorInvalidURI . displayException) $-      parseRequest uri-  resp <- liftIO $ httpJson req--  let status = getResponseStatus resp--  unless (statusIsSuccessful status) $-    throwError $-      EcsMetadataErrorUnexpectedStatus req status--  mapEither (EcsMetadataErrorInvalidJSON req) $ getResponseBody resp--mapEither :: MonadError e m => (x -> e) -> Either x a -> m a-mapEither f = either (throwError . f) pure

@@ -1,390 +0,0 @@-{-# LANGUAGE TupleSections #-}---- | An intentionally-leaky StatsD interface to Datadog-module Freckle.App.Stats-  ( -- $docs-    StatsSettings-  , defaultStatsSettings-  , setStatsSettingsTags-  , envParseStatsSettings--    -- * Client-  , StatsClient-  , tagsL-  , withStatsClient-  , HasStatsClient (..)--    -- * Gauges-  , Gauges-  , Gauge-  , dbConnections-  , dbEnqueuedAndProcessing-  , withGauge-  , lookupGauge-  , incGauge-  , decGauge--    -- * Reporting-  , tagged-  , increment-  , counter-  , gauge-  , histogram-  , histogramSince-  , histogramSinceMs-  ) where--import Freckle.App.Prelude--import Blammo.Logging.ThreadContext (MonadMask, withThreadContext)-import Control.Lens (Lens', lens, to, view, (&), (.~), (<>~))-import Control.Monad.Except (runExceptT)-import Control.Monad.Reader (local)-import Data.Aeson (Value (..))-import Data.String-import Data.Time (diffUTCTime)-import Freckle.App.Ecs-import Freckle.App.Env qualified as Env-import Network.StatsD.Datadog qualified as Datadog-import System.IO (hPutStrLn, stderr)-import System.Metrics.Gauge qualified as EKG-import UnliftIO.Exception (bracket_)-import Yesod.Core.Lens-import Yesod.Core.Types (HandlerData)--data StatsSettings = StatsSettings-  { amsEnabled :: Bool-  , amsSettings :: Datadog.DogStatsSettings-  , amsTags :: [(Text, Text)]-  }--defaultStatsSettings :: StatsSettings-defaultStatsSettings =-  StatsSettings-    { amsEnabled = False-    , amsSettings = Datadog.defaultSettings-    , amsTags = []-    }--setStatsSettingsTags :: [(Text, Text)] -> StatsSettings -> StatsSettings-setStatsSettingsTags x settings = settings {amsTags = x}--envParseStatsSettings :: Env.Parser Env.Error StatsSettings-envParseStatsSettings =-  StatsSettings-    <$> Env.switch "DOGSTATSD_ENABLED" mempty-    <*> ( buildSettings-            <$> optional (Env.var Env.str "DOGSTATSD_HOST" mempty)-            <*> optional (Env.var Env.auto "DOGSTATSD_PORT" mempty)-        )-    <*> ( buildTags-            <$> optional (Env.var Env.nonempty "DD_ENV" mempty)-            <*> optional (Env.var Env.nonempty "DD_SERVICE" mempty)-            <*> optional (Env.var Env.nonempty "DD_VERSION" mempty)-            <*> Env.var Env.keyValues "DOGSTATSD_TAGS" (Env.def [])-        )- where-  buildSettings mHost mPort =-    Datadog.defaultSettings-      & maybe id (Datadog.host .~) mHost-        . maybe id (Datadog.port .~) mPort--  buildTags mEnv mService mVersion tags =-    catMaybes-      [ ("env",) <$> mEnv-      , ("environment",) <$> mEnv -- Legacy-      , ("service",) <$> mService-      , ("version",) <$> mVersion-      ]-      <> tags--data Gauges = Gauges-  { gdbConnections :: Gauge-  -- ^ Track open db connections-  , gdbEnqueuedAndProcessing :: Gauge-  -- ^ Track enqueued and processing queries-  }--data Gauge = Gauge-  { gName :: Text-  , gGauge :: EKG.Gauge-  }--dbConnections :: Gauges -> Gauge-dbConnections = gdbConnections--dbEnqueuedAndProcessing :: Gauges -> Gauge-dbEnqueuedAndProcessing = gdbEnqueuedAndProcessing--data StatsClient = StatsClient-  { scClient :: Datadog.StatsClient-  , scTags :: [(Text, Text)]-  , scGauges :: Gauges-  }--tagsL :: Lens' StatsClient [(Text, Text)]-tagsL = lens scTags $ \x y -> x {scTags = y}--gaugesL :: Lens' StatsClient Gauges-gaugesL = lens scGauges $ \x y -> x {scGauges = y}--class HasStatsClient env where-  statsClientL :: Lens' env StatsClient--instance HasStatsClient StatsClient where-  statsClientL = id--instance HasStatsClient site => HasStatsClient (HandlerData child site) where-  statsClientL = envL . siteL . statsClientL--withStatsClient-  :: (MonadMask m, MonadUnliftIO m)-  => StatsSettings-  -> (StatsClient -> m a)-  -> m a-withStatsClient StatsSettings {..} f = do-  gauges <- liftIO $ do-    gdbConnections <- Gauge "active_pool_connections" <$> EKG.new-    gdbEnqueuedAndProcessing <- Gauge "queries_enqueued_and_processing" <$> 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-              }-    else do-      f $-        StatsClient-          { scClient = Datadog.Dummy-          , scTags = amsTags-          , scGauges = gauges-          }- where-  toPair = bimap (fromString . unpack) String--withGauge-  :: (MonadReader app m, HasStatsClient app, MonadUnliftIO m)-  => (Gauges -> Gauge)-  -> m a-  -> m a-withGauge getGauge f = do-  gauge' <- lookupGauge getGauge-  bracket_ (inc gauge') (dec gauge') f- where-  inc = incGauge-  dec = decGauge--lookupGauge-  :: (MonadReader app m, HasStatsClient app)-  => (Gauges -> Gauge)-  -> m Gauge-lookupGauge accessor = view $ statsClientL . gaugesL . to accessor--incGauge-  :: (MonadReader app m, HasStatsClient app, MonadUnliftIO m)-  => Gauge-  -> m ()-incGauge g@Gauge {..} = do-  liftIO $ EKG.inc gGauge-  publishGauge g--decGauge-  :: (MonadReader app m, HasStatsClient app, MonadUnliftIO m)-  => Gauge-  -> m ()-decGauge g@Gauge {..} = do-  liftIO $ EKG.dec gGauge-  publishGauge g--publishGauge-  :: (MonadReader app m, HasStatsClient app, MonadUnliftIO m)-  => Gauge-  -> m ()-publishGauge Gauge {..} = do-  n <- liftIO $ EKG.read gGauge-  gauge gName $ fromIntegral n---- | Include the given tags on all metrics emitted from a block-tagged-  :: (MonadReader env m, HasStatsClient env) => [(Text, Text)] -> m a -> m a-tagged tags = local $ statsClientL . tagsL <>~ tags---- | Synonym for @'counter' 1@-increment-  :: (MonadUnliftIO m, MonadReader env m, HasStatsClient env) => Text -> m ()-increment name = counter name 1--counter-  :: (MonadUnliftIO m, MonadReader env m, HasStatsClient env)-  => Text-  -> Int-  -> m ()-counter = sendMetric Datadog.Counter--gauge-  :: (MonadUnliftIO m, MonadReader env m, HasStatsClient env)-  => Text-  -> Double-  -> m ()-gauge = sendMetric Datadog.Gauge---- | Emit an elapsed duration (which Datadog calls a /histogram/)------ The 'ToMetricValue' constraint can be satisfied by most numeric types and is--- assumed to be seconds.-histogram-  :: ( MonadUnliftIO m-     , MonadReader env m-     , HasStatsClient env-     , Datadog.ToMetricValue n-     )-  => Text-  -> n-  -> m ()-histogram = sendMetric Datadog.Histogram--histogramSince-  :: (MonadUnliftIO m, MonadReader env m, HasStatsClient env)-  => Text-  -> UTCTime-  -> m ()-histogramSince = histogramSinceBy toSeconds where toSeconds = round @_ @Int--histogramSinceMs-  :: (MonadUnliftIO m, MonadReader env m, HasStatsClient env)-  => Text-  -> UTCTime-  -> m ()-histogramSinceMs = histogramSinceBy toMilliseconds- where-  toMilliseconds = (* 1000) . realToFrac @_ @Double--histogramSinceBy-  :: ( MonadUnliftIO m-     , MonadReader env m-     , HasStatsClient env-     , Datadog.ToMetricValue n-     )-  => (NominalDiffTime -> n)-  -> Text-  -> UTCTime-  -> m ()-histogramSinceBy f name time = do-  now <- liftIO getCurrentTime-  let delta = f $ now `diffUTCTime` time-  sendMetric Datadog.Histogram name delta--sendMetric-  :: ( MonadUnliftIO m-     , MonadReader env m-     , HasStatsClient env-     , Datadog.ToMetricValue v-     )-  => Datadog.MetricType-  -> Text-  -> v-  -> m ()-sendMetric metricType name metricValue = do-  StatsClient {..} <- view statsClientL--  Datadog.send scClient $-    Datadog.metric (Datadog.MetricName name) metricType metricValue-      & (Datadog.tags .~ map (uncurry Datadog.tag) scTags)--getEcsMetadataTags :: MonadIO m => m [(Text, Text)]-getEcsMetadataTags = do-  eMetadata <- runExceptT getEcsMetadata-  either (([] <$) . err) (pure . toTags) eMetadata- where-  err e = liftIO $ hPutStrLn stderr $ "Error reading ECS Metadata: " <> show e--  toTags (EcsMetadata EcsContainerMetadata {..} EcsContainerTaskMetadata {..}) =-    [ ("container_id", ecmDockerId)-    , ("container_name", ecmDockerName)-    , ("docker_image", ecmImage)-    , ("image_tag", ecmImageID)-    , ("cluster_name", ectmCluster)-    , ("task_arn", ectmTaskARN)-    , ("task_family", ectmFamily)-    , ("task_version", ectmRevision)-    ]---- $docs------ == Usage------ - Use 'envParseStatsSettings' to configure things------   @---   data AppSettings = AppSettings---    { -- ...---    , appStatsSettings :: StatsSettings---    }------   loadSettings :: IO AppSettings---   loadSettings = Env.parse id $ AppSettings---     <$> -- ...---     <*> 'envParseStatsSettings'---   @------   This will read,------   - @DOGSTATSD_ENABLED=x@---   - @DOGSTATSD_HOST=127.0.0.1@---   - @DOGSTATSD_PORT=8125@---   - @DOGSTATSD_TAGS=[<key>:<value>,...]@---   - Optionally @DD_ENV@, @DD_SERVICE@, and @DD_VERSION@------ - Give your @App@ a 'HasStatsClient' instance------   @---   data App = App---     { -- ...---     , appStatsClient :: 'StatsClient'---     }------   instance 'HasStatsClient' App where---     'statsClientL' = lens appStatsClient $ \x y -> { appStatsClient = y }---   @------ - Use 'withStatsClient' to build and store a client on your @App@ when you---   run it------   @---   'withStatsClient' appStatsSettings $ \client -> do---     app <- App---       <$> ...---       <*> pure client------     'runApp' app $ ...---   @------ - Throughout your application code, emit metrics as desired------   @---   import qualified Freckle.App.Stats as Stats------   myFunction :: (MonadIO m, MonadReader env m, 'HasStatsClient' env) => m ()---   myFunction = do---     start <- liftIO getCurrentTime---     result <- myAction------     Stats.'increment' \"action.attempt\"---     Stats.'histogramSinceMs' \"action.duration\" start------     case result of---       Left err -> do---         Stats.'increment' \"action.failure\"---         -- ...---       Right x -. do---         Stats.'increment' \"action.success\"---         -- ...---   @

@@ -1,47 +0,0 @@--- | Send RTS statistics via "Freckle.App.Stats"-module Freckle.App.Stats.Rts-  ( forkRtsStatPolling-  ) where--import Freckle.App.Prelude--import Control.Immortal qualified as Immortal-import Data.HashMap.Strict qualified as HashMap-import Freckle.App.Stats (HasStatsClient)-import Freckle.App.Stats qualified as Stats-import System.Metrics qualified as Ekg-import System.Metrics.Distribution.Internal qualified as Ekg-import UnliftIO.Concurrent (threadDelay)---- | Initialize a thread to poll RTS stats------ Stats are collected via `ekg-core` and 'System.Metrics.registerGcMetrics'-forkRtsStatPolling-  :: (MonadUnliftIO m, MonadReader env m, HasStatsClient env) => m ()-forkRtsStatPolling = do-  store <- liftIO Ekg.newStore-  liftIO $ Ekg.registerGcMetrics store--  void $ Immortal.create $ \_ -> do-    sample <- liftIO $ Ekg.sampleAll store-    traverse_ (uncurry flushEkgSample) $ HashMap.toList sample--    let seconds n = n * 1000000-    threadDelay $ seconds 1--flushEkgSample-  :: (MonadUnliftIO m, MonadReader env m, HasStatsClient env)-  => Text-  -> Ekg.Value-  -> m ()-flushEkgSample name = \case-  Ekg.Counter n -> Stats.counter name $ fromIntegral n-  Ekg.Gauge n -> Stats.gauge name $ fromIntegral n-  Ekg.Distribution d -> do-    Stats.gauge (name <> "." <> "mean") $ Ekg.mean d-    Stats.gauge (name <> "." <> "variance") $ Ekg.variance d-    Stats.gauge (name <> "." <> "sum") $ Ekg.sum d-    Stats.gauge (name <> "." <> "min") $ Ekg.min d-    Stats.gauge (name <> "." <> "max") $ Ekg.max d-    Stats.counter (name <> "." <> "count") $ fromIntegral $ Ekg.count d-  Ekg.Label _ -> pure ()

@@ -20,18 +20,20 @@ import Network.HTTP.Types (ResponseHeaders, status503) import Network.Wai qualified as W import Yesod.Core.Handler (HandlerFor, sendWaiResponse)-import Yesod.Core.Types (HandlerContents)+import Yesod.Core.Types (HandlerContents, HandlerData)  -- | Catch 'SqlError' when queries are canceled due to timeout and respond 503 -- -- Also logs and increments a metric. respondQueryCanceled-  :: HasStatsClient site => HandlerFor site res -> HandlerFor site res+  :: HasStatsClient (HandlerData site site)+  => HandlerFor site res+  -> HandlerFor site res respondQueryCanceled = respondQueryCanceledHeaders []  -- | 'respondQueryCanceledHeaders' but adding headers to the 503 response respondQueryCanceledHeaders-  :: HasStatsClient site+  :: HasStatsClient (HandlerData site site)   => ResponseHeaders   -> HandlerFor site res   -> HandlerFor site res

@@ -1,5 +1,5 @@ name: freckle-app-version: 1.21.0.0+version: 1.22.0.0  maintainer: Freckle Education category: Utils@@ -94,17 +94,15 @@     - conduit-extra     - containers     - cookie-    - datadog     - doctest-    - ekg-core     - exceptions-    - extra     - faktory     - freckle-env     - freckle-exception     - freckle-http     - freckle-otel     - freckle-prelude+    - freckle-stats     - hs-opentelemetry-api     - hs-opentelemetry-instrumentation-persistent     - hs-opentelemetry-instrumentation-wai@@ -135,7 +133,6 @@     - semigroupoids     - template-haskell     - text-    - time     - transformers     - transformers-base     - typed-process@@ -165,6 +162,7 @@       - cassava       - conduit       - freckle-app+      - freckle-stats       - hs-opentelemetry-api       - hspec       - http-types