複数のブランチを更新しつづけるのはメンテナンスが大変なのでフラグで分けるようにした

本家に PR するときはこれを除外しないといけない
本家から pull するときは衝突が発生するだろう

cabal.project

@@ -47,6 +47,19 @@ source-repository-package
     subdir: . core
     -- HEAD of master at 2023-06-09
 
+-- proto3-suite-no-prefix でのみ必要
+source-repository-package
+    type: git
+    location: https://github.com/ccycle/proto3-suite.git
+    tag: 9197b195442600578a919ccce8efd6d4a51d2dd9
+
+-- proto3-suite-no-prefix でのみ必要
+source-repository-package
+    type: git
+    location: https://github.com/awakesecurity/proto3-wire.git
+    tag: ee6ca644eef86cc5f31da85fb48e10b20ab0e1a1
+    -- HEAD of master at 2023-08-10
+
 source-repository-package
     type: git
     location: https://github.com/ryantm/hdbc-mysql
@@ -67,3 +80,5 @@ allow-newer:
 
 constraints:
     postgresql-simple == 0.6.4
+  -- ↓ proto3-suite-no-prefix でのみ必要
+  , any.proto3-suite -large-records

examples/grpc-echo/Setup.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
 import Data.Char (isDigit)
 import Data.Foldable (for_)
 import Data.List (intercalate, intersperse, isPrefixOf, replicate, stripPrefix)
@@ -20,14 +22,32 @@ import System.IO (
  )
 
 
+#if PROTO3_SUITE_NO_PREFIX
+import Proto3.Suite.DotProto.Generate (IsPrefixed (IsPrefixed), RecordStyle (RegularRecords), StringType (StringType))
+#endif
+
+
 main :: IO ()
 main =
   defaultMainWithHooks
     simpleUserHooks
       { preBuild = compileProto
       }
 
-
+#if !PROTO3_SUITE_NO_PREFIX
+compileProto :: Args -> BuildFlags -> IO HookedBuildInfo
+compileProto _ _ = do
+  let
+    compileArgs =
+      CompileArgs
+        { includeDir = []
+        , extraInstanceFiles = []
+        , inputProto = "echo.proto"
+        , outputDir = "gen"
+        }
+  compileDotProtoFileOrDie compileArgs
+  pure emptyHookedBuildInfo
+#else
 compileProto :: Args -> BuildFlags -> IO HookedBuildInfo
 compileProto _ _ = do
   let
@@ -37,6 +57,10 @@ compileProto _ _ = do
         , extraInstanceFiles = []
         , inputProto = "echo.proto"
         , outputDir = "gen"
+        , stringType = StringType "Data.Text.Lazy" "Text"
+        , recordStyle = RegularRecords
+        , isPrefixed = IsPrefixed True
         }
   compileDotProtoFileOrDie compileArgs
   pure emptyHookedBuildInfo
+#endif

instrumentation/grpc-haskell/hs-opentelemetry-instrumentation-grpc-haskell.cabal

@@ -17,6 +17,11 @@ tested-with: GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.5
 extra-source-files: README.md,
                     CHANGELOG.md
 
+flag proto3-suite-no-prefix
+  description: proto3-suite のプレフィックスなしのバージョンを使っている場合にそれに対応する
+  default: False
+  manual: True
+
 common common
   build-depends: base >= 4 && < 5
   ghc-options: -Wall
@@ -78,3 +83,6 @@ library
                  grpc-haskell-core,
                  http-types,
                  text
+  if flag(proto3-suite-no-prefix)
+    ghc-options: -DPROTO3_SUITE_NO_PREFIX
+    build-depends: proto3-suite

instrumentation/grpc-haskell/src/OpenTelemetry/Instrumentation/GRPC.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
@@ -10,21 +11,34 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 
+
+#if !PROTO3_SUITE_NO_PREFIX
+module OpenTelemetry.Instrumentation.GRPC (
+  propagatableTraceableServer,
+  propagatableTraceableClient,
+  Propagatable (..),
+  Traceable (..),
+  convertToGrpcPropagator,
+) where
+#else
 module OpenTelemetry.Instrumentation.GRPC (
   propagatableTraceableServer,
   propagatableTraceableClient,
   Propagatable (..),
   Traceable (..),
   convertToGrpcPropagator,
+  GTraceable (..),
+  GTraceableSelectors (..),
+  GPropagatable (..),
 ) where
+#endif
 
 import Control.Exception (assert, bracket)
 import Control.Monad (void)
 import Data.Bifunctor (first)
 import Data.ByteString (ByteString)
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
-import Data.Char (toLower)
 import qualified Data.Text as Text
 import Data.Version (showVersion)
 import GHC.Exts (IsList (fromList, toList))
@@ -41,6 +55,13 @@ import qualified OpenTelemetry.Trace.Core as Otel
 import qualified Paths_hs_opentelemetry_instrumentation_grpc_haskell
 
 
