Otel for HDBC and HDBC MySQL

cabal.project

@@ -12,6 +12,8 @@ packages:
   , instrumentation/cloudflare
   , instrumentation/conduit
   , instrumentation/grpc-haskell
+  , instrumentation/hdbc
+  , instrumentation/hdbc-mysql
   , instrumentation/hedis
   , instrumentation/herp-logger-datadog
   , instrumentation/hspec
@@ -22,6 +24,7 @@ packages:
   , instrumentation/wai
   , instrumentation/yesod
   , examples/grpc-echo
+  , examples/hdbc-mysql
   , examples/http-server
   , examples/yesod-minimal
   , examples/yesod-subsite
@@ -41,6 +44,12 @@ source-repository-package
     subdir: . core
     -- HEAD of master at 2023-06-09
 
+source-repository-package
+    type: git
+    location: https://github.com/ryantm/hdbc-mysql
+    tag: 80f8077b29ee27bce4141b385a8b28f42cbbbe46
+    -- master at 2023-12-19
+
 source-repository-package
     type: git
     location: https://github.com/herp-inc/herp-logger

docker-compose.yaml

@@ -16,3 +16,11 @@ services:
       - POSTGRES_PASSWORD=password
     ports:
       - "5432:5432"
+
+  mysql:
+    image: mysql
+    environment:
+      - MYSQL_ALLOW_EMPTY_PASSWORD=yes
+      - MYSQL_DATABASE=test
+    ports:
+      - "3306:3306"

examples/hdbc-mysql/hdbc-mysql-example.cabal

@@ -0,0 +1,65 @@
+cabal-version: 2.4
+
+name: hdbc-mysql-example
+version: 0.0.0.0
+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
+
+executable hdbc-mysql-example
+  import: common
+  hs-source-dirs: .
+  main-is: main.hs
+  build-depends: hs-opentelemetry-sdk,
+                 hs-opentelemetry-instrumentation-HDBC-mysql,
+                 HDBC,
+  ghc-options: -threaded
+               -with-rtsopts=-N
+               -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: -Wambiguous-fields
+                 -Wmissing-kind-signatures
+                 -Woperator-whitespace
+                 -Wredundant-bang-patterns
+  if impl(ghc >= 9.4)
+    ghc-options: -Wredundant-strictness-flags
+                 -Wforall-identifier
+                 -Woperator-whitespace-ext-conflict
+  if impl(ghc >= 9.4.1)
+    ghc-options: -Wgadt-mono-local-binds
+                 -Wtype-equality-out-of-scope
+                 -Wtype-equality-requires-operators
+  if impl(ghc >= 9.6.1)
+    -- ghc-options: -Wloopy-superclass-solve
+    -- Bug: https://gitlab.haskell.org/ghc/ghc/-/issues/24071
+  if impl(ghc >= 9.8.1)
+    ghc-options: -Wincomplete-export-warnings

examples/hdbc-mysql/main.hs

@@ -0,0 +1,37 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+import Control.Exception (bracket)
+import Control.Monad (void)
+import Database.HDBC (commit, disconnect, run)
+import OpenTelemetry.Instrumentation.HDBC.MySQL (connectMySQL, defaultMySQLConnectInfo)
+import OpenTelemetry.Trace (
+  defaultSpanArguments,
+  inSpan,
+  initializeTracerProvider,
+  makeTracer,
+  shutdownTracerProvider,
+  tracerOptions,
+ )
+import System.IO (hFlush, stdout)
+
+
+main :: IO ()
+main = do
+  bracket
+    initializeTracerProvider
+    shutdownTracerProvider
+    $ \tracerProvider -> do
+      bracket
+        (connectMySQL tracerProvider mempty defaultMySQLConnectInfo)
+        disconnect
+        $ \connection -> do
+          let tracer = makeTracer tracerProvider "hdbc-mysql-example" tracerOptions
+          inSpan tracer "create" defaultSpanArguments $ do
+            void $ run connection "CREATE TABLE test (id INTEGER PRIMARY KEY)" []
+            commit connection
+          inSpan tracer "drop" defaultSpanArguments $ do
+            void $ run connection "DROP TABLE test" []
+            commit connection
+          putStr "Press enter to exit after while..."
+          hFlush stdout
+          void $ getLine -- wait for transporting spans

hie.yaml

@@ -35,6 +35,9 @@ cradle:
             - path: "examples/grpc-echo/gen"
               component: "lib:grpc-echo-example"
 
+            - path: "examples/hdbc-mysql/main.hs"
+              component: "hdbc-mysql-example:exe:hdbc-mysql-example"
+
             - path: "examples/yesod-minimal/src"
               component: "lib:yesod-minimal"
 
@@ -86,6 +89,12 @@ cradle:
             - path: "instrumentation/grpc-haskell/src"
               component: "lib:hs-opentelemetry-instrumentation-grpc-haskell"
 
+            - path: "instrumentation/hdbc/src"
+              component: "lib:hs-opentelemetry-instrumentation-HDBC"
+
+            - path: "instrumentation/hdbc-mysql/src"
+              component: "lib:hs-opentelemetry-instrumentation-HDBC-MySQL"
+
             - path: "instrumentation/hedis/src"
               component: "lib:hs-opentelemetry-instrumentation-hedis"
 

