freckle-app 1.4.0.0 → 1.5.0.0
raw patch · 22 files changed
+699/−483 lines, 22 filesdep +QuickCheckdep +extradep +path-pieces
Dependencies added: QuickCheck, extra, path-pieces
Files
- CHANGELOG.md +50/−1
- freckle-app.cabal +13/−4
- library/Freckle/App.hs +34/−60
- library/Freckle/App/Datadog.hs +0/−207
- library/Freckle/App/Datadog/Gauge.hs +0/−86
- library/Freckle/App/Datadog/Rts.hs +0/−57
- library/Freckle/App/Ecs.hs +57/−0
- library/Freckle/App/Memcached/Client.hs +13/−0
- library/Freckle/App/Scientist.hs +17/−20
- library/Freckle/App/Stats.hs +280/−0
- library/Freckle/App/Stats/Gauge.hs +63/−0
- library/Freckle/App/Stats/Rts.hs +48/−0
- library/Freckle/App/Test.hs +9/−4
- library/Freckle/App/Test/Properties/JSON.hs +11/−0
- library/Freckle/App/Test/Properties/PathPiece.hs +11/−0
- library/Freckle/App/Wai.hs +3/−31
- library/Freckle/App/Yesod.hs +5/−7
- library/Network/Wai/Middleware/Stats.hs +29/−0
- package.yaml +4/−1
- tests/Freckle/App/MemcachedSpec.hs +6/−5
- tests/Freckle/App/Test/Properties/JSONSpec.hs +28/−0
- tests/Freckle/App/Test/Properties/PathPieceSpec.hs +18/−0
CHANGELOG.md view
@@ -1,4 +1,53 @@-## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.4.0.0...main)+## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.5.0.0...main)++## [v1.5.0.0](https://github.com/freckle/freckle-app/compare/v1.4.0.0...v1.5.0.0)++- Remove `Freckle.App.Datadog` modules for `Freckle.App.Stats` equivalents++ It's not a drop-in, but the required changes should be mechanical:++ - Instead of `HasDogStats{Client,Tags}`, implement a single `HasStatsClient`+ - Instead of `mkStatsClient` use `withStatsClient` (the new style of `runApp`+ had will enable that)+ - Use `tagged` instead of extra arguments to metric sends+ - Move to the new `Rts`, `Gauge`, and `Middleware.Stats` modules++- Change signature of `runApp` and `withApp`++ Instead of passing a loaded `App` (or a function that loads an `App`) to+ `runApp` and `withApp`, you should now pass a function that _takes a function_+ and calls it on the loaded `App`.++ This is necessary for apps that hold onto values that require cleanup, like+ `withStatsClient`.++ ```hs+ -- This doesn't work+ loadApp :: IO App+ loadApp = do+ -- ...+ withStatsClient $ \appStatsClient -> do+ -- ???++ -- This does+ loadApp :: (App -> IO a) -> IO a+ loadApp f = do+ -- ...+ withStatsClient $ \appStatsClient -> do+ f App { .. }+ ```++ The old form can be trivially converted to the new form like so,++ ```hs+ loadApp :: (App -> IO a) -> IO a+ loadApp f = f =<< loadApp'++ loadApp' :: IO App+ loadApp' = -- old code+ ```++- Add functions that check properties that we like to commonly test. ## [v1.4.0.0](https://github.com/freckle/freckle-app/compare/v1.3.0.0...v1.4.0.0)
freckle-app.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.18 name: freckle-app-version: 1.4.0.0+version: 1.5.0.0 license: MIT license-file: LICENSE maintainer: Freckle Education@@ -28,9 +28,7 @@ Freckle.App Freckle.App.Bugsnag Freckle.App.Database- Freckle.App.Datadog- Freckle.App.Datadog.Gauge- Freckle.App.Datadog.Rts+ Freckle.App.Ecs Freckle.App.Env Freckle.App.Ghci Freckle.App.GlobalCache@@ -44,14 +42,20 @@ Freckle.App.Memcached.Servers Freckle.App.Prelude Freckle.App.Scientist+ Freckle.App.Stats+ Freckle.App.Stats.Gauge+ Freckle.App.Stats.Rts Freckle.App.Test Freckle.App.Test.DocTest Freckle.App.Test.Hspec.Runner+ Freckle.App.Test.Properties.JSON+ Freckle.App.Test.Properties.PathPiece Freckle.App.Version Freckle.App.Wai Freckle.App.Yesod Freckle.App.Yesod.Routes Network.HTTP.Link.Compat+ Network.Wai.Middleware.Stats Yesod.Core.Lens hs-source-dirs: library@@ -83,6 +87,7 @@ envparse >=0.5.0, errors >=2.3.0, exceptions >=0.10.0,+ extra >=1.6.14, filepath >=1.4.2, hashable >=1.2.7.0, hspec >=2.8.1,@@ -100,6 +105,7 @@ monad-control >=1.0.2.3, mtl >=2.2.2, network-uri >=2.6.1.0,+ path-pieces >=0.2.1, persistent >=2.9.0, persistent-postgresql >=2.9.0, postgresql-simple >=0.6.2,@@ -186,6 +192,8 @@ Freckle.App.HttpSpec Freckle.App.Memcached.ServersSpec Freckle.App.MemcachedSpec+ Freckle.App.Test.Properties.JSONSpec+ Freckle.App.Test.Properties.PathPieceSpec Freckle.App.WaiSpec Spec Paths_freckle_app@@ -203,6 +211,7 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: Blammo >=1.0.2.2,+ QuickCheck >=2.13.1, aeson >=1.5.2.0, base >=4.11.1.0 && <5, bytestring >=0.10.8.2,
library/Freckle/App.hs view
@@ -22,28 +22,27 @@ -- > instance HasLogger App where -- > loggerL = lens appLogger $ \x y -> x { appLogger = y } ----- and a way to build a value:+-- and a bracketed function for building and using a value: ----- > loadApp :: IO App+-- > loadApp :: (App -> m a) -> m a+-- > loadApp f = do+-- > app <- -- ...+-- > f app -- -- It's likely you'll want to use @"Freckle.App.Env"@ to load your @App@: -- -- > import qualified Blammo.Logger.LogSettings.Env as LoggerEnv -- > import qualified Freckle.App.Env as Env -- >--- > loadApp = Env.parse id $ App--- > <$> Env.switch "DRY_RUN" mempty--- > <*> LoggerEnv.parser------ Though not required, a type synonym can make things throughout your--- application a bit more readable:------ > type AppM = ReaderT App (LoggingT IO)+-- > loadApp f = do+-- > app <- Env.parse id $ App+-- > <$> Env.switch "DRY_RUN" mempty+-- > <*> LoggerEnv.parser -- -- Now you have application-specific actions that can do IO, log, and access -- your state: ----- > myAppAction :: AppM ()+-- > myAppAction :: (MonadIO m, MonadLogger m, MonadReader App env) => m () -- > myAppAction = do -- > isDryRun <- asks appDryRun -- >@@ -56,8 +55,7 @@ -- -- > main :: IO () -- > main = do--- > app <- loadApp--- > runApp app $ do+-- > runApp loadApp $ do -- > myAppAction -- > myOtherAppAction --@@ -96,71 +94,43 @@ -- The @"Freckle.App.Database"@ module provides @'makePostgresPool'@ for -- building a Pool given this (limited) config data: ----- > loadApp :: IO App--- > loadApp = do+-- > loadApp :: (App -> IO a) -> IO a+-- > loadApp f = do -- > appConfig{..} <- loadConfig -- > appLogger <- newLogger configLoggerSettings -- > appSqlPool <- runLoggerLoggingT appLogger $ makePostgresPool configDbPoolSize--- > pure App{..}------ /Note/: the actual database connection parameters (host, user, etc) are--- (currently) parsed from conventional environment variables by the underlying--- driver directly. Our application configuration is only involved in declaring--- the pool size.+-- > f App{..} -- -- This unlocks @'runDB'@ for your application: ----- > myAppAction :: AppM [Entity Something]+-- > myAppAction+-- > :: (MonadIO m, MonadReader env m, HasSqlPool env)+-- > => SqlPersistT m [Entity Something] -- > myAppAction = runDB $ selectList [] [] -- -- == Testing -- -- @"Freckle.App.Test"@ exposes an @'AppExample'@ type for examples in a -- @'SpecWith' App@ spec. The can be run by giving your @loadApp@ function to--- Hspec's @'before'@.+-- Hspec's @'aroundAll'@. ----- Our @Test@ module also exposes @'runAppTest'@ for running @AppM@ actions and--- lifted expectations for use within such an example.+-- Using MTL-style constraints (i.e. 'MonadReader') means you can use your+-- actions directly in expectations, but you may need some type annotations: -- -- > spec :: Spec--- > spec = before loadApp $ do+-- > spec = aroundAll loadApp $ do -- > describe "myAppAction" $ do -- > it "works" $ do--- > result <- runAppTest myAppAction+-- > result <- myAppAction :: AppExample App Text -- > result `shouldBe` "as expected" ----- If your application makes use of the database, a few things will have to be--- different:------ First, we want to have a specialized @'runDB'@ in tests to avoid excessive--- annotations because of the generalized type of @'runDB'@ itself:------ > import Database.Persist.Sql--- > import qualified Freckle.App.Database as DB--- >--- > runDB :: SqlPersistM IO a -> AppExample App a--- > runDB = DB.runDB------ Second, we'll probably want a conventional @withApp@ function so that we can--- truncate tables as part of spec setup:------ > import Freckle.App.Test hiding (withApp)--- > import Test.Hspec--- >--- > withApp :: SpecWith App -> Spec--- > withApp = withAppSql truncateTables loadApp------ And now you can write specs that also use the database:+-- If your app type 'HasSqlPool', you can use 'runDB' in your specs too: -- -- > spec :: Spec--- > spec = withApp $ do--- > describe "myAppAction" $ do--- > it "works" . withGraph runDB do--- > nodeWith -- ...--- > nodeWith -- ...--- > nodeWith -- ...--- >--- > result <- lift $ runAppTest myAppAction+-- > spec = aroundAll loadApp $ do+-- > describe "myQuery" $ do+-- > it "works" $ do+-- > result <- runDB myQuery :: AppExample App Text -- > result `shouldBe` "as expected" -- module Freckle.App@@ -175,9 +145,13 @@ import Freckle.App.Database as X import System.IO (BufferMode(..), hSetBuffering, stderr, stdout) -runApp :: HasLogger app => app -> ReaderT app (LoggingT IO) a -> IO a-runApp app action = do+runApp+ :: HasLogger app+ => (forall b . (app -> IO b) -> IO b)+ -> ReaderT app (LoggingT IO) a+ -> IO a+runApp loadApp action = do -- Ensure output is streamed if in a Docker container hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering- runLoggerLoggingT app $ runReaderT action app+ loadApp $ \app -> runLoggerLoggingT app $ runReaderT action app
− library/Freckle/App/Datadog.hs
@@ -1,207 +0,0 @@-{-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE NamedFieldPuns #-}---- | Datadog access for your @App@-module Freckle.App.Datadog- ( HasDogStatsClient(..)- , HasDogStatsTags(..)- , StatsClient- , Tag-- -- * Lower-level operations- , sendAppMetricWithTags-- -- * Higher-level operations- , increment- , counter- , gauge- , histogram- , histogramSince- , histogramSinceMs-- -- * Reading settings at startup- , DogStatsSettings(..)- , envParseDogStatsEnabled- , envParseDogStatsSettings- , envParseDogStatsTags- , mkStatsClient-- -- * To be removed in next major bump- , guage- ) where--import Freckle.App.Prelude--import Control.Lens (set)-import Control.Monad.Reader-import Data.Time (diffUTCTime)-import qualified Freckle.App.Env as Env-import Network.StatsD.Datadog hiding (metric, name, tags)-import qualified Network.StatsD.Datadog as Datadog-import Yesod.Core.Types (HandlerData, handlerEnv, rheSite)--class HasDogStatsClient app where- getDogStatsClient :: app -> Maybe StatsClient--instance HasDogStatsClient site => HasDogStatsClient (HandlerData child site) where- getDogStatsClient = getDogStatsClient . rheSite . handlerEnv--class HasDogStatsTags app where- getDogStatsTags :: app -> [Tag]--instance HasDogStatsTags site => HasDogStatsTags (HandlerData child site) where- getDogStatsTags = getDogStatsTags . rheSite . handlerEnv--increment- :: ( MonadUnliftIO m- , MonadReader env m- , HasDogStatsClient env- , HasDogStatsTags env- )- => Text- -> [(Text, Text)]- -> m ()-increment name tags = counter name tags 1--counter- :: ( MonadUnliftIO m- , MonadReader env m- , HasDogStatsClient env- , HasDogStatsTags env- )- => Text- -> [(Text, Text)]- -> Int- -> m ()-counter name tags = sendAppMetricWithTags name tags Counter--gauge- :: ( MonadUnliftIO m- , MonadReader env m- , HasDogStatsClient env- , HasDogStatsTags env- )- => Text- -> [(Text, Text)]- -> Double- -> m ()-gauge name tags = sendAppMetricWithTags name tags Gauge--{-# DEPRECATED guage "Use gauge instead" #-}--- | Deprecated typo version of 'gauge'-guage- :: ( MonadUnliftIO m- , MonadReader env m- , HasDogStatsClient env- , HasDogStatsTags env- )- => Text- -> [(Text, Text)]- -> Double- -> m ()-guage = gauge--histogram- :: ( MonadUnliftIO m- , MonadReader env m- , HasDogStatsClient env- , HasDogStatsTags env- , ToMetricValue n- )- => Text- -> [(Text, Text)]- -> n- -> m ()-histogram name tags metricValue =- sendAppMetricWithTags name tags Histogram metricValue--histogramSince- :: ( MonadUnliftIO m- , MonadReader env m- , HasDogStatsClient env- , HasDogStatsTags env- )- => Text- -> [(Text, Text)]- -> UTCTime- -> m ()-histogramSince = histogramSinceBy toSeconds- where- -- N.B. NominalDiffTime is treated as seconds when using round. Replace round- -- with nominalDiffTimeToSeconds once we upgrade our version of the time- -- library.- toSeconds = round @_ @Int--histogramSinceMs- :: ( MonadUnliftIO m- , MonadReader env m- , HasDogStatsClient env- , HasDogStatsTags env- )- => Text- -> [(Text, Text)]- -> UTCTime- -> m ()-histogramSinceMs = histogramSinceBy toMilliseconds- where toMilliseconds = (* 1000) . realToFrac @_ @Double--histogramSinceBy- :: ( MonadUnliftIO m- , MonadReader env m- , HasDogStatsClient env- , HasDogStatsTags env- , ToMetricValue n- )- => (NominalDiffTime -> n)- -> Text- -> [(Text, Text)]- -> UTCTime- -> m ()-histogramSinceBy f name tags time = do- now <- liftIO getCurrentTime- let delta = f $ now `diffUTCTime` time- sendAppMetricWithTags name tags Histogram delta--sendAppMetricWithTags- :: ( MonadUnliftIO m- , MonadReader env m- , HasDogStatsClient env- , HasDogStatsTags env- , ToMetricValue v- )- => Text- -> [(Text, Text)]- -> MetricType- -> v- -> m ()-sendAppMetricWithTags name tags metricType metricValue = do- mClient <- asks getDogStatsClient-- for_ mClient $ \client -> do- appTags <- asks getDogStatsTags-- let- ddTags = appTags <> map (uncurry tag) tags- ddMetric = set Datadog.tags ddTags- $ Datadog.metric (MetricName name) metricType metricValue-- send client ddMetric--envParseDogStatsEnabled :: Env.Parser Env.Error Bool-envParseDogStatsEnabled = Env.switch "DOGSTATSD_ENABLED" mempty--envParseDogStatsSettings :: Env.Parser Env.Error DogStatsSettings-envParseDogStatsSettings = do- dogStatsSettingsHost <- Env.var Env.str "DOGSTATSD_HOST" $ Env.def "127.0.0.1"- dogStatsSettingsPort <- Env.var Env.auto "DOGSTATSD_PORT" $ Env.def 8125- dogStatsSettingsMaxDelay <-- Env.var Env.auto "DOGSTATSD_MAX_DELAY_MICROSECONDS" $ Env.def 1000000- pure defaultSettings- { dogStatsSettingsHost- , dogStatsSettingsPort- , dogStatsSettingsMaxDelay- }--envParseDogStatsTags :: Env.Parser Env.Error [Tag]-envParseDogStatsTags =- map (uncurry tag) <$> Env.var Env.keyValues "DOGSTATSD_TAGS" (Env.def [])
− library/Freckle/App/Datadog/Gauge.hs
@@ -1,86 +0,0 @@--- | Stateful gauges for Datadog-module Freckle.App.Datadog.Gauge- ( Gauge- , new- , increment- , decrement- , add- , subtract- ) where--import Freckle.App.Prelude hiding (subtract)--import Freckle.App.Datadog (HasDogStatsClient, HasDogStatsTags, gauge)-import qualified System.Metrics.Gauge as EKG---- | A data type containing all reporting values for a gauge-data Gauge = Gauge- { name :: Text- , tags :: [(Text, Text)]- , ekgGauge :: EKG.Gauge- }---- | Create a gauge holding in memory state-new :: MonadIO m => Text -> [(Text, Text)] -> m Gauge-new name tags = Gauge name tags <$> liftIO EKG.new---- | Increment gauge state and report its current value-increment- :: ( MonadUnliftIO m- , MonadReader env m- , HasDogStatsClient env- , HasDogStatsTags env- )- => Gauge- -> m ()-increment = add 1---- | Add to gauge state and report its current value-add- :: ( MonadUnliftIO m- , MonadReader env m- , HasDogStatsClient env- , HasDogStatsTags env- )- => Int64- -> Gauge- -> m ()-add i = withEKGGauge (`EKG.add` i)---- | Decrement gauge state and report its current value-decrement- :: ( MonadUnliftIO m- , MonadReader env m- , HasDogStatsClient env- , HasDogStatsTags env- )- => Gauge- -> m ()-decrement = subtract 1---- | Subtract from gauge state and report its current value-subtract- :: ( MonadUnliftIO m- , MonadReader env m- , HasDogStatsClient env- , HasDogStatsTags env- )- => Int64- -> Gauge- -> m ()-subtract i = withEKGGauge (`EKG.subtract` i)--withEKGGauge- :: ( MonadUnliftIO m- , MonadReader env m- , HasDogStatsClient env- , HasDogStatsTags env- )- => (EKG.Gauge -> IO ())- -> Gauge- -> m ()-withEKGGauge f Gauge {..} = do- current <- liftIO $ do- f ekgGauge- EKG.read ekgGauge- gauge name tags $ fromIntegral current
− library/Freckle/App/Datadog/Rts.hs
@@ -1,57 +0,0 @@--- | RTS statistics sent to Datadog-module Freckle.App.Datadog.Rts- ( forkRtsStatPolling- ) where--import Freckle.App.Prelude--import qualified Control.Immortal as Immortal-import qualified Data.HashMap.Strict as HashMap-import Freckle.App.Datadog (HasDogStatsClient, HasDogStatsTags)-import qualified Freckle.App.Datadog as Datadog-import qualified System.Metrics as Ekg-import qualified System.Metrics.Distribution.Internal 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- , HasDogStatsClient env- , HasDogStatsTags 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- , HasDogStatsClient env- , HasDogStatsTags env- )- => Text- -> Ekg.Value- -> m ()-flushEkgSample name = \case- Ekg.Counter n -> Datadog.counter name [] $ fromIntegral n- Ekg.Gauge n -> Datadog.gauge name [] $ fromIntegral n- Ekg.Distribution d -> do- Datadog.gauge (name <> "." <> "mean") [] $ Ekg.mean d- Datadog.gauge (name <> "." <> "variance") [] $ Ekg.variance d- Datadog.gauge (name <> "." <> "sum") [] $ Ekg.sum d- Datadog.gauge (name <> "." <> "min") [] $ Ekg.min d- Datadog.gauge (name <> "." <> "max") [] $ Ekg.max d- Datadog.counter (name <> "." <> "count") [] $ fromIntegral $ Ekg.count d- Ekg.Label _ -> pure ()
+ library/Freckle/App/Ecs.hs view
@@ -0,0 +1,57 @@+module Freckle.App.Ecs+ ( EcsMetadata(..)+ , EcsContainerMetadata(..)+ , EcsContainerTaskMetadata(..)+ , getEcsMetadata+ ) where++import Freckle.App.Prelude++import Control.Error.Util (hush)+import Data.Aeson+import Data.List.Extra (dropPrefix)+import Freckle.App.Http+import System.Environment (lookupEnv)++data EcsMetadata = EcsMetadata+ { emContainerMetadata :: EcsContainerMetadata+ , emContainerTaskMetadata :: EcsContainerTaskMetadata+ }++data EcsContainerMetadata = EcsContainerMetadata+ { ecmDockerId :: Text+ , ecmDockerName :: Text+ , ecmImage :: Text+ , ecmImageID :: Text+ }+ deriving stock Generic++instance FromJSON EcsContainerMetadata where+ parseJSON = genericParseJSON $ aesonDropPrefix "ecm"++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 => m (Maybe EcsMetadata)+getEcsMetadata =+ liftA2 EcsMetadata+ <$> makeContainerMetadataRequest "/"+ <*> makeContainerMetadataRequest "/task"++makeContainerMetadataRequest :: (MonadIO m, FromJSON a) => Text -> m (Maybe a)+makeContainerMetadataRequest path = do+ mURI <- liftIO $ lookupEnv "ECS_CONTAINER_METADATA_URI"+ meMetadata <- for mURI $ \uri -> do+ httpJson $ parseRequest_ $ uri <> unpack path+ pure $ hush . getResponseBody =<< meMetadata
library/Freckle/App/Memcached/Client.hs view
@@ -1,6 +1,7 @@ module Freckle.App.Memcached.Client ( MemcachedClient , newMemcachedClient+ , withMemcachedClient , memcachedClientDisabled , HasMemcachedClient(..) , get@@ -15,6 +16,7 @@ import Freckle.App.Memcached.CacheKey import Freckle.App.Memcached.CacheTTL import Freckle.App.Memcached.Servers+import UnliftIO.Exception (finally) import Yesod.Core.Lens import Yesod.Core.Types (HandlerData) @@ -36,6 +38,12 @@ [] -> pure memcachedClientDisabled specs -> liftIO $ MemcachedClient <$> Memcache.newClient specs Memcache.def +withMemcachedClient+ :: MonadUnliftIO m => MemcachedServers -> (MemcachedClient -> m a) -> m a+withMemcachedClient servers f = do+ c <- newMemcachedClient servers+ f c `finally` quitClient c+ memcachedClientDisabled :: MemcachedClient memcachedClientDisabled = MemcachedClientDisabled @@ -61,6 +69,11 @@ MemcachedClient mc -> void $ liftIO $ Memcache.set mc (fromCacheKey k) v 0 $ fromCacheTTL expiration+ MemcachedClientDisabled -> pure ()++quitClient :: MonadIO m => MemcachedClient -> m ()+quitClient = \case+ MemcachedClient mc -> void $ liftIO $ Memcache.quit mc MemcachedClientDisabled -> pure () with
library/Freckle/App/Scientist.hs view
@@ -4,33 +4,30 @@ import Freckle.App.Prelude -import Data.List.NonEmpty as NE-import qualified Freckle.App.Datadog as Datadog+import Freckle.App.Stats (HasStatsClient)+import qualified Freckle.App.Stats as Stats import Scientist import Scientist.Duration --- | Publish experiment durations to Datadog+-- | Publish experiment durations using "Freckle.App.Stats" -- -- * Experiments are labeled "science.${name}"--- * Control results are tagged with "variant:control"--- * Candidates are tagged with "variant:control-${i}"+-- * Results are tagged with "variant:${name}" -- experimentPublishDatadog- :: ( MonadReader env m- , MonadUnliftIO m- , Datadog.HasDogStatsClient env- , Datadog.HasDogStatsTags env- )+ :: (MonadReader env m, MonadUnliftIO m, HasStatsClient env) => Result c a b -> m () experimentPublishDatadog result = for_ (resultDetails result) $ \details -> do- let statName = "science." <> resultDetailsExperimentName details- Datadog.gauge statName [("variant", "control")]- $ durationToSeconds- $ resultControlDuration- $ resultDetailsControl details- for_ (NE.zip (resultDetailsCandidates details) (NE.fromList [1 ..]))- $ \(candidate, i :: Int) -> do- Datadog.gauge statName [("variant", "candidate-" <> tshow i)]- $ durationToSeconds- $ resultCandidateDuration candidate+ let+ statName = "science." <> resultDetailsExperimentName details+ ResultControl {..} = resultDetailsControl details++ Stats.tagged [("variant", resultControlName)]+ $ Stats.gauge statName+ $ durationToSeconds resultControlDuration++ for_ (resultDetailsCandidates details) $ \ResultCandidate {..} ->+ Stats.tagged [("variant", "candidate-" <> resultCandidateName)]+ $ Stats.gauge statName+ $ durationToSeconds resultCandidateDuration
+ library/Freckle/App/Stats.hs view
@@ -0,0 +1,280 @@+{-# LANGUAGE TupleSections #-}++-- | An intentionally-leaky StatsD interface to Datadog+--+-- $usage+--+module Freckle.App.Stats+ ( StatsSettings+ , envParseStatsSettings++ -- * Client+ , StatsClient+ , withStatsClient+ , HasStatsClient(..)++ -- * Reporting+ , tagged+ , increment+ , counter+ , gauge+ , histogram+ , histogramSince+ , histogramSinceMs+ ) where++import Freckle.App.Prelude++import Blammo.Logging+import Control.Lens (Lens', lens, view, (&), (.~), (<>~))+import Control.Monad.Reader (local)+import Data.Aeson (Value(..))+import Data.String+import Data.Time (diffUTCTime)+import Freckle.App.Ecs+import qualified Freckle.App.Env as Env+import qualified Network.StatsD.Datadog as Datadog+import Yesod.Core.Lens+import Yesod.Core.Types (HandlerData)++data StatsSettings = StatsSettings+ { amsEnabled :: Bool+ , amsSettings :: Datadog.DogStatsSettings+ , amsTags :: [(Text, Text)]+ }++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 StatsClient = StatsClient+ { scClient :: Datadog.StatsClient+ , scTags :: [(Text, Text)]+ }++tagsL :: Lens' StatsClient [(Text, Text)]+tagsL = lens scTags $ \x y -> x { scTags = 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+ 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 }+ else f $ StatsClient { scClient = Datadog.Dummy, scTags = [] }+ where toPair = bimap (fromString . unpack) String++-- | 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 = maybe [] toTags <$> getEcsMetadata+ where+ 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)+ ]++-- $usage+-- 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\"+-- -- ...+-- @+--
+ library/Freckle/App/Stats/Gauge.hs view
@@ -0,0 +1,63 @@+-- | Stateful gauges for "Freckle.App.Stats"+module Freckle.App.Stats.Gauge+ ( Gauge+ , new+ , increment+ , decrement+ , add+ , subtract+ ) where++import Freckle.App.Prelude hiding (subtract)++import Freckle.App.Stats (HasStatsClient)+import qualified Freckle.App.Stats as Stats+import qualified System.Metrics.Gauge as EKG++-- | A data type containing all reporting values for a gauge+data Gauge = Gauge+ { name :: Text+ , tags :: [(Text, Text)]+ , ekgGauge :: EKG.Gauge+ }++-- | Create a gauge holding in memory state+new :: MonadIO m => Text -> [(Text, Text)] -> m Gauge+new name tags = Gauge name tags <$> liftIO EKG.new++-- | Increment gauge state and report its current value+increment+ :: (MonadUnliftIO m, MonadReader env m, HasStatsClient env) => Gauge -> m ()+increment = add 1++-- | Add to gauge state and report its current value+add+ :: (MonadUnliftIO m, MonadReader env m, HasStatsClient env)+ => Int64+ -> Gauge+ -> m ()+add i = withEKGGauge (`EKG.add` i)++-- | Decrement gauge state and report its current value+decrement+ :: (MonadUnliftIO m, MonadReader env m, HasStatsClient env) => Gauge -> m ()+decrement = subtract 1++-- | Subtract from gauge state and report its current value+subtract+ :: (MonadUnliftIO m, MonadReader env m, HasStatsClient env)+ => Int64+ -> Gauge+ -> m ()+subtract i = withEKGGauge (`EKG.subtract` i)++withEKGGauge+ :: (MonadUnliftIO m, MonadReader env m, HasStatsClient env)+ => (EKG.Gauge -> IO ())+ -> Gauge+ -> m ()+withEKGGauge f Gauge {..} = do+ current <- liftIO $ do+ f ekgGauge+ EKG.read ekgGauge+ Stats.tagged tags $ Stats.gauge name $ fromIntegral current
+ library/Freckle/App/Stats/Rts.hs view
@@ -0,0 +1,48 @@+-- | Send RTS statistics via "Freckle.App.Stats"+module Freckle.App.Stats.Rts+ ( forkRtsStatPolling+ ) where++import Freckle.App.Prelude++import qualified Control.Immortal as Immortal+import qualified Data.HashMap.Strict as HashMap+import Freckle.App.Stats (HasStatsClient)+import qualified Freckle.App.Stats as Stats+import qualified System.Metrics as Ekg+import qualified System.Metrics.Distribution.Internal 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 ()
library/Freckle/App/Test.hs view
@@ -124,8 +124,8 @@ -- this spec can use 'runAppTest' if the app 'HasLogger' (and 'runDB', if the -- app 'HasSqlPool'). ---withApp :: IO app -> SpecWith app -> Spec-withApp load = beforeAll (loadEnvTest *> load)+withApp :: ((app -> IO ()) -> IO ()) -> SpecWith app -> Spec+withApp run = beforeAll loadEnvTest . Hspec.aroundAll run -- | 'withApp', with custom DB 'Pool' initialization --@@ -133,8 +133,13 @@ -- truncate tables. -- withAppSql- :: HasSqlPool app => SqlPersistT IO a -> IO app -> SpecWith app -> Spec-withAppSql f load = beforeAll (loadEnvTest *> load) . beforeWith setup+ :: HasSqlPool app+ => SqlPersistT IO a+ -> ((app -> IO ()) -> IO ())+ -> SpecWith app+ -> Spec+withAppSql f run =+ beforeAll loadEnvTest . Hspec.aroundAll run . beforeWith setup where setup app = app <$ runSqlPool f (getSqlPool app) loadEnvTest :: IO ()
+ library/Freckle/App/Test/Properties/JSON.hs view
@@ -0,0 +1,11 @@+module Freckle.App.Test.Properties.JSON+ ( prop_roundTripJSON+ ) where++import Freckle.App.Prelude++import Data.Aeson++-- | Check that @fromJSON (toJSON value)@ is @value@+prop_roundTripJSON :: (FromJSON a, ToJSON a, Eq a) => a -> Bool+prop_roundTripJSON a = fromJSON (toJSON a) == Success a
+ library/Freckle/App/Test/Properties/PathPiece.hs view
@@ -0,0 +1,11 @@+module Freckle.App.Test.Properties.PathPiece+ ( prop_roundTripPathPiece+ ) where++import Freckle.App.Prelude++import Web.PathPieces++-- | Check that @fromPathPiece (toPathPiece value)@ is @value@+prop_roundTripPathPiece :: (PathPiece a, Eq a) => a -> Bool+prop_roundTripPathPiece a = fromPathPiece (toPathPiece a) == Just a
library/Freckle/App/Wai.hs view
@@ -1,45 +1,20 @@ -- | Integration of "Freckle.App" tooling with "Network.Wai" module Freckle.App.Wai- ( makeRequestMetricsMiddleware- , noCacheMiddleware+ ( noCacheMiddleware , corsMiddleware , denyFrameEmbeddingMiddleware ) where -import Freckle.App.Prelude hiding (decodeUtf8)+import Freckle.App.Prelude -import Control.Monad.Reader (runReaderT) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.CaseInsensitive as CI-import Data.Text.Encoding (decodeUtf8With)-import Data.Text.Encoding.Error (lenientDecode)-import Freckle.App.Datadog (HasDogStatsClient, HasDogStatsTags)-import qualified Freckle.App.Datadog as Datadog import Network.HTTP.Types (ResponseHeaders)-import Network.HTTP.Types.Status (status200, statusCode)+import Network.HTTP.Types.Status (status200) import Network.Wai import Network.Wai.Middleware.AddHeaders (addHeaders) -makeRequestMetricsMiddleware- :: (HasDogStatsClient env, HasDogStatsTags env)- => env- -> (Request -> [(Text, Text)])- -> Middleware-makeRequestMetricsMiddleware env getTags app req sendResponse' = do- start <- getCurrentTime- app req $ \res -> do- flip runReaderT env $ do- Datadog.increment "requests" $ tags res- Datadog.histogramSinceMs "response_time_ms" (tags res) start- sendResponse' res- where- tags res =- getTags req- <> [ ("method", decodeUtf8 $ requestMethod req)- , ("status", pack $ show $ statusCode $ responseStatus res)- ]- noCacheMiddleware :: Middleware noCacheMiddleware = addHeaders [cacheControlHeader] where@@ -100,6 +75,3 @@ exposedHeaders = ["Set-Cookie", "Content-Disposition", "Link"] <> extraExposedHeaders--decodeUtf8 :: ByteString -> Text-decodeUtf8 = decodeUtf8With lenientDecode
library/Freckle/App/Yesod.hs view
@@ -8,8 +8,8 @@ import Blammo.Logging import Database.PostgreSQL.Simple (SqlError(..))-import Freckle.App.Datadog (HasDogStatsClient, HasDogStatsTags)-import qualified Freckle.App.Datadog as Datadog+import Freckle.App.Stats (HasStatsClient)+import qualified Freckle.App.Stats as Stats import Network.HTTP.Types (ResponseHeaders, status503) import qualified Network.Wai as W import UnliftIO.Exception (displayException, handleJust)@@ -20,20 +20,18 @@ -- Also logs and increments a metric. -- respondQueryCanceled- :: (HasDogStatsClient site, HasDogStatsTags site)- => HandlerFor site res- -> HandlerFor site res+ :: HasStatsClient site => HandlerFor site res -> HandlerFor site res respondQueryCanceled = respondQueryCanceledHeaders [] -- | 'respondQueryCanceledHeaders' but adding headers to the 503 response respondQueryCanceledHeaders- :: (HasDogStatsClient site, HasDogStatsTags site)+ :: HasStatsClient site => ResponseHeaders -> HandlerFor site res -> HandlerFor site res respondQueryCanceledHeaders headers = handleJust queryCanceled $ \ex -> do logError $ "Query canceled" :# ["exception" .= displayException ex]- Datadog.increment "query_canceled" []+ Stats.increment "query_canceled" sendWaiResponse $ W.responseLBS status503 headers "Query canceled" queryCanceled :: SqlError -> Maybe SqlError
+ library/Network/Wai/Middleware/Stats.hs view
@@ -0,0 +1,29 @@+module Network.Wai.Middleware.Stats+ ( requestStats+ ) where++import Freckle.App.Prelude++import Control.Monad.Reader (runReaderT)+import Freckle.App.Stats (HasStatsClient)+import qualified Freckle.App.Stats as Stats+import Network.HTTP.Types.Status (Status(..))+import Network.Wai (Middleware, Request, requestMethod, responseStatus)++requestStats+ :: HasStatsClient env => env -> (Request -> [(Text, Text)]) -> Middleware+requestStats env getTags app req respond = do+ start <- getCurrentTime+ app req $ \res -> do+ let+ tags =+ getTags req+ <> [ ("method", decodeUtf8 $ requestMethod req)+ , ("status", pack $ show $ statusCode $ responseStatus res)+ ]++ flip runReaderT env $ Stats.tagged tags $ do+ Stats.increment "requests"+ Stats.histogramSinceMs "response_time_ms" start++ respond res
package.yaml view
@@ -1,6 +1,6 @@ --- name: freckle-app-version: 1.4.0.0+version: 1.5.0.0 maintainer: Freckle Education category: Utils github: freckle/freckle-app@@ -67,6 +67,7 @@ - envparse - errors - exceptions+ - extra - filepath - hashable - hspec >= 2.8.1@@ -84,6 +85,7 @@ - monad-control - mtl - network-uri+ - path-pieces - persistent - persistent-postgresql - postgresql-simple@@ -115,6 +117,7 @@ ghc-options: -threaded -rtsopts "-with-rtsopts=-N" dependencies: - Blammo+ - QuickCheck - aeson - bytestring - errors
tests/Freckle/App/MemcachedSpec.hs view
@@ -14,7 +14,7 @@ import qualified Data.List.NonEmpty as NE import qualified Freckle.App.Env as Env import Freckle.App.Memcached-import Freckle.App.Memcached.Client (MemcachedClient, newMemcachedClient)+import Freckle.App.Memcached.Client (MemcachedClient, withMemcachedClient) import qualified Freckle.App.Memcached.Client as Memcached import Freckle.App.Memcached.Servers @@ -48,14 +48,15 @@ instance HasLogger App where loggerL = lens appLogger $ \x y -> x { appLogger = y } -loadApp :: IO App-loadApp = do+loadApp :: (App -> IO a) -> IO a+loadApp f = do servers <- Env.parse id $ Env.var (Env.eitherReader readMemcachedServers) "MEMCACHED_SERVERS" (Env.def defaultMemcachedServers)-- App <$> newMemcachedClient servers <*> newTestLogger defaultLogSettings+ appLogger <- newTestLogger defaultLogSettings+ withMemcachedClient servers $ \appMemcachedClient -> do+ f App { .. } spec :: Spec spec = withApp loadApp $ do
+ tests/Freckle/App/Test/Properties/JSONSpec.hs view
@@ -0,0 +1,28 @@+module Freckle.App.Test.Properties.JSONSpec+ ( spec+ ) where++import Freckle.App.Prelude++import Data.Aeson+import Freckle.App.Test.Properties.JSON+import Test.Hspec+import Test.QuickCheck++data MyCustomType+ = A+ | B (Maybe String)+ deriving stock (Show, Eq, Generic)+ deriving anyclass (ToJSON, FromJSON)++instance Arbitrary MyCustomType where+ arbitrary = oneof [pure A, B <$> arbitrary]++spec :: Spec+spec = do+ describe "prop_roundTripJSON" $ do+ it "round trips for Integer" $ property $ prop_roundTripJSON @Integer+ it "round trips for Bool" $ property $ prop_roundTripJSON @Bool+ it "round trips for some custom type"+ $ property+ $ prop_roundTripJSON @MyCustomType
+ tests/Freckle/App/Test/Properties/PathPieceSpec.hs view
@@ -0,0 +1,18 @@+module Freckle.App.Test.Properties.PathPieceSpec+ ( spec+ ) where++import Freckle.App.Prelude++import Freckle.App.Test.Properties.PathPiece+import Test.Hspec+import Test.QuickCheck++spec :: Spec+spec = do+ describe "pathPieceInstancesRoundTrip" $ do+ it "round trips for Integer" $ property $ prop_roundTripPathPiece @Integer+ it "round trips for Bool" $ property $ prop_roundTripPathPiece @Bool+ it "round trips for Maybe String"+ $ property+ $ prop_roundTripPathPiece @(Maybe String)