From 36f4b3554d83a834141ed09fcd6aa1ce28df5441 Mon Sep 17 00:00:00 2001 From: Kazuki Okamoto Date: Thu, 18 Jan 2024 16:29:37 +0900 Subject: [PATCH] =?UTF-8?q?=E8=A4=87=E6=95=B0=E3=81=AE=E3=83=96=E3=83=A9?= =?UTF-8?q?=E3=83=B3=E3=83=81=E3=82=92=E6=9B=B4=E6=96=B0=E3=81=97=E3=81=A4?= =?UTF-8?q?=E3=81=A5=E3=81=91=E3=82=8B=E3=81=AE=E3=81=AF=E3=83=A1=E3=83=B3?= =?UTF-8?q?=E3=83=86=E3=83=8A=E3=83=B3=E3=82=B9=E3=81=8C=E5=A4=A7=E5=A4=89?= =?UTF-8?q?=E3=81=AA=E3=81=AE=E3=81=A7=E3=83=95=E3=83=A9=E3=82=B0=E3=81=A7?= =?UTF-8?q?=E5=88=86=E3=81=91=E3=82=8B=E3=82=88=E3=81=86=E3=81=AB=E3=81=97?= =?UTF-8?q?=E3=81=9F?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 本家に PR するときはこれを除外しないといけない 本家から pull するときは衝突が発生するだろう --- cabal.project | 15 ++++ examples/grpc-echo/Setup.hs | 26 ++++++- ...lemetry-instrumentation-grpc-haskell.cabal | 8 +++ .../src/OpenTelemetry/Instrumentation/GRPC.hs | 72 ++++++++++++++++++- .../src/OpenTelemetry/Instrumentation/HDBC.hs | 2 +- 5 files changed, 120 insertions(+), 3 deletions(-) diff --git a/cabal.project b/cabal.project index 7a34e224..5a086b24 100644 --- a/cabal.project +++ b/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 diff --git a/examples/grpc-echo/Setup.hs b/examples/grpc-echo/Setup.hs index 124a90c7..f0bc2f07 100644 --- a/examples/grpc-echo/Setup.hs +++ b/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,6 +22,11 @@ import System.IO ( ) +#if PROTO3_SUITE_NO_PREFIX +import Proto3.Suite.DotProto.Generate (IsPrefixed (IsPrefixed), RecordStyle (RegularRecords), StringType (StringType)) +#endif + + main :: IO () main = defaultMainWithHooks @@ -27,7 +34,20 @@ main = { 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 diff --git a/instrumentation/grpc-haskell/hs-opentelemetry-instrumentation-grpc-haskell.cabal b/instrumentation/grpc-haskell/hs-opentelemetry-instrumentation-grpc-haskell.cabal index 8269d101..a9974ebd 100644 --- a/instrumentation/grpc-haskell/hs-opentelemetry-instrumentation-grpc-haskell.cabal +++ b/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 diff --git a/instrumentation/grpc-haskell/src/OpenTelemetry/Instrumentation/GRPC.hs b/instrumentation/grpc-haskell/src/OpenTelemetry/Instrumentation/GRPC.hs index c0a7d3a8..803ce104 100644 --- a/instrumentation/grpc-haskell/src/OpenTelemetry/Instrumentation/GRPC.hs +++ b/instrumentation/grpc-haskell/src/OpenTelemetry/Instrumentation/GRPC.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} @@ -10,13 +11,27 @@ {-# 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) @@ -24,7 +39,6 @@ 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. diff --git a/instrumentation/hdbc/src/OpenTelemetry/Instrumentation/HDBC.hs b/instrumentation/hdbc/src/OpenTelemetry/Instrumentation/HDBC.hs index 2e93cabe..8234ee59 100644 --- a/instrumentation/hdbc/src/OpenTelemetry/Instrumentation/HDBC.hs +++ b/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