hs-opentelemetry-instrumentation-persistent 0.0.1.0 → 0.1.0.0

raw patch · 5 files changed

+215/−105 lines, 5 filesdep +clockdep +unordered-containersdep ~hs-opentelemetry-apisetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: clock, unordered-containers

Dependency ranges changed: hs-opentelemetry-api

API changes (from Hackage documentation)

Files

• ChangeLog.md +8/−2
• Setup.hs +2/−0
• hs-opentelemetry-instrumentation-persistent.cabal +18/−14
• src/OpenTelemetry/Instrumentation/Persistent.hs +186/−89
• test/Spec.hs +1/−0

@@ -1,7 +1,13 @@ # Changelog for hs-opentelemetry-persistent +## Unreleased changes++## 0.1.0.0++### Breaking changes++- Use `HashMap Text Attribute` instead of `[(Text, Attribute)]` as attributes+ ## 0.0.1.0  - Initial release--## Unreleased changes

@@ -1,2 +1,4 @@ import Distribution.Simple++ main = defaultMain

@@ -1,20 +1,20 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4.+-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack -name:           hs-opentelemetry-instrumentation-persistent-version:        0.0.1.0-description:    Please see the README on GitHub at <https://github.com/iand675/hs-opentelemetry/tree/main/instrumentation/persistent#readme>-homepage:       https://github.com/iand675/hs-opentelemetry#readme-bug-reports:    https://github.com/iand675/hs-opentelemetry/issues-author:         Ian Duncan-maintainer:     ian@iankduncan.com-copyright:      2021 Ian Duncan-license:        BSD3-license-file:   LICENSE-build-type:     Simple+name:               hs-opentelemetry-instrumentation-persistent+version:            0.1.0.0+description:        Please see the README on GitHub at <https://github.com/iand675/hs-opentelemetry/tree/main/instrumentation/persistent#readme>+homepage:           https://github.com/iand675/hs-opentelemetry#readme+bug-reports:        https://github.com/iand675/hs-opentelemetry/issues+author:             Ian Duncan, Jade Lovelace+maintainer:         ian@iankduncan.com+copyright:          2023 Ian Duncan, Mercury Technologies+license:            BSD3+license-file:       LICENSE+build-type:         Simple extra-source-files:     README.md     ChangeLog.md@@ -32,12 +32,14 @@       src   build-depends:       base >=4.7 && <5-    , hs-opentelemetry-api ==0.0.3.*+    , clock+    , hs-opentelemetry-api ==0.1.*     , mtl     , persistent >=2.13.3     , resourcet     , text     , unliftio+    , unordered-containers     , vault   default-language: Haskell2010 @@ -51,12 +53,14 @@   ghc-options: -threaded -rtsopts -with-rtsopts=-N   build-depends:       base >=4.7 && <5-    , hs-opentelemetry-api ==0.0.3.*+    , clock+    , hs-opentelemetry-api ==0.1.*     , hs-opentelemetry-instrumentation-persistent     , mtl     , persistent >=2.13.3     , resourcet     , text     , unliftio+    , unordered-containers     , vault   default-language: Haskell2010