+#if PROTO3_SUITE_NO_PREFIX
+import qualified Proto3.Suite.DotProto.Generate as Proto3
+#else
+import Data.Char (toLower)
+#endif
+
+
 propagatableTraceableServer :: (Traceable service, Propagatable service, HasCallStack) => Otel.TracerProvider -> service -> service
 propagatableTraceableServer provider = withFrozenCallStack $ propagatableService tracer . traceableService tracer Otel.defaultSpanArguments {Otel.kind = Otel.Server} where tracer = makeTracer provider
 
@@ -52,6 +73,7 @@ propagatableTraceableClient provider = withFrozenCallStack $ traceableService tr
 makeTracer :: Otel.TracerProvider -> Otel.Tracer
 makeTracer provider = Otel.makeTracer provider (Otel.InstrumentationLibrary "hs-opentelemetry-instrumentation-grpc-haskell" $ Text.pack $ showVersion Paths_hs_opentelemetry_instrumentation_grpc_haskell.version) (Otel.TracerOptions Nothing)
 
+#if !PROTO3_SUITE_NO_PREFIX
 
 class Traceable service where
   -- | Wrap each rpc with 'Otel.inSpan'.
@@ -102,6 +124,54 @@ instance (GTraceableSelectors f, GTraceableSelectors g) => GTraceableSelectors (
         rep2' = gTraceableSelectors tracer serviceName args rep2
      in rep1' G.:*: rep2'
 
+#else
+
+class Traceable service where
+  -- | Wrap each rpc with 'Otel.inSpan'.
+  --
+  -- For example if you have a service like:
+  --
+  -- @
+  -- data Service = Service { rpc1 :: Request -> 'IO' Responce } deriving Generic
+  -- instance 'Traceable' Service
+  -- @
+  --
+  -- then 'traceableService' is equivalent to:
+  --
+  -- @
+  -- 'traceableService' tracer Service { rpc1 } = Service { rpc1 = 'inSpan' tracer "Service.rpc1" rpc1 }
+  -- @
+  traceableService :: HasCallStack => Otel.Tracer -> Otel.SpanArguments -> service -> service
+  default traceableService :: (G.Generic service, GTraceable (G.Rep service), HasCallStack) => Otel.Tracer -> Otel.SpanArguments -> service -> service
+  traceableService tracer args = withFrozenCallStack $ G.to . gTraceableService (Proto3.IsPrefixed True) tracer args . G.from
+
+class GTraceable rep where
+  gTraceableService :: HasCallStack => Proto3.IsPrefixed -> Otel.Tracer -> Otel.SpanArguments -> rep a -> rep a
+
+class GTraceableSelectors rep where
+  gTraceableSelectors :: HasCallStack => Proto3.IsPrefixed -> Otel.Tracer -> String -> Otel.SpanArguments -> rep a -> rep a
+
+instance (GTraceableSelectors f, G.Datatype dc, G.Constructor cc) => GTraceable (G.M1 G.D dc (G.M1 G.C cc f)) where
+  gTraceableService prefixed tracer args datatypeRep@(G.M1 conRep@(G.M1 selsRep)) =
+    assert (G.datatypeName datatypeRep == G.conName conRep) $
+      G.M1 $
+        G.M1 $
+          gTraceableSelectors prefixed tracer (G.datatypeName datatypeRep) args selsRep
+
+instance (G.Selector c) => GTraceableSelectors (G.M1 G.S c (G.K1 G.R (request -> IO response))) where
+  gTraceableSelectors (Proto3.IsPrefixed prefixed) tracer serviceName args rep@(G.M1 (G.K1 rpc)) =
+    let spanName = Text.pack serviceName <> "." <> Text.pack ((if prefixed then drop $ length serviceName else id) $ G.selName rep)
+     in G.M1 $ G.K1 $ Otel.inSpan tracer spanName args . rpc
+
+
+instance (GTraceableSelectors f, GTraceableSelectors g) => GTraceableSelectors (f G.:*: g) where
+  gTraceableSelectors prefixed tracer serviceName args (rep1 G.:*: rep2) =
+    let rep1' = gTraceableSelectors prefixed tracer serviceName args rep1
+        rep2' = gTraceableSelectors prefixed tracer serviceName args rep2
+     in rep1' G.:*: rep2'
+
+#endif
+
 
 {- | Convert a propagator for http-types headers to one for grpc-haskell headers.
 

instrumentation/hdbc/src/OpenTelemetry/Instrumentation/HDBC.hs

@@ -16,7 +16,6 @@ import Data.Function ((&))
 import Data.Kind (Type)
 import Data.Text (Text)
 import qualified Data.Text as Text
-import qualified Database.HDBC as HDBC
 import Database.HDBC (
   ConnWrapper (ConnWrapper),
   IConnection (
@@ -36,6 +35,7 @@ import Database.HDBC (
     run
   ),
  )
+import qualified Database.HDBC as HDBC
 import GHC.Generics (Generic)
 import GHC.Stack (withFrozenCallStack)
 import qualified OpenTelemetry.Attributes as Attr