Merge pull request #3 from MercuryTechnologies/avieth/strictness

persistent: fully evaluate before opening span
iand675 · Nov 30, 2022 · 8ccf449 · 8ccf449
2 parents 0b5dd25 + 6b003e5
commit 8ccf449
Show file tree

Hide file tree

Showing 3 changed files with 7 additions and 3 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,6 +6,7 @@ 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)
@@ -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)
-    ]
+    ]