@@ -1,132 +1,229 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-}-module OpenTelemetry.Instrumentation.Persistent-  ( wrapSqlBackend-  ) where-import OpenTelemetry.Trace.Core-import OpenTelemetry.Context++module OpenTelemetry.Instrumentation.Persistent (+  wrapSqlBackend,+  wrapSqlBackend',+) where++import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Reader import Data.Acquire.Internal+import Data.IORef+import qualified Data.HashMap.Strict as H import Data.Maybe (fromMaybe) import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Vault.Strict as Vault import Database.Persist.Sql-import Database.Persist.SqlBackend (setConnHooks, emptySqlBackendHooks, MkSqlBackendArgs (connRDBMS), getRDBMS, getConnVault, modifyConnVault)+import Database.Persist.SqlBackend (MkSqlBackendArgs (connRDBMS), emptySqlBackendHooks, getConnVault, getRDBMS, modifyConnVault, setConnHooks) import Database.Persist.SqlBackend.Internal-import Control.Monad.IO.Class-import System.IO.Unsafe (unsafePerformIO)-import qualified Data.Vault.Strict as Vault import OpenTelemetry.Attributes (Attributes)+import OpenTelemetry.Common+import OpenTelemetry.Context+import OpenTelemetry.Context.ThreadLocal (adjustContext, getContext) import OpenTelemetry.Resource+import OpenTelemetry.Trace.Core+import OpenTelemetry.Trace.Monad (MonadTracer (..))+import System.Clock+import System.IO.Unsafe (unsafePerformIO) import UnliftIO.Exception-import OpenTelemetry.Trace.Monad (MonadTracer(..))-import Control.Monad.Reader-import qualified Data.Text as T-import OpenTelemetry.Context.ThreadLocal (getContext, adjustContext) -instance {-# OVERLAPS #-} MonadTracer m => MonadTracer (ReaderT SqlBackend m) where++{-+Design notes:++In some OTel export destinations like Honeycomb, the cost is per-span. Consquently, we want to minimize the number of spans we create. In particular, we want to avoid creating a span for every query, since they add up cost-wise.++However, we also want to capture transactions as spans. Therefore, for pool acquisitions we track the time between trying to acquire the connection and the time the connection is obtained as an attribute on the initial span.+-}++instance {-# OVERLAPS #-} (MonadTracer m) => MonadTracer (ReaderT SqlBackend m) where   getTracer = lift OpenTelemetry.Trace.Monad.getTracer-instance {-# OVERLAPS #-} MonadTracer m => MonadTracer (ReaderT SqlReadBackend m) where+++instance {-# OVERLAPS #-} (MonadTracer m) => MonadTracer (ReaderT SqlReadBackend m) where   getTracer = lift OpenTelemetry.Trace.Monad.getTracer-instance {-# OVERLAPS #-} MonadTracer m => MonadTracer (ReaderT SqlWriteBackend m) where+++instance {-# OVERLAPS #-} (MonadTracer m) => MonadTracer (ReaderT SqlWriteBackend m) where   getTracer = lift OpenTelemetry.Trace.Monad.getTracer + originalConnectionKey :: Vault.Key SqlBackend originalConnectionKey = unsafePerformIO Vault.newKey {-# NOINLINE originalConnectionKey #-} + insertOriginalConnection :: SqlBackend -> SqlBackend -> SqlBackend insertOriginalConnection conn original = modifyConnVault (Vault.insert originalConnectionKey original) conn + lookupOriginalConnection :: SqlBackend -> Maybe SqlBackend lookupOriginalConnection = Vault.lookup originalConnectionKey . getConnVault -connectionLevelAttributesKey :: Vault.Key [(Text, Attribute)]++connectionLevelAttributesKey :: Vault.Key (H.HashMap Text Attribute) connectionLevelAttributesKey = unsafePerformIO Vault.newKey {-# NOINLINE connectionLevelAttributesKey #-} --- | Wrap a 'SqlBackend' with appropriate tracing context and attributes--- so that queries are tracked appropriately in the tracing hierarchy.-wrapSqlBackend-  :: MonadIO m-  => [(Text, Attribute)]-  -- ^ Attributes that are specific to providers like MySQL, PostgreSQL, etc.-  -> SqlBackend-  -> m SqlBackend++{- | Wrap a 'SqlBackend' with appropriate tracing context and attributes+ so that queries are tracked appropriately in the tracing hierarchy.+-}+wrapSqlBackend ::+  MonadIO m =>+  -- | Attributes that are specific to providers like MySQL, PostgreSQL, etc.+  H.HashMap Text Attribute ->+  SqlBackend ->+  m SqlBackend wrapSqlBackend attrs conn_ = do   tp <- getGlobalTracerProvider+  wrapSqlBackend' tp attrs conn_+++{- | Wrap a 'SqlBackend' with appropriate tracing context and attributes+so that queries are tracked appropriately in the tracing hierarchy.+-}+wrapSqlBackend' :: MonadIO m =>+  TracerProvider ->+  -- | Attributes that are specific to providers like MySQL, PostgreSQL, etc.+  H.HashMap Text Attribute ->+  SqlBackend ->+  m SqlBackend+wrapSqlBackend' tp attrs conn_ = do   let conn = Data.Maybe.fromMaybe conn_ (lookupOriginalConnection conn_)+  {- A connection is acquired when the connection pool is asked for a connection. The runSqlPool function in Persistent then+    immediately begins a transaction and ensures the transaction is committed or rolled back. Since we want to capture the+    transaction as a span, we have to use track the current Span in flight. We do this because we can't hand off+    the Span between connBegin/connCommit/connRollback as return values.+  -}+  connParentSpan <- liftIO $ newIORef Nothing+  connSpanInFlight <- liftIO $ newIORef Nothing   -- TODO add schema to tracerOptions?   let t = makeTracer tp "hs-opentelemetry-persistent" tracerOptions-  let hooks = emptySqlBackendHooks-        { hookGetStatement = \conn sql stmt -> do-            pure $ Statement-              { stmtQuery = \ps -> do-                  ctxt <- getContext-                  let spanCreator = do-                        s <- createSpan-                          t-                          ctxt-                          sql-                          (defaultSpanArguments { kind = Client, attributes = ("db.statement", toAttribute sql) : attrs })-                        adjustContext (insertSpan s)-                        pure (lookupSpan ctxt, s)-                      spanCleanup (parent, s) = do-                        s `endSpan` Nothing-                        adjustContext $ \ctx ->-                          maybe ctx (`insertSpan` ctx) parent--                  (p, child) <- mkAcquire spanCreator spanCleanup+  let hooks =+        emptySqlBackendHooks+          { hookGetStatement = \conn sql stmt -> do+              pure $+                Statement+                  { stmtQuery = \ps -> do+                      ctxt <- getContext+                      let spanCreator = do+                            s <-+                              createSpan+                                t+                                ctxt+                                sql+                                (defaultSpanArguments {kind = Client, attributes = H.insert "db.statement" (toAttribute sql) attrs})+                            adjustContext (insertSpan s)+                            pure (lookupSpan ctxt, s)+                          spanCleanup (parent, s) = do+                            s `endSpan` Nothing+                            adjustContext $ \ctx ->+                              maybe (removeSpan ctx) (`insertSpan` ctx) parent -                  annotateBasics child conn-                  case stmtQuery stmt ps of-                    Acquire stmtQueryAcquireF -> Acquire $ \f ->-                      handleAny-                        (\(SomeException err) -> do-                          recordException child [] Nothing err-                          endSpan child Nothing-                          throwIO err-                        )-                        (stmtQueryAcquireF f)+                      (p, child) <- mkAcquire spanCreator spanCleanup -              , stmtExecute = \ps -> do-                inSpan' t sql (defaultSpanArguments { kind = Client, attributes = ("db.statement", toAttribute sql) : attrs }) $ \s -> do-                  annotateBasics s conn-                  stmtExecute stmt ps-              , stmtReset = stmtReset stmt-              , stmtFinalize = stmtFinalize stmt-              }-        }+                      annotateBasics child conn+                      case stmtQuery stmt ps of+                        Acquire stmtQueryAcquireF -> Acquire $ \f ->+                          handleAny+                            ( \(SomeException err) -> do+                                recordException child [("exception.escaped", toAttribute True)] Nothing err+                                endSpan child Nothing+                                throwIO err+                            )+                            (stmtQueryAcquireF f)+                  , stmtExecute = \ps -> do+                      inSpan' t sql (defaultSpanArguments {kind = Client, attributes = H.insert "db.statement" (toAttribute sql) attrs}) $ \s -> do+                        annotateBasics s conn+                        stmtExecute stmt ps+                  , stmtReset = stmtReset stmt+                  , stmtFinalize = stmtFinalize stmt+                  }+          } -  let conn' = conn-        { connHooks = hooks-        , connBegin = \f mIso -> do-            let statement = "begin transaction" <> case mIso of-                  Nothing -> mempty-                  Just ReadUncommitted -> " isolation level read uncommitted"-                  Just ReadCommitted -> " isolation level read committed"-                  Just RepeatableRead -> " isolation level repeatable read"-                  Just Serializable -> " isolation level serializable"-            let attrs' = ("db.statement", toAttribute statement) : attrs-            inSpan' t statement (defaultSpanArguments { kind = Client, attributes = attrs' }) $ \s -> do+      conn' =+        conn+          { connHooks = hooks+          , connBegin = \f mIso -> do+              ctxt <- getContext+              s <- createSpan t ctxt "transaction" (defaultSpanArguments {kind = Client, attributes = attrs})               annotateBasics s conn+              writeIORef connSpanInFlight (Just s)+              writeIORef connParentSpan (lookupSpan ctxt)+              adjustContext (insertSpan s)+              case mIso of+                Nothing -> pure ()+                Just iso -> addAttribute s "db.transaction.isolation" $ case iso of+                  ReadUncommitted -> "read uncommitted" :: Text+                  ReadCommitted -> "read committed"+                  RepeatableRead -> "repeatable read"+                  Serializable -> "serializable"               connBegin conn f mIso-        , connCommit = \f -> do-            inSpan' t "commit" (defaultSpanArguments { kind = Client, attributes = ("db.statement", toAttribute ("commit" :: Text)): attrs }) $ \s -> do-              annotateBasics s conn-              connCommit conn f-        , connRollback = \f -> do-            inSpan' t "rollback" (defaultSpanArguments { kind = Client, attributes = ("db.statement", toAttribute ("rollback" :: Text)): attrs }) $ \s -> do-              annotateBasics s conn-              connRollback conn f-        , connClose = do-            inSpan' t "close connection" (defaultSpanArguments { kind = Client, attributes = attrs }) $ \s -> do-              annotateBasics s conn-              connClose conn-        }+          , connCommit = \f -> do+              spanInFlight <- readIORef connSpanInFlight+              parentSpan <- readIORef connParentSpan+              let act = do+                    (Timestamp tsStart) <- getTimestamp+                    result <- tryAny $ connCommit conn f+                    (Timestamp tsEnd) <- getTimestamp+                    forM_ spanInFlight $ \s -> do+                      addAttributes+                        s+                        [ ("db.transaction.outcome", toAttribute ("committed" :: Text))+                        , ("db.transaction.commit_duration_ns", toAttribute $ fromIntegral @Integer @Int $ toNanoSecs (diffTimeSpec tsStart tsEnd) `div` 1000)+                        ]+                      endSpan s Nothing+                      case result of+                        Left (SomeException err) -> do+                          recordException s [("exception.escaped", toAttribute True)] Nothing err+                          throwIO err+                        Right _ -> pure ()+              act `finally` do+                adjustContext $ \ctx ->+                  maybe (removeSpan ctx) (`insertSpan` ctx) parentSpan+                forM_ spanInFlight $ \s -> endSpan s Nothing+          , connRollback = \f -> do+              spanInFlight <- readIORef connSpanInFlight+              parentSpan <- readIORef connParentSpan+              let act = do+                    (Timestamp tsStart) <- getTimestamp+                    result <- tryAny $ connRollback conn f+                    e@(Timestamp tsEnd) <- getTimestamp+                    forM_ spanInFlight $ \s -> do+                      addAttributes+                        s+                        [ ("db.transaction.outcome", toAttribute ("rolled back" :: Text))+                        , ("db.transaction.commit_duration_microseconds", toAttribute $ fromIntegral @Integer @Int $ toNanoSecs (diffTimeSpec tsStart tsEnd `div` 1000))+                        ]+                      endSpan s (Just e)+                      case result of+                        Left (SomeException err) -> do+                          recordException s [("exception.escaped", toAttribute True)] Nothing err+                          throwIO err+                        Right _ -> pure ()+              act `finally` do+                adjustContext $ \ctx ->+                  maybe (removeSpan ctx) (`insertSpan` ctx) parentSpan+                forM_ spanInFlight $ \s -> endSpan s Nothing+          , -- TODO: This doesn't work when we wrap the connections for the pool.+            connClose = do+              inSpan' t "close connection" (defaultSpanArguments {kind = Client, attributes = attrs}) $ \s -> do+                annotateBasics s conn+                connClose conn+          }   pure $ insertOriginalConnection conn' conn -annotateBasics :: MonadIO m => Span -> SqlBackend -> m ()++annotateBasics :: (MonadIO m) => Span -> SqlBackend -> m () annotateBasics span conn = do-  addAttributes span+  addAttributes+    span     [ ("db.system", toAttribute $ getRDBMS conn)     ]

@@ -1,2 +1,3 @@+ main :: IO () main = putStrLn "Test suite not yet implemented"