packages feed

freckle-app 1.9.5.1 → 1.10.0.0

raw patch · 12 files changed

+296/−64 lines, 12 filesdep +hs-opentelemetry-apidep +hs-opentelemetry-instrumentation-persistentdep +hs-opentelemetry-instrumentation-waidep ~hw-kafka-clientdep ~resource-pool

Dependencies added: hs-opentelemetry-api, hs-opentelemetry-instrumentation-persistent, hs-opentelemetry-instrumentation-wai, hs-opentelemetry-propagator-datadog, hs-opentelemetry-sdk

Dependency ranges changed: hw-kafka-client, resource-pool

Files

CHANGELOG.md view
@@ -1,4 +1,17 @@-## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.9.5.1...main)+## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.10.0.0...main)++## [v1.10.0.0](https://github.com/freckle/freckle-app/compare/v1.9.5.1...v1.10.0.0)++- Full support for OpenTelemetry tracing, use it instead of XRay in `runDB`++  This replaces our bespoke, XRay-based `MonadTracer` class to be that of+  `hs-opentelemetry.` This means `Freckle.App.Database.runDB` now traces using+  OpenTelemetry instead of XRay. A compilation error will indicate a missing+  `HasTracer` instance, which you should implement based on the+  `Freckle.App.OpenTelemetry` module documentation.++  Clients who wish to remain on XRay can still upgrade, but must adjust their+  imports so they use `Freckle.App.Database.XRay`, not `Freckle.App.Database`.  ## [v1.9.5.1](https://github.com/freckle/freckle-app/compare/v1.9.5.0...v1.9.5.1)
freckle-app.cabal view
@@ -1,6 +1,6 @@ cabal-version:      1.18 name:               freckle-app-version:            1.9.5.1+version:            1.10.0.0 license:            MIT license-file:       LICENSE maintainer:         Freckle Education@@ -29,6 +29,7 @@         Freckle.App.Bugsnag.MetaData         Freckle.App.Csv         Freckle.App.Database+        Freckle.App.Database.XRay         Freckle.App.Dotenv         Freckle.App.Ecs         Freckle.App.Env@@ -61,6 +62,7 @@         Freckle.App.Yesod.Routes         Network.HTTP.Link.Compat         Network.Wai.Middleware.Cors+        Network.Wai.Middleware.OpenTelemetry         Network.Wai.Middleware.Stats         Yesod.Core.Lens @@ -109,6 +111,11 @@         extra,         filepath,         hashable,+        hs-opentelemetry-api,+        hs-opentelemetry-instrumentation-persistent,+        hs-opentelemetry-instrumentation-wai,+        hs-opentelemetry-propagator-datadog,+        hs-opentelemetry-sdk,         hspec >=2.8.1,         hspec-core >=2.8.1,         hspec-expectations-lifted,@@ -117,7 +124,7 @@         http-conduit >=2.3.5,         http-link-header,         http-types,-        hw-kafka-client,+        hw-kafka-client >=4.0.3 && <5.0.0,         immortal,         lens,         memcache,@@ -131,7 +138,7 @@         persistent-postgresql,         postgresql-simple,         primitive,-        resource-pool,+        resource-pool >=0.4.0.0,         resourcet,         retry >=0.8.1.0,         safe,
library/Freckle/App.hs view
@@ -67,9 +67,15 @@ -- -- == Database --+-- @+-- import "Freckle.App.Database"+-- import "Freckle.App.OpenTelemetry"+-- @+-- -- Adding Database access requires a few more instances on your @App@ type: -- -- - @'HasSqlPool'@: so we can, you know, talk to a DB+-- - @'HasTracer'@: to satisfy @'MonadTracer'@ so we can trace @'runDB'@ -- - @'HasStatsClient'@: so we can manage connection count metrics -- -- Most often, this will be easiest if you indeed separate a @Config@ attribute:@@ -94,6 +100,7 @@ -- >   { appConfig :: Config -- >   , appLogger :: Logger -- >   , appSqlPool :: SqlPool+-- >   , appTracer :: Tracer -- >   , appStatsClient :: StatsClient -- >   } -- >@@ -103,6 +110,9 @@ -- > instance HasSqlPool App where -- >   getSqlPool = appSqlPool -- >+-- > instance HasTracer App where+-- >   tracerL = lens appTracer $ \x y -> x { appTracer = y }+-- > -- > instance HasStatsClient App where -- >   statsClientL = lens appStatsClient $ \x y -> x { appStatsClient = y } --@@ -114,13 +124,16 @@ -- >   appConfig{..} <- loadConfig -- >   appLogger <- newLogger configLoggerSettings -- >   appSqlPool <- runLoggerLoggingT appLogger $ makePostgresPool configDbPoolSize--- >   withStatsClient configStatsSettings $ \appStatsClient -> do--- >     f App{..}+-- >   withTracerProvider $ \tracerProvider -> do+-- >     withStatsClient configStatsSettings $ \appStatsClient -> do+-- >       let appTracer = makeTracer tracerProvider "my-app" tracerOptions+-- >       f App{..} -- -- This unlocks @'runDB'@ for your application: -- -- > myAppAction -- >   :: ( MonadUnliftIO m+-- >      , MonadTracer m -- >      , MonadReader env m -- >      , HasSqlPool env -- >      , HasStatsClient env@@ -162,8 +175,6 @@   , runAppT      -- * Re-exports-  , module Freckle.App.Database-  , module Freckle.App.OpenTelemetry   , module Blammo.Logging   , module Control.Monad.Reader   ) where@@ -171,12 +182,14 @@ import Freckle.App.Prelude  import Blammo.Logging+import Control.Lens (view) import Control.Monad.Catch (MonadCatch, MonadThrow) import Control.Monad.IO.Unlift (MonadUnliftIO (..)) import Control.Monad.Primitive (PrimMonad (..)) import Control.Monad.Reader import Control.Monad.Trans.Resource (MonadResource, ResourceT, runResourceT) import Freckle.App.Database+import qualified Freckle.App.Database.XRay as XRay import Freckle.App.OpenTelemetry import System.IO (BufferMode (..), hSetBuffering, stderr, stdout) @@ -232,7 +245,10 @@   primitive = AppT . lift . lift . lift . primitive   {-# INLINE primitive #-} -instance Applicative m => MonadTracer (AppT app m) where+instance (Monad m, HasTracer app) => MonadTracer (AppT app m) where+  getTracer = view tracerL++instance Applicative m => XRay.MonadTracer (AppT app m) where   getVaultData = pure Nothing  runAppT :: (MonadUnliftIO m, HasLogger app) => AppT app m a -> app -> m a
library/Freckle/App/Database.hs view
@@ -4,7 +4,9 @@  -- | Database access for your @App@ module Freckle.App.Database-  ( HasSqlPool (..)+  ( MonadTracer+  , HasStatsClient+  , HasSqlPool (..)   , SqlPool   , makePostgresPool   , makePostgresPoolWith@@ -23,7 +25,6 @@  import Blammo.Logging import qualified Control.Immortal as Immortal-import Control.Monad.IO.Unlift (MonadUnliftIO (..)) import Control.Monad.Reader import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS8@@ -36,9 +37,10 @@   , createPostgresqlPoolModified   , createSqlPool   , openSimpleConn-  , runSqlConn   , runSqlPool+  , runSqlPoolWithExtensibleHooks   )+import Database.Persist.SqlBackend.SqlPoolHooks import Database.PostgreSQL.Simple   ( Connection   , Only (..)@@ -48,11 +50,10 @@ import Database.PostgreSQL.Simple.SqlQQ (sql) import Freckle.App.Env (Timeout (..)) import qualified Freckle.App.Env as Env-import Freckle.App.OpenTelemetry (MonadTracer (..))+import Freckle.App.OpenTelemetry import Freckle.App.Stats (HasStatsClient) import qualified Freckle.App.Stats as Stats-import Network.AWS.XRayClient.Persistent-import Network.AWS.XRayClient.WAI+import OpenTelemetry.Instrumentation.Persistent import System.Process.Typed (proc, readProcessStdout_) import UnliftIO.Concurrent (threadDelay) import UnliftIO.Exception (displayException)@@ -78,20 +79,28 @@   makePostgresPoolWith conf  -- | Run a Database action with connection stats and tracing+--+-- This uses OpenTelemetry and 'MonadTracer'. For callstacks in traces to be+-- useful, ensure you have 'HasCallStack' on functions that call this (and+-- functions that call those, for as far as you require to get to a useful+-- source location). runDB   :: ( MonadUnliftIO m      , MonadTracer m      , MonadReader app m      , HasSqlPool app      , HasStatsClient app+     , HasCallStack      )   => SqlPersistT m a   -> m a runDB action = do   pool <- asks getSqlPool-  mVaultData <- getVaultData   Stats.withGauge Stats.dbConnections $-    maybe runSqlPool (runSqlPoolXRay "runDB") mVaultData action pool+    inSpan "runDB" defaultSpanArguments $+      runSqlPoolWithExtensibleHooks action pool Nothing $+        setAlterBackend defaultSqlPoolHooks $+          wrapSqlBackend mempty  runDBSimple   :: (HasSqlPool app, MonadUnliftIO m, MonadReader app m)@@ -100,31 +109,6 @@ runDBSimple action = do   pool <- asks getSqlPool   runSqlPool action pool---- | @'runSqlPool'@ but with XRay tracing-runSqlPoolXRay-  :: (backend ~ SqlBackend, MonadUnliftIO m)-  => Text-  -- ^ Subsegment name-  ---  -- The top-level subsegment will be named @\"<this> runSqlPool\"@ and the,-  -- with a lower-level subsegment named @\"<this> query\"@.-  -> XRayVaultData-  -- ^ Vault data to trace with-  -> ReaderT backend m a-  -> Pool backend-  -> m a-runSqlPoolXRay name vaultData action pool =-  traceXRaySubsegment' vaultData (name <> " runSqlPool") id $-    withRunInIO $-      \run -> withResource pool $ \backend -> do-        let-          sendTrace = atomicallyAddVaultDataSubsegment vaultData-          stdGenIORef = xrayVaultDataStdGen vaultData-          subsegmentName = name <> " query"-        run . runSqlConn action-          =<< liftIO-            (xraySqlBackend sendTrace stdGenIORef subsegmentName backend)  data PostgresConnectionConf = PostgresConnectionConf   { pccHost :: String
+ library/Freckle/App/Database/XRay.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE TypeOperators #-}++-- | Legacy version of "Freckle.App.Database" that still uses XRay+module Freckle.App.Database.XRay+  ( MonadTracer (..)+  , HasStatsClient+  , HasSqlPool (..)+  , SqlPool+  , makePostgresPool+  , makePostgresPoolWith+  , runDB+  , runDBSimple+  , PostgresConnectionConf (..)+  , PostgresPasswordSource (..)+  , PostgresPassword (..)+  , PostgresStatementTimeout+  , postgresStatementTimeoutMilliseconds+  , envParseDatabaseConf+  , envPostgresPasswordSource+  ) where++import Freckle.App.Prelude++import Control.Monad.IO.Unlift (MonadUnliftIO (..))+import Control.Monad.Reader+import Data.Pool+import Database.Persist.Postgresql+  ( SqlBackend+  , SqlPersistT+  , runSqlConn+  , runSqlPool+  )+import Freckle.App.Database hiding (MonadTracer, runDB)+import qualified Freckle.App.Stats as Stats+import Network.AWS.XRayClient.Persistent+import Network.AWS.XRayClient.WAI+  ( XRayVaultData+  , atomicallyAddVaultDataSubsegment+  , traceXRaySubsegment'+  , vaultDataFromRequest+  , xrayVaultDataStdGen+  )+import Yesod.Core (HandlerFor, waiRequest)++-- | Class for reading 'XRayVaultData'+--+-- This is named the same as the OpenTelemetry class we'll use once we move to+-- that tracing system+class MonadTracer m where+  getVaultData :: m (Maybe XRayVaultData)++instance MonadTracer (HandlerFor app) where+  getVaultData = vaultDataFromRequest <$> waiRequest++-- | Run a Database action with connection stats and tracing+runDB+  :: ( MonadUnliftIO m+     , MonadTracer m+     , MonadReader app m+     , HasSqlPool app+     , HasStatsClient app+     )+  => SqlPersistT m a+  -> m a+runDB action = do+  pool <- asks getSqlPool+  mVaultData <- getVaultData+  Stats.withGauge Stats.dbConnections $+    maybe runSqlPool (runSqlPoolXRay "runDB") mVaultData action pool++-- | @'runSqlPool'@ but with XRay tracing+runSqlPoolXRay+  :: (backend ~ SqlBackend, MonadUnliftIO m)+  => Text+  -- ^ Subsegment name+  --+  -- The top-level subsegment will be named @\"<this> runSqlPool\"@ and the,+  -- with a lower-level subsegment named @\"<this> query\"@.+  -> XRayVaultData+  -- ^ Vault data to trace with+  -> ReaderT backend m a+  -> Pool backend+  -> m a+runSqlPoolXRay name vaultData action pool =+  traceXRaySubsegment' vaultData (name <> " runSqlPool") id $+    withRunInIO $+      \run -> withResource pool $ \backend -> do+        let+          sendTrace = atomicallyAddVaultDataSubsegment vaultData+          stdGenIORef = xrayVaultDataStdGen vaultData+          subsegmentName = name <> " query"+        run . runSqlConn action+          =<< liftIO+            (xraySqlBackend sendTrace stdGenIORef subsegmentName backend)
library/Freckle/App/Kafka/Producer.hs view
@@ -89,12 +89,13 @@   -> KafkaProducerPoolConfig   -> IO (Pool KafkaProducer) createKafkaProducerPool addresses KafkaProducerPoolConfig {..} =-  Pool.createPool-    mkProducer-    closeProducer-    kafkaProducerPoolConfigStripes-    kafkaProducerPoolConfigIdleTimeout-    kafkaProducerPoolConfigSize+  Pool.newPool $+    Pool.setNumStripes (Just kafkaProducerPoolConfigStripes) $+      Pool.defaultPoolConfig+        mkProducer+        closeProducer+        (realToFrac kafkaProducerPoolConfigIdleTimeout)+        kafkaProducerPoolConfigSize  where   mkProducer =     either throw pure =<< newProducer (brokersList $ toList addresses)
library/Freckle/App/OpenTelemetry.hs view
@@ -1,18 +1,71 @@+-- | Application tracing via <https://opentelemetry.io/>+--+-- @+-- data App = App+--   { -- ...+--   , appTracer :: Tracer+--   }+--+-- instance HasTracer App where+--   tracerL = lens appTracer $ \x y -> x { appTracer = y }+--+-- loadApp f = do+--   -- ...+--   withTracerProvider $ \tracerProvider -> do+--     let appTracer = makeTracer tracerProvider "my-app" tracerOptions+--     f App {..}+-- @+--+-- You may need to do this even if you don't plan to manually trace things, in order to+-- satisfy the 'MonadTracer' constraint required by functions like 'runDB'. If+-- you don't need this feature, and don't plan on running an otel-collector, set+-- @OTEL_TRACES_EXPORTER=none@ in the environment, which makes all tracing a+-- no-op.+--+-- In the future, it should be possible to use @OTEL_SDK_DISABLED@ for the same+-- purpose. See <https://github.com/iand675/hs-opentelemetry/issues/60>. module Freckle.App.OpenTelemetry-  ( MonadTracer (..)+  ( HasTracer (..)+  , Tracer++    -- * Effects+  , MonadTracer (..)+  , inSpan+  , defaultSpanArguments++    -- * Querying+  , getCurrentTraceId+  , getCurrentSpanContext++    -- * Setup+  , withTracerProvider++    -- ** 'Tracer'+  , makeTracer+  , tracerOptions   ) where  import Freckle.App.Prelude -import Network.AWS.XRayClient.WAI (XRayVaultData, vaultDataFromRequest)-import Yesod.Core (HandlerFor, waiRequest)+import OpenTelemetry.Context (lookupSpan)+import OpenTelemetry.Context.ThreadLocal (getContext)+import OpenTelemetry.Trace hiding (inSpan)+import OpenTelemetry.Trace.Core (getSpanContext)+import qualified OpenTelemetry.Trace.Core as Trace (SpanContext (..))+import OpenTelemetry.Trace.Id (TraceId)+import OpenTelemetry.Trace.Monad+import UnliftIO.Exception (bracket) --- | Class for reading 'XRayVaultData'------ This is named the same as the OpenTelemetry class we'll use once we move to--- that tracing system-class MonadTracer m where-  getVaultData :: m (Maybe XRayVaultData)+withTracerProvider :: MonadUnliftIO m => (TracerProvider -> m a) -> m a+withTracerProvider =+  bracket+    (liftIO initializeGlobalTracerProvider)+    (liftIO . shutdownTracerProvider) -instance MonadTracer (HandlerFor app) where-  getVaultData = vaultDataFromRequest <$> waiRequest+getCurrentTraceId :: MonadIO m => m (Maybe TraceId)+getCurrentTraceId = fmap Trace.traceId <$> getCurrentSpanContext++getCurrentSpanContext :: MonadIO m => m (Maybe SpanContext)+getCurrentSpanContext = do+  mSpan <- lookupSpan <$> getContext+  traverse getSpanContext mSpan
library/Freckle/App/Prelude.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ -- | Those functions and types we can't do without! module Freckle.App.Prelude   ( module Prelude@@ -102,6 +104,9 @@   , read   , tail   , (!!)+#if MIN_VERSION_base(4,18,0)+  , liftA2+#endif   )  -- Commonly used types (and their commonly used functions)
library/Freckle/App/Test.hs view
@@ -20,7 +20,6 @@ import Freckle.App.Prelude as X  import Data.Pool as X-import Freckle.App.Database as X import Test.Hspec as X   ( Expectation   , Spec@@ -36,6 +35,7 @@ import Test.Hspec.Expectations.Lifted as X hiding (expectationFailure)  import Blammo.Logging+import Control.Lens (view) import Control.Monad.Base import Control.Monad.Catch import qualified Control.Monad.Fail as Fail@@ -45,6 +45,8 @@ import Control.Monad.Reader import Control.Monad.Trans.Control import Database.Persist.Sql (SqlPersistT, runSqlPool)+import Freckle.App.Database (HasSqlPool (..))+import qualified Freckle.App.Database.XRay as XRay import qualified Freckle.App.Dotenv as Dotenv import Freckle.App.OpenTelemetry import qualified Test.Hspec as Hspec hiding (expectationFailure)@@ -117,7 +119,10 @@       params       ($ ()) -instance MonadTracer (AppExample app) where+instance HasTracer app => MonadTracer (AppExample app) where+  getTracer = view tracerL++instance XRay.MonadTracer (AppExample app) where   getVaultData = pure Nothing  -- | A type restricted version of id
library/Freckle/App/Wai.hs view
@@ -10,6 +10,9 @@   , requestLogger   , addThreadContextFromRequest +    -- * Tracing+  , newOpenTelemetryWaiMiddleware+     -- * Metrics   , addThreadContextFromStatsTags   , requestStats@@ -19,6 +22,7 @@ import Network.Wai.Middleware.AddHeaders import Network.Wai.Middleware.Cors import Network.Wai.Middleware.Logging+import Network.Wai.Middleware.OpenTelemetry import Network.Wai.Middleware.Stats  -- | Middleware that adds header to disable all caching
+ library/Network/Wai/Middleware/OpenTelemetry.hs view
@@ -0,0 +1,44 @@+module Network.Wai.Middleware.OpenTelemetry+  ( newOpenTelemetryWaiMiddleware+  , openTelemetryMiddleware+  ) where++import Freckle.App.Prelude++import Blammo.Logging (withThreadContext, (.=))+import qualified Data.ByteString.Char8 as BS8+import Freckle.App.OpenTelemetry+import Network.Wai+import Network.Wai.Middleware.AddHeaders+import qualified OpenTelemetry.Instrumentation.Wai as Trace+import OpenTelemetry.Propagator.Datadog+  ( convertOpenTelemetryTraceIdToDatadogTraceId+  )++newOpenTelemetryWaiMiddleware :: IO Middleware+newOpenTelemetryWaiMiddleware = do+  otel <- Trace.newOpenTelemetryWaiMiddleware+  pure $ otel . openTelemetryMiddleware++-- | Add 'TraceId' information to context and responses+--+-- - Adds @trace_id@ to the logging context+-- - Adds @X-Datadog-TraceId@ to response headers+--+-- This is added automatically by our 'newOpenTelemetryWaiMiddleware'.+openTelemetryMiddleware :: Middleware+openTelemetryMiddleware app request respond = do+  mTraceId <- getCurrentTraceId+  case mTraceId of+    Nothing -> app request respond+    Just traceId -> do+      let+        traceIdInt = convertOpenTelemetryTraceIdToDatadogTraceId traceId+        traceIdIntBS = BS8.pack $ show traceIdInt++      withThreadContext ["trace_id" .= traceIdInt] $+        addHeaders+          [("X-Datadog-Trace-Id", traceIdIntBS)]+          app+          request+          respond
package.yaml view
@@ -1,5 +1,5 @@ name: freckle-app-version: 1.9.5.1+version: 1.10.0.0 maintainer: Freckle Education category: Utils github: freckle/freckle-app@@ -94,6 +94,11 @@     - extra     - filepath     - hashable+    - hs-opentelemetry-api+    - hs-opentelemetry-instrumentation-persistent+    - hs-opentelemetry-instrumentation-wai+    - hs-opentelemetry-propagator-datadog+    - hs-opentelemetry-sdk     - hspec >= 2.8.1     - hspec-core >= 2.8.1     - hspec-expectations-lifted@@ -102,7 +107,7 @@     - http-conduit >= 2.3.5 # addToRequestQueryString     - http-link-header     - http-types-    - hw-kafka-client+    - hw-kafka-client < 5.0.0     - immortal     - lens     - memcache@@ -116,8 +121,8 @@     - persistent-postgresql     - postgresql-simple     - primitive+    - resource-pool >= 0.4.0.0 # defaultPoolConfig, etc     - resourcet-    - resource-pool     - retry >= 0.8.1.0 # retryingDynamic     - safe     - scientist