hs-opentelemetry-instrumentation-persistent (empty) → 0.0.1.0

raw patch · 7 files changed

+236/−0 lines, 7 filesdep +basedep +hs-opentelemetry-apidep +hs-opentelemetry-instrumentation-persistentsetup-changed

Dependencies added: base, hs-opentelemetry-api, hs-opentelemetry-instrumentation-persistent, mtl, persistent, resourcet, text, unliftio, vault

Files

• ChangeLog.md +7/−0
• LICENSE +30/−0
• README.md +1/−0
• Setup.hs +2/−0
• hs-opentelemetry-instrumentation-persistent.cabal +62/−0
• src/OpenTelemetry/Instrumentation/Persistent.hs +132/−0
• test/Spec.hs +2/−0

@@ -0,0 +1,7 @@+# Changelog for hs-opentelemetry-persistent++## 0.0.1.0++- Initial release++## Unreleased changes

@@ -0,0 +1,30 @@+Copyright Ian Duncan (c) 2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Ian Duncan nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,1 @@+# hs-opentelemetry-persistent

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

@@ -0,0 +1,62 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- 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+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/iand675/hs-opentelemetry++library+  exposed-modules:+      OpenTelemetry.Instrumentation.Persistent+  other-modules:+      Paths_hs_opentelemetry_instrumentation_persistent+  hs-source-dirs:+      src+  build-depends:+      base >=4.7 && <5+    , hs-opentelemetry-api ==0.0.3.*+    , mtl+    , persistent >=2.13.3+    , resourcet+    , text+    , unliftio+    , vault+  default-language: Haskell2010++test-suite hs-opentelemetry-persistent-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_hs_opentelemetry_instrumentation_persistent+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , hs-opentelemetry-api ==0.0.3.*+    , hs-opentelemetry-instrumentation-persistent+    , mtl+    , persistent >=2.13.3+    , resourcet+    , text+    , unliftio+    , vault+  default-language: Haskell2010

@@ -0,0 +1,132 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module OpenTelemetry.Instrumentation.Persistent+  ( wrapSqlBackend+  ) where+import OpenTelemetry.Trace.Core+import OpenTelemetry.Context+import Data.Acquire.Internal+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Database.Persist.Sql+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)+import qualified Data.Vault.Strict as Vault+import OpenTelemetry.Attributes (Attributes)+import OpenTelemetry.Resource+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+  getTracer = lift OpenTelemetry.Trace.Monad.getTracer+instance {-# OVERLAPS #-} MonadTracer m => MonadTracer (ReaderT SqlReadBackend m) where+  getTracer = lift OpenTelemetry.Trace.Monad.getTracer+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 = 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+wrapSqlBackend attrs conn_ = do+  tp <- getGlobalTracerProvider+  let conn = Data.Maybe.fromMaybe conn_ (lookupOriginalConnection conn_)+  -- 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++                  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)++              , 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+              }+        }++  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+              annotateBasics s conn+              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+        }+  pure $ insertOriginalConnection conn' conn++annotateBasics :: MonadIO m => Span -> SqlBackend -> m ()+annotateBasics span conn = do+  addAttributes span+    [ ("db.system", toAttribute $ getRDBMS conn)+    ]

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