fully evaluate before opening span

This will make metrics more accurate because the cost of computing the values which form the query/statement is no longer factored into the span.
iand675 · Nov 17, 2022 · 6b003e5 · 6b003e5
1 parent 315f8f8
commit 6b003e5
Show file tree

Hide file tree

Showing 3 changed files with 8 additions and 4 deletions.
diff --git a/instrumentation/persistent/hs-opentelemetry-instrumentation-persistent.cabal b/instrumentation/persistent/hs-opentelemetry-instrumentation-persistent.cabal
@@ -39,6 +39,7 @@ library
     , text
     , unliftio
     , vault
+    , deepseq
   default-language: Haskell2010
 
 test-suite hs-opentelemetry-persistent-test
@@ -59,4 +60,5 @@ test-suite hs-opentelemetry-persistent-test
     , text
     , unliftio
     , vault
+    , deepseq
   default-language: Haskell2010
diff --git a/instrumentation/persistent/package.yaml b/instrumentation/persistent/package.yaml
@@ -27,6 +27,7 @@ dependencies:
 - resourcet
 - unliftio # TODO, unliftio-core
 - mtl
+- deepseq
 
 library:
   # ghc-options: -Wall

diff --git a/instrumentation/persistent/src/OpenTelemetry/Instrumentation/Persistent.hs b/instrumentation/persistent/src/OpenTelemetry/Instrumentation/Persistent.hs
@@ -6,11 +6,12 @@ module OpenTelemetry.Instrumentation.Persistent
   ) where
 import OpenTelemetry.Trace.Core
 import OpenTelemetry.Context
+import Control.DeepSeq (deepseq)
 import Data.Acquire.Internal
 import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import Database.Persist.Sql
-import Database.Persist.SqlBackend (setConnHooks, SqlBackendHooks (hookGetStatement), emptySqlBackendHooks, MkSqlBackendArgs (connRDBMS), getRDBMS, getConnVault, modifyConnVault)
+import Database.Persist.SqlBackend (setConnHooks, emptySqlBackendHooks, MkSqlBackendArgs (connRDBMS), getRDBMS, getConnVault, modifyConnVault)
 import Database.Persist.SqlBackend.Internal
 import Control.Monad.IO.Class
 import System.IO.Unsafe (unsafePerformIO)
@@ -60,7 +61,7 @@ wrapSqlBackend attrs conn_ = do
   let hooks = emptySqlBackendHooks
         { hookGetStatement = \conn sql stmt -> do
             pure $ Statement
-              { stmtQuery = \ps -> do
+              { stmtQuery = \ps -> ps `deepseq` do
                   ctxt <- getContext
                   let spanCreator = do
                         s <- createSpan
@@ -88,7 +89,7 @@ wrapSqlBackend attrs conn_ = do
                         )
                         (stmtQueryAcquireF f)
 
-              , stmtExecute = \ps -> do
+              , stmtExecute = \ps -> ps `deepseq` do
                 inSpan' t sql (defaultSpanArguments { kind = Client, attributes = ("db.statement", toAttribute sql) : attrs }) $ \s -> do
                   annotateBasics s conn
                   stmtExecute stmt ps
@@ -129,4 +130,4 @@ annotateBasics :: MonadIO m => Span -> SqlBackend -> m ()
 annotateBasics span conn = do
   addAttributes span
     [ ("db.system", toAttribute $ getRDBMS conn)
-    ]
+    ]