diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,7 @@ +# Changelog for hs-opentelemetry-persistent + +## 0.0.1.0 + +- Initial release + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# hs-opentelemetry-persistent diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hs-opentelemetry-instrumentation-persistent.cabal b/hs-opentelemetry-instrumentation-persistent.cabal new file mode 100644 --- /dev/null +++ b/hs-opentelemetry-instrumentation-persistent.cabal @@ -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 +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 diff --git a/src/OpenTelemetry/Instrumentation/Persistent.hs b/src/OpenTelemetry/Instrumentation/Persistent.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/Instrumentation/Persistent.hs @@ -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) + ] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"