diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 6e1d58b..4187672 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -4,7 +4,6 @@ on: push: branches: [ "main" ] pull_request: - branches: [ "main" ] types: [ opened, synchronize, reopened, ready_for_review ] permissions: @@ -114,6 +113,8 @@ jobs: ${{ runner.os }}-build- ${{ runner.os }}- + - name: Configure cabal flags + run: cabal configure -fenable-otel -fenable-pool - name: Install dependencies run: | cabal update diff --git a/effectful-opaleye/effectful-opaleye.cabal b/effectful-opaleye/effectful-opaleye.cabal index ba0feb4..3efb39a 100644 --- a/effectful-opaleye/effectful-opaleye.cabal +++ b/effectful-opaleye/effectful-opaleye.cabal @@ -17,8 +17,7 @@ extra-doc-files: README.md CHANGELOG.md tested-with: - GHC == 8.10.7 - , GHC == 9.0.2 + GHC == 9.0.2 , GHC == 9.2.4 , GHC == 9.2.8 , GHC == 9.4.2 diff --git a/effectful-postgresql/CHANGELOG.md b/effectful-postgresql/CHANGELOG.md index 1ed7c19..b8d94df 100644 --- a/effectful-postgresql/CHANGELOG.md +++ b/effectful-postgresql/CHANGELOG.md @@ -13,6 +13,7 @@ and this project adheres to [Haskell Package Versioning Policy](https://pvp.hask ### Added - Support `withTransactionX` functions from `postgresql-simple` in [#13](https://github.com/fpringle/effectful-postgresql/pulls/13) +- Support OpenTelemetry instrumentation in [#16](https://github.com/fpringle/effectful-postgresql/pull/16) ## [0.1.0.1] - 04.08.2025 diff --git a/effectful-postgresql/README.md b/effectful-postgresql/README.md index 1833112..a14ead4 100644 --- a/effectful-postgresql/README.md +++ b/effectful-postgresql/README.md @@ -59,6 +59,13 @@ dischargePostgreSQL :: (WithConnection :> es, IOE :> es) => Eff es [User] dischargePostgreSQL = runPostgreSQL insertAndListCarefully ``` +Alternatively we can use the OpenTelemetry support provided by [hs-opentelemetry-instrumentation-postgresql-simple](https://hackage-content.haskell.org/package/hs-opentelemetry-instrumentation-postgresql-simple/docs/OpenTelemetry-Instrumentation-PostgresqlSimple.html) (note that this requires enabling the `enable-opentel` cabal flag): + +```haskell +dischargePostgreSQLUsingOpenTelemetry :: (WithConnection :> es, IOE :> es) => Eff es [User] +dischargePostgreSQLUsingOpenTelemetry = runPostgreSQLOT insertAndListCarefully +``` + The simplest way of running the `WithConnection` effect is by just providing a `Connection`, which we can get in the normal ways: ```haskell diff --git a/effectful-postgresql/effectful-postgresql.cabal b/effectful-postgresql/effectful-postgresql.cabal index cdf0b26..d2de569 100644 --- a/effectful-postgresql/effectful-postgresql.cabal +++ b/effectful-postgresql/effectful-postgresql.cabal @@ -17,9 +17,7 @@ extra-doc-files: README.md CHANGELOG.md tested-with: - GHC == 8.8.4 - , GHC == 8.10.7 - , GHC == 9.0.2 + GHC == 9.0.2 , GHC == 9.2.4 , GHC == 9.2.8 , GHC == 9.4.2 @@ -36,12 +34,21 @@ flag enable-pool default: True manual: False +flag enable-otel + description: Enable OpenTelemetry instrumentation support using + hs-opentelemetry-instrumentation-postgresql-simple. + default: False + manual: True + common warnings ghc-options: -Wall -Wno-unused-do-bind -Wunused-packages if flag(enable-pool) cpp-options: -DPOOL + if flag(enable-otel) + cpp-options: -DOTEL + common deps build-depends: , base >= 4 && < 5 @@ -53,6 +60,10 @@ common deps build-depends: , unliftio-pool >= 0.4.1 && < 0.5 + if flag(enable-otel) + build-depends: + , hs-opentelemetry-instrumentation-postgresql-simple >= 1.0 && < 1.1 + common extensions default-extensions: DataKinds diff --git a/effectful-postgresql/src/Effectful/PostgreSQL.hs b/effectful-postgresql/src/Effectful/PostgreSQL.hs index 0cc71f6..06d779e 100644 --- a/effectful-postgresql/src/Effectful/PostgreSQL.hs +++ b/effectful-postgresql/src/Effectful/PostgreSQL.hs @@ -15,6 +15,10 @@ module Effectful.PostgreSQL , runPostgreSQL +#if OTEL + , runPostgreSQLOT +#endif + -- * Lifted versions of functions from Database.PostgreSQL.Simple -- ** Queries that return results diff --git a/effectful-postgresql/src/Effectful/PostgreSQL/Effect.hs b/effectful-postgresql/src/Effectful/PostgreSQL/Effect.hs index d954652..7ddc5f2 100644 --- a/effectful-postgresql/src/Effectful/PostgreSQL/Effect.hs +++ b/effectful-postgresql/src/Effectful/PostgreSQL/Effect.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE TemplateHaskell #-} module Effectful.PostgreSQL.Effect @@ -6,6 +8,9 @@ module Effectful.PostgreSQL.Effect -- ** Interpreters , runPostgreSQL +#if OTEL + , runPostgreSQLOT +#endif -- * Lifted versions of functions from Database.PostgreSQL.Simple @@ -63,6 +68,9 @@ import Effectful import Effectful.Dispatch.Dynamic import Effectful.PostgreSQL.Connection import Effectful.TH +#if OTEL +import qualified "hs-opentelemetry-instrumentation-postgresql-simple" OpenTelemetry.Instrumentation.PostgresqlSimple as OT +#endif -- | Dynamic effect representing all the Postgres operations we want to perform. data PostgreSQL :: Effect where @@ -293,3 +301,74 @@ runPostgreSQL = interpret $ \env -> \case localUnliftWithConn env $ \conn unlift -> PSQL.forEachWith_ parser conn q (unlift . forR) ReturningWith parser q rows -> withConnection $ \conn -> liftIO $ PSQL.returningWith parser conn q rows + +#if OTEL +{- | An interpreter for the 'PostgreSQL' effect that runs database operations using OpenTelemetry instrumentation. + +Basically the same as 'runPostgreSQL' except it uses the functions from +[OpenTelemetry.Instrumentation.PostgresqlSimple](https://hackage-content.haskell.org/package/hs-opentelemetry-instrumentation-postgresql-simple/docs/OpenTelemetry-Instrumentation-PostgresqlSimple.html). + +Note that the @enable-opentel@ cabal flag must be set to enable this functionality. +-} +runPostgreSQLOT :: forall es a. (HasCallStack, WithConnection :> es, IOE :> es) => Eff (PostgreSQL : es) a -> Eff es a +runPostgreSQLOT = interpret $ \env -> \case + Query q row -> + withConnection $ \conn -> OT.query conn q row + QueryWith parser q row -> + withConnection $ \conn -> OT.queryWith parser conn q row + Query_ row -> + withConnection $ \conn -> OT.query_ conn row + QueryWith_ parser row -> + withConnection $ \conn -> OT.queryWith_ parser conn row + Execute q row -> withConnection $ \conn -> OT.execute conn q row + Execute_ q -> withConnection $ \conn -> OT.execute_ conn q + ExecuteMany q row -> withConnection $ \conn -> OT.executeMany conn q row + WithTransaction f -> localUnliftWithConn env $ \conn unlift -> OT.withTransaction conn (unlift f) + WithTransactionLevel level f -> localUnliftWithConn env $ \conn unlift -> PSQL.withTransactionLevel level conn (unlift f) + WithTransactionMode mode f -> localUnliftWithConn env $ \conn unlift -> PSQL.withTransactionMode mode conn (unlift f) + WithTransactionModeRetry mode shouldRetry f -> localUnliftWithConn env $ \conn unlift -> PSQL.withTransactionModeRetry mode shouldRetry conn (unlift f) + WithTransactionModeRetry' mode shouldRetry f -> localUnliftWithConn env $ \conn unlift -> PSQL.withTransactionModeRetry' mode shouldRetry conn (unlift f) + WithTransactionSerializable f -> localUnliftWithConn env $ \conn unlift -> PSQL.withTransactionSerializable conn (unlift f) + WithSavepoint f -> localUnliftWithConn env $ \conn unlift -> OT.withSavepoint conn (unlift f) + Begin -> withConnection $ liftIO . OT.begin + Commit -> withConnection $ liftIO . OT.commit + Rollback -> withConnection $ liftIO . OT.rollback + Fold q params a f -> + localUnliftWithConn env $ \conn unlift -> + OT.fold conn q params a (unlift ... f) + Fold_ q a f -> + localUnliftWithConn env $ \conn unlift -> + OT.fold_ conn q a (unlift ... f) + FoldWithOptions opts q params a f -> + localUnliftWithConn env $ \conn unlift -> + OT.foldWithOptions opts conn q params a (unlift ... f) + FoldWithOptions_ opts q a f -> + localUnliftWithConn env $ \conn unlift -> + OT.foldWithOptions_ opts conn q a (unlift ... f) + ForEach q row forR -> + localUnliftWithConn env $ \conn unlift -> + OT.forEachWith PSQL.fromRow conn q row (unlift . forR) + ForEach_ q forR -> + localUnliftWithConn env $ \conn unlift -> + OT.forEach_ conn q (unlift . forR) + Returning q rows -> withConnection $ \conn -> OT.returning conn q rows + FoldWith parser q params a f -> + localUnliftWithConn env $ \conn unlift -> + OT.foldWith parser conn q params a (unlift ... f) + FoldWithOptionsAndParser opts parser q params a f -> + localUnliftWithConn env $ \conn unlift -> + OT.foldWithOptionsAndParser opts parser conn q params a (unlift ... f) + FoldWith_ parser q a f -> + localUnliftWithConn env $ \conn unlift -> + OT.foldWith_ parser conn q a (unlift ... f) + FoldWithOptionsAndParser_ opts parser q a f -> + localUnliftWithConn env $ \conn unlift -> + OT.foldWithOptionsAndParser_ opts parser conn q a (unlift ... f) + ForEachWith parser q row forR -> + localUnliftWithConn env $ \conn unlift -> + OT.forEachWith parser conn q row (unlift . forR) + ForEachWith_ parser q forR -> + localUnliftWithConn env $ \conn unlift -> + OT.forEachWith_ parser conn q (unlift . forR) + ReturningWith parser q rows -> withConnection $ \conn -> OT.returningWith parser conn q rows +#endif