diff --git a/hs-opentelemetry-instrumentation-persistent-mysql.cabal b/hs-opentelemetry-instrumentation-persistent-mysql.cabal new file mode 100644 --- /dev/null +++ b/hs-opentelemetry-instrumentation-persistent-mysql.cabal @@ -0,0 +1,60 @@ +cabal-version: 2.4 + +name: hs-opentelemetry-instrumentation-persistent-mysql +version: 0.0.0.0 +synopsis: OpenTelemetry instrumentation for persistent-mysql +license: BSD-3-Clause +author: Kazuki Okamoto (岡本和樹) +maintainer: kazuki.okamoto@herp.co.jp + +common common + build-depends: base >= 4 && < 5 + ghc-options: -Wall + if impl(ghc >= 8.0) + ghc-options: -Wcompat + default-language: Haskell2010 + +library + import: common + hs-source-dirs: src + exposed-modules: OpenTelemetry.Instrumentation.Persistent.MySQL + build-depends: hs-opentelemetry-api, + hs-opentelemetry-instrumentation-persistent, + iproute, + monad-logger, + mysql, + persistent, + persistent-mysql, + resource-pool, + text, + unliftio-core, + unordered-containers + ghc-options: -Wcompat + -Wno-name-shadowing + if impl(ghc >= 6.4) + ghc-options: -Wincomplete-record-updates + if impl(ghc >= 6.8) + ghc-options: -Wmonomorphism-restriction + if impl(ghc >= 7.0) + ghc-options: -Wmissing-import-lists + if impl(ghc >= 7.2) + ghc-options: -Wincomplete-uni-patterns + -Widentities + if impl(ghc >= 8.0) + ghc-options: -Wmissing-exported-signatures + -Wredundant-constraints + if impl(ghc >= 8.2) + ghc-options: -Wmissing-home-modules + if impl(ghc >= 8.4) + ghc-options: -Wmissing-export-lists + -Wpartial-fields + if impl(ghc >= 8.8) + ghc-options: -Wmissing-deriving-strategies + if impl(ghc >= 8.10) + ghc-options: -Wunused-packages + if impl(ghc >= 9.0) + ghc-options: -Winvalid-haddock + if impl(ghc >= 9.2) + ghc-options: -Wmissing-kind-signatures + -Woperator-whitespace + -Wredundant-bang-patterns diff --git a/src/OpenTelemetry/Instrumentation/Persistent/MySQL.hs b/src/OpenTelemetry/Instrumentation/Persistent/MySQL.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/Instrumentation/Persistent/MySQL.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +-- option for module re-export +{-# OPTIONS_GHC -Wno-missing-import-lists #-} + +{- | Wrapper module for @Database.Persist.MySQL@ with @OpenTelemetry.Instrumentation.Persistent@. + +[New HTTP semantic conventions have been declared stable.](https://opentelemetry.io/blog/2023/http-conventions-declared-stable/#migration-plan) Opt-in by setting the environment variable OTEL_SEMCONV_STABILITY_OPT_IN to +- "http" - to use the stable conventions +- "http/dup" - to emit both the old and the stable conventions +Otherwise, the old conventions will be used. The stable conventions will replace the old conventions in the next major release of this library. +-} +module OpenTelemetry.Instrumentation.Persistent.MySQL ( + withMySQLPool, + withMySQLConn, + createMySQLPool, + module Database.Persist.Sql, + MySQL.ConnectInfo (..), + MySQL.SSLInfo (..), + MySQL.defaultConnectInfo, + MySQL.defaultSSLInfo, + Orig.MySQLConf (..), + + -- * @ON DUPLICATE KEY UPDATE@ Functionality + Orig.insertOnDuplicateKeyUpdate, + Orig.insertManyOnDuplicateKeyUpdate, + Orig.HandleUpdateCollision, + Orig.copyField, + Orig.copyUnlessNull, + Orig.copyUnlessEmpty, + Orig.copyUnlessEq, + openMySQLConn, +) where + +import Control.Monad.IO.Unlift (MonadUnliftIO) +import Control.Monad.Logger (MonadLoggerIO) +import Data.Foldable (Foldable (fold)) +import Data.Functor ((<&>)) +import qualified Data.HashMap.Strict as H +import Data.IP (IP) +import Data.Maybe (fromMaybe) +import Data.Monoid (Last (Last, getLast)) +import Data.Pool (Pool) +import Data.String (IsString (fromString)) +import Data.Text (Text) +import Database.MySQL.Base (ConnectInfo (..)) +import qualified Database.MySQL.Base as MySQL +import qualified Database.Persist.MySQL as Orig +import Database.Persist.Sql +import qualified OpenTelemetry.Instrumentation.Persistent as Otel +import OpenTelemetry.SemanticsConfig +import qualified OpenTelemetry.Trace.Core as Otel +import Text.Read (readMaybe) + + +{- | Create a MySQL connection pool. Note that it's your +responsibility to properly close the connection pool when +unneeded. Use 'withMySQLPool' for automatic resource control. +-} +createMySQLPool + :: (MonadUnliftIO m, MonadLoggerIO m) + => Otel.TracerProvider + -> H.HashMap Text Otel.Attribute + -- ^ Additional attributes. + -> MySQL.ConnectInfo + -- ^ Connection information. + -> Int + -- ^ Number of connections to be kept open in the pool. + -> m (Pool SqlBackend) +createMySQLPool tp attrs ci = createSqlPool $ fmap snd . openMySQLConn tp attrs ci + + +{- | Create a MySQL connection pool and run the given action. +The pool is properly released after the action finishes using +it. Note that you should not use the given 'ConnectionPool' +outside the action since it may be already been released. +-} +withMySQLPool + :: (MonadLoggerIO m, MonadUnliftIO m) + => Otel.TracerProvider + -> H.HashMap Text Otel.Attribute + -- ^ Additional attributes. + -> MySQL.ConnectInfo + -- ^ Connection information. + -> Int + -- ^ Number of connections to be kept open in the pool. + -> (Pool SqlBackend -> m a) + -- ^ Action to be executed that uses the connection pool. + -> m a +withMySQLPool tp attrs ci = withSqlPool $ fmap snd . openMySQLConn tp attrs ci + + +{- | Open a connection to MySQL server, initialize the 'SqlBackend' and return +their tuple + +About attributes, see https://opentelemetry.io/docs/reference/specification/trace/semantic_conventions/database/. +-} +openMySQLConn + :: Otel.TracerProvider + -> H.HashMap Text Otel.Attribute + -- ^ Additional attributes. + -> MySQL.ConnectInfo + -- ^ Connection information. + -> LogFunc + -> IO (MySQL.Connection, SqlBackend) +openMySQLConn tp attrs ci@MySQL.ConnectInfo {connectUser, connectPort, connectOptions, connectHost} logFunc = do + let + portAttr, transportAttr :: Otel.Attribute + portAttr = fromString $ show connectPort + transportAttr = + fromMaybe "ip_tcp" $ + getLast $ + fold $ + connectOptions <&> \case + MySQL.Protocol p -> + Last $ Just $ case p of + MySQL.TCP -> "ip_tcp" + MySQL.Socket -> "other" + MySQL.Pipe -> "pipe" + MySQL.Memory -> "inproc" + _ -> Last Nothing + addStableAttributes = + H.union + [ ("db.connection_string" :: Text, fromString $ showsPrecConnectInfoMasked 0 ci "") + , ("db.user", fromString connectUser) + , ("server.port", portAttr) + , ("network.peer.port", portAttr) + , ("net.transport", transportAttr) + , (maybe "server.address" (const "network.peer.address") (readMaybe connectHost :: Maybe IP), fromString connectHost) + ] + addOldAttributes = + -- "net.sock.family" is unnecessary because it must be "inet" when "net.sock.peer.addr" or "net.sock.host.addr" is set. + H.union + [ ("db.connection_string" :: Text, fromString $ showsPrecConnectInfoMasked 0 ci "") + , ("db.user", fromString connectUser) + , ("net.peer.port", portAttr) + , ("net.sock.peer.port", portAttr) + , ("net.transport", transportAttr) + , (maybe "net.peer.name" (const "net.sock.peer.addr") (readMaybe connectHost :: Maybe IP), fromString connectHost) + ] + + semanticsOptions <- getSemanticsOptions + let attrs' = + case httpOption semanticsOptions of + Stable -> addStableAttributes attrs + StableAndOld -> addStableAttributes $ addOldAttributes attrs + Old -> addOldAttributes attrs + (conn, backend) <- Orig.openMySQLConn ci logFunc + backend' <- Otel.wrapSqlBackend' tp attrs' backend + pure (conn, backend') + + +{- | Same as 'withMySQLPool', but instead of opening a pool +of connections, only one connection is opened. +-} +withMySQLConn + :: (MonadUnliftIO m, MonadLoggerIO m) + => Otel.TracerProvider + -> H.HashMap Text Otel.Attribute + -- ^ Additional attributes. + -> MySQL.ConnectInfo + -- ^ Connection information. + -> (SqlBackend -> m a) + -- ^ Action to be executed that uses the connection. + -> m a +withMySQLConn tp attrs ci = withSqlConn $ fmap snd . openMySQLConn tp attrs ci + + +showsPrecConnectInfoMasked :: Int -> MySQL.ConnectInfo -> ShowS +showsPrecConnectInfoMasked d MySQL.ConnectInfo {connectHost, connectPort, connectUser, connectDatabase, connectOptions, connectPath, connectSSL} = + showParen (d > 10) $ + showString "ConnectInfo {" + . showString "connectHost = " + . shows connectHost + . showString ", " + . showString "connectPort = " + . shows connectPort + . showString ", " + . showString "connectUser = " + . shows connectUser + . showString ", " + . showString "connectPassword = \"****\", " + . showString "connectDatabase = " + . shows connectDatabase + . showString ", " + . showString "connectOptions = " + . shows connectOptions + . showString ", " + . showString "connectPath = " + . shows connectPath + . showString ", " + . showString "connectSSL = " + . shows connectSSL + . showString "}"