diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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) 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.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, diff --git a/library/Freckle/App.hs b/library/Freckle/App.hs --- a/library/Freckle/App.hs +++ b/library/Freckle/App.hs @@ -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 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 @@ -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 @\" runSqlPool\"@ and the, - -- with a lower-level subsegment named @\" 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 diff --git a/library/Freckle/App/Database/XRay.hs b/library/Freckle/App/Database/XRay.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Database/XRay.hs @@ -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 @\" runSqlPool\"@ and the, + -- with a lower-level subsegment named @\" 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) diff --git a/library/Freckle/App/Kafka/Producer.hs b/library/Freckle/App/Kafka/Producer.hs --- a/library/Freckle/App/Kafka/Producer.hs +++ b/library/Freckle/App/Kafka/Producer.hs @@ -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) diff --git a/library/Freckle/App/OpenTelemetry.hs b/library/Freckle/App/OpenTelemetry.hs --- a/library/Freckle/App/OpenTelemetry.hs +++ b/library/Freckle/App/OpenTelemetry.hs @@ -1,18 +1,71 @@ +-- | Application tracing via +-- +-- @ +-- 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 . 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 diff --git a/library/Freckle/App/Prelude.hs b/library/Freckle/App/Prelude.hs --- a/library/Freckle/App/Prelude.hs +++ b/library/Freckle/App/Prelude.hs @@ -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) diff --git a/library/Freckle/App/Test.hs b/library/Freckle/App/Test.hs --- a/library/Freckle/App/Test.hs +++ b/library/Freckle/App/Test.hs @@ -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 diff --git a/library/Freckle/App/Wai.hs b/library/Freckle/App/Wai.hs --- a/library/Freckle/App/Wai.hs +++ b/library/Freckle/App/Wai.hs @@ -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 diff --git a/library/Network/Wai/Middleware/OpenTelemetry.hs b/library/Network/Wai/Middleware/OpenTelemetry.hs new file mode 100644 --- /dev/null +++ b/library/Network/Wai/Middleware/OpenTelemetry.hs @@ -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 diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -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