Full support for OpenTelemetry tracing, use it instead of XRay in runDB

.github/workflows/ci.yml

@@ -26,27 +26,25 @@ jobs:
     strategy:
       matrix:
         stack-yaml:
-          - stack-nightly.yaml # ghc-9.4
-          - stack.yaml # ghc-9.2
+          - stack-nightly.yaml # ghc-9.6
+          - stack.yaml # ghc-9.4
+          - stack-lts-20.26.yaml # ghc-9.2
           - stack-lts-19.33.yaml # ghc-9.0
           - stack-lts-18.28.yaml # ghc-8.10
       fail-fast: false
 
     steps:
-      - uses: actions/checkout@v3
+      - uses: actions/checkout@v4
       - name: Install rdkafka
         run: sudo apt-get install --assume-yes --no-install-recommends librdkafka-dev
-      - uses: freckle/stack-cache-action@v2
-        with:
-          stack-yaml: ${{ matrix.stack-yaml }}
-      - uses: freckle/stack-action@v3
+      - uses: freckle/stack-action@v4
         with:
           stack-yaml: ${{ matrix.stack-yaml }}
 
   lint:
     runs-on: ubuntu-latest
     steps:
-      - uses: actions/checkout@v3
+      - uses: actions/checkout@v4
       - uses: haskell/actions/hlint-setup@v2
       - uses: haskell/actions/hlint-run@v2
         with:

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)
 

freckle-app.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.18
 -- see: https://github.com/sol/hpack
 
 name:           freckle-app
-version:        1.9.5.1
+version:        1.10.0.0
 synopsis:       Haskell application toolkit used at Freckle
 description:    Please see README.md
 category:       Utils
@@ -35,6 +35,7 @@ library
       Freckle.App.Bugsnag.MetaData
       Freckle.App.Csv
       Freckle.App.Database
+      Freckle.App.Database.XRay
       Freckle.App.Dotenv
       Freckle.App.Ecs
       Freckle.App.Env
@@ -67,6 +68,7 @@ library
       Freckle.App.Yesod.Routes
       Network.HTTP.Link.Compat
       Network.Wai.Middleware.Cors
+      Network.Wai.Middleware.OpenTelemetry
       Network.Wai.Middleware.Stats
       Yesod.Core.Lens
   other-modules:
@@ -126,6 +128,11 @@ library
     , 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
@@ -134,7 +141,7 @@ library
     , http-conduit >=2.3.5
     , http-link-header
     , http-types
-    , hw-kafka-client
+    , hw-kafka-client <5.0.0
     , immortal
     , lens
     , memcache
@@ -148,7 +155,7 @@ library
     , persistent-postgresql
     , postgresql-simple
     , primitive
-    , resource-pool
+    , resource-pool >=0.4.0.0
     , resourcet
     , retry >=0.8.1.0
     , safe

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,21 +175,21 @@ module Freckle.App
   , runAppT
 
     -- * Re-exports
-  , module Freckle.App.Database
-  , module Freckle.App.OpenTelemetry
   , module Blammo.Logging
   , module Control.Monad.Reader
   ) where
 
 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 @@ instance PrimMonad m => PrimMonad (AppT app m) where
   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

@@ -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 Freckle.App.Prelude
 
 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 @@ import Database.Persist.Postgresql
   , 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
 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 @@ makePostgresPool = do
   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)
@@ -101,31 +110,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
   , pccPort :: Int