instrumentation/hdbc-mysql/hs-opentelemetry-instrumentation-HDBC-mysql.cabal

@@ -0,0 +1,64 @@
+cabal-version: 2.4
+
+name: hs-opentelemetry-instrumentation-HDBC-mysql
+version: 0.0.0.0
+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.HDBC.MySQL
+  build-depends: hs-opentelemetry-api,
+                 hs-opentelemetry-instrumentation-HDBC,
+                 HDBC-mysql,
+                 text,
+  ghc-options: -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: -Wambiguous-fields
+                 -Wmissing-kind-signatures
+                 -Woperator-whitespace
+                 -Wredundant-bang-patterns
+  if impl(ghc >= 9.4)
+    ghc-options: -Wredundant-strictness-flags
+                 -Wforall-identifier
+                 -Woperator-whitespace-ext-conflict
+  if impl(ghc >= 9.4.1)
+    ghc-options: -Wgadt-mono-local-binds
+                 -Wtype-equality-out-of-scope
+                 -Wtype-equality-requires-operators
+  if impl(ghc >= 9.6.1)
+    -- ghc-options: -Wloopy-superclass-solve
+    -- Bug: https://gitlab.haskell.org/ghc/ghc/-/issues/24071
+  if impl(ghc >= 9.8.1)
+    ghc-options: -Wincomplete-export-warnings

instrumentation/hdbc-mysql/src/OpenTelemetry/Instrumentation/HDBC/MySQL.hs

@@ -0,0 +1,52 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module OpenTelemetry.Instrumentation.HDBC.MySQL (
+  Orig.MySQLConnectInfo (..),
+  Otel.Connection,
+  connectMySQL,
+  Orig.defaultMySQLConnectInfo,
+  Orig.withRTSSignalsBlocked,
+) where
+
+import qualified Data.Text as Text
+import qualified Database.HDBC.MySQL as Orig
+import qualified OpenTelemetry.Attribute as Attr
+import qualified OpenTelemetry.Attribute.Attributes as Attr
+import qualified OpenTelemetry.Attribute.Key as Attr
+import qualified OpenTelemetry.Instrumentation.HDBC as Otel
+import qualified OpenTelemetry.Trace.Core as Otel
+
+
+connectMySQL :: Otel.TracerProvider -> Attr.Attributes -> Orig.MySQLConnectInfo -> IO Otel.Connection
+connectMySQL
+  tracerProvider
+  extraAttributes
+  connectInfo@Orig.MySQLConnectInfo
+    { Orig.mysqlHost
+    , Orig.mysqlUser
+    , Orig.mysqlDatabase
+    , Orig.mysqlPort
+    , Orig.mysqlUnixSocket
+    } = do
+    connection <- Orig.connectMySQL connectInfo
+    let port :: Maybe Word
+        transport :: Text.Text
+        (port, transport) =
+          if null mysqlUnixSocket
+            then (Just $ fromIntegral mysqlPort, "tcp")
+            else (Nothing, "unix")
+        attributes =
+          Otel.Attributes
+            { Otel.db_connectionString = Nothing
+            , Otel.db_system = "mysql"
+            , Otel.db_user = Just $ Text.pack mysqlUser
+            , Otel.network_peer_address = Just $ Text.pack mysqlHost
+            , Otel.network_peer_port = port
+            , Otel.network_transport = Just transport
+            , Otel.network_type = Nothing
+            , Otel.server_address = Just $ Text.pack mysqlHost
+            , Otel.server_port = port
+            }
+        extraAttributes' = Attr.insert Attr.db_name (Text.pack mysqlDatabase) extraAttributes
+    pure $ Otel.makeConnection connection tracerProvider attributes extraAttributes'

instrumentation/hdbc/hs-opentelemetry-instrumentation-HDBC.cabal

@@ -0,0 +1,64 @@
+cabal-version: 2.4
+
+name: hs-opentelemetry-instrumentation-HDBC
+version: 0.0.0.0
+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.HDBC
+  build-depends: hs-opentelemetry-api,
+                 HDBC,
+                 data-default-class,
+                 text
+  ghc-options: -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: -Wambiguous-fields
+                 -Wmissing-kind-signatures
+                 -Woperator-whitespace
+                 -Wredundant-bang-patterns
+  if impl(ghc >= 9.4)
+    ghc-options: -Wredundant-strictness-flags
+                 -Wforall-identifier
+                 -Woperator-whitespace-ext-conflict
+  if impl(ghc >= 9.4.1)
+    ghc-options: -Wgadt-mono-local-binds
+                 -Wtype-equality-out-of-scope
+                 -Wtype-equality-requires-operators
+  if impl(ghc >= 9.6.1)
+    -- ghc-options: -Wloopy-superclass-solve
+    -- Bug: https://gitlab.haskell.org/ghc/ghc/-/issues/24071
+  if impl(ghc >= 9.8.1)
+    ghc-options: -Wincomplete-export-warnings