diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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) 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.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, 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 @@ -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 diff --git a/library/Freckle/App/Ecs.hs b/library/Freckle/App/Ecs.hs deleted file mode 100644 --- a/library/Freckle/App/Ecs.hs +++ /dev/null @@ -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 --- --- -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 --- --- -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 diff --git a/library/Freckle/App/Stats.hs b/library/Freckle/App/Stats.hs deleted file mode 100644 --- a/library/Freckle/App/Stats.hs +++ /dev/null @@ -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=[:,...]@ --- - 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\" --- -- ... --- @ diff --git a/library/Freckle/App/Stats/Rts.hs b/library/Freckle/App/Stats/Rts.hs deleted file mode 100644 --- a/library/Freckle/App/Stats/Rts.hs +++ /dev/null @@ -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 () diff --git a/library/Freckle/App/Yesod.hs b/library/Freckle/App/Yesod.hs --- a/library/Freckle/App/Yesod.hs +++ b/library/Freckle/App/Yesod.hs @@ -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 diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -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