diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +## [_Unreleased_](https://github.com/freckle/freckle-app/compare/freckle-stats-v0.0.0.0...main) + +## [v0.0.0.0](https://github.com/freckle/freckle-app/tree/freckle-stats-v0.0.0.0/freckle-stats) + +First release, sprouted from `freckle-app-1.21.0.0`. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2021-2024 Renaissance Learning Inc + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# freckle-stats + +An intentionally-leaky StatsD interface to Datadog diff --git a/freckle-stats.cabal b/freckle-stats.cabal new file mode 100644 --- /dev/null +++ b/freckle-stats.cabal @@ -0,0 +1,61 @@ +cabal-version: 1.18 +name: freckle-stats +version: 0.0.0.0 +license: MIT +license-file: LICENSE +maintainer: Freckle Education +homepage: https://github.com/freckle/freckle-app#readme +bug-reports: https://github.com/freckle/freckle-app/issues +synopsis: An intentionally-leaky StatsD interface to Datadog +description: Please see README.md +category: Prelude +build-type: Simple +extra-source-files: package.yaml +extra-doc-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/freckle/freckle-app + +library + exposed-modules: + Freckle.App.Stats + Freckle.App.Stats.Rts + + hs-source-dirs: library + other-modules: Paths_freckle_stats + default-language: GHC2021 + default-extensions: + DataKinds DeriveAnyClass DerivingVia DerivingStrategies GADTs + LambdaCase NoImplicitPrelude NoMonomorphismRestriction + OverloadedStrings RecordWildCards TypeFamilies + + ghc-options: + -fignore-optim-changes -fwrite-ide-info -Weverything + -Wno-all-missed-specialisations -Wno-missing-exported-signatures + -Wno-missing-import-lists -Wno-missing-kind-signatures + -Wno-missing-local-signatures -Wno-missing-safe-haskell-mode + -Wno-monomorphism-restriction -Wno-prepositive-qualified-module + -Wno-safe -Wno-unsafe + + build-depends: + Blammo >=2.1.0.0, + aeson >=2.0.3.0, + base >=4.16.4.0 && <5, + datadog >=0.3.0.0, + ekg-core >=0.1.1.7, + freckle-ecs >=0.0.0.0, + freckle-env >=0.0.1.1, + freckle-prelude >=0.0.1.1, + immortal >=0.3, + lens >=5.1.1, + mtl >=2.2.2, + time >=1.11.1.1, + unliftio >=0.2.25.0, + unordered-containers >=0.2.19.1 + + if impl(ghc >=9.8) + ghc-options: + -Wno-missing-role-annotations -Wno-missing-poly-kind-signatures diff --git a/library/Freckle/App/Stats.hs b/library/Freckle/App/Stats.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Stats.hs @@ -0,0 +1,385 @@ +{-# 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_) + +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 + +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 new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Stats/Rts.hs @@ -0,0 +1,47 @@ +-- | 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/package.yaml b/package.yaml new file mode 100644 --- /dev/null +++ b/package.yaml @@ -0,0 +1,70 @@ +name: freckle-stats +version: 0.0.0.0 +maintainer: Freckle Education +category: Prelude +github: freckle/freckle-app +synopsis: An intentionally-leaky StatsD interface to Datadog +description: Please see README.md + +extra-doc-files: + - README.md + - CHANGELOG.md + +extra-source-files: + - package.yaml + +language: GHC2021 + +ghc-options: + - -fignore-optim-changes + - -fwrite-ide-info + - -Weverything + - -Wno-all-missed-specialisations + - -Wno-missing-exported-signatures # re-enables missing-signatures + - -Wno-missing-import-lists + - -Wno-missing-kind-signatures + - -Wno-missing-local-signatures + - -Wno-missing-safe-haskell-mode + - -Wno-monomorphism-restriction + - -Wno-prepositive-qualified-module + - -Wno-safe + - -Wno-unsafe + +when: + - condition: "impl(ghc >= 9.8)" + ghc-options: + - -Wno-missing-role-annotations + - -Wno-missing-poly-kind-signatures + +dependencies: + - base < 5 + +default-extensions: + - DataKinds + - DeriveAnyClass + - DerivingVia + - DerivingStrategies + - GADTs + - LambdaCase + - NoImplicitPrelude + - NoMonomorphismRestriction + - OverloadedStrings + - RecordWildCards + - TypeFamilies + +library: + source-dirs: library + dependencies: + - aeson + - Blammo + - datadog + - ekg-core + - freckle-ecs + - freckle-env + - freckle-prelude + - immortal + - lens + - mtl + - time + - unliftio + - unordered-containers