diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,91 @@ This package follows the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## 0.3.1.0 — 2026-09-15 + +### Fixed + +- `pollMessage` no longer throws on partition-scoped conditions that a healthy + consumer meets in normal operation. `RdKafkaRespErrPartitionEof`, + `RdKafkaRespErrAutoOffsetReset` and `RdKafkaRespErrUnknownTopicOrPart` now + return `Nothing` alongside the timeout. Previously any of them killed the + consumer, and because the interpreter's bracket closes the consumer on the + way out, a supervised service would restart, re-subscribe, meet the same + persistent partition condition, and crash-loop. Partition EOF in particular + is delivered on every catch-up when `enable.partition.eof` is set, so the old + behaviour killed consumers precisely when they had succeeded. The batch + variant `pollMessageBatch` already kept these in-band; the two are now + consistent. + +- The three commit operations (`commitOffsetMessage`, `commitAllOffsets`, + `commitPartitionsOffsets`) treat `RdKafkaRespErrNoOffset` as success. + hw-kafka-client's own offset-commit callback documentation states that this + code "is not to be considered an error" — it simply means nothing had + advanced. Previously an idle consumer could die on a shutdown commit. + +- The traced interpreter no longer leaks one record's trace context into the + next. `withConsumerSpan` extracted each record's context into the *current* + thread-local context and never detached what it attached, so a record with no + `traceparent` was parented to the previous record's remote trace — directly + contradicting this module's documented "new root span when no inbound context + is present" — and the leak persisted across batch entries and after the poll + returned. Extraction now starts from an empty context and the attach is + paired with its detach in a bracket, giving per-record isolation and + restoring the caller's ambient context. + +- Kafka headers are decoded leniently, so a header carrying non-UTF-8 bytes no + longer costs a record its inbound trace context. Previously the partial + decode raised inside carrier construction, the propagator's catch-all + swallowed it, and the record lost its `traceparent` while logging a + `Propagator extract failed` warning on every message. Extraction now also + filters headers to the propagator's own declared fields, so application + payload headers never reach the decoder at all. + +### Documentation + +- Corrected the `produceMessageBatch` docs. The 0.2.0.0 entry below says the + interpreter inlines "the upstream definition" because Hackage 5.3.0 "does not + re-export" it. Both halves are wrong: upstream *deleted* the function in + October 2021, before v5.3.0, and it is absent from upstream `main` too — the + copy that suggested otherwise was a local addition in our corpus checkout. + More usefully, the function does not batch: it loops calling + `produceMessage`, so it saves no network round-trips. Throughput comes from + `linger.ms` / `batch.size`, which apply to every produce call. Now tracked as + upstream issue `hw-kafka-client-no-produce-batch-binding` in + `mori/upstream-issues.dhall`. + +### Added + +- `Kafka.Effectful.Consumer.Classify`, a new exposed module holding the in-band + error policy as pure, testable functions: `PollErrorDisposition`, + `classifyPollError` and `isBenignCommitError`. Both interpreters route + through it, so their taxonomies cannot drift apart. + +- `pollMessageEither`, which returns every in-band condition as a `Left` + instead of swallowing or throwing it. Use it for bounded reads that must + observe partition EOF. Additive; `pollMessage` is unchanged in type. + +- The first tests for the consumer interpreters, covering the classifier + taxonomy, brokerless interpreter behaviour, and trace-context hygiene. + +### Other Changes + +- Detecting a fatal consumer error in `CallbackPollModeAsync` requires a + patched `hw-kafka-client`. Hackage 5.3.0 drops consumer-queue messages in + `pollConsumerEvents'`, and librdkafka delivers a raised fatal error to the + high-level consumer only on that queue — never through `error_cb` — so in the + default async mode a fatal such as a fenced static group member is + unobservable at every layer and the application polls forever. This + repository pins a fork that reports it in-band from `pollMessage` / + `pollMessageBatch`, which is what lets `Kafka.Effectful.Consumer.Classify` + see the fatal and throw. The pin governs builds of this repository only: a + downstream package does not inherit it and must add the same + `source-repository-package` stanza to its own `cabal.project`, or it silently + keeps async-mode fatal blindness. Sync-mode consumers are unaffected. + +- Support `effectful-core` 2.7 (upper bound raised from `<2.7` to `<2.8`). + Built and tested against 2.7.1.2; no source changes were needed. + ## 0.3.0.0 — 2026-05-31 ### Breaking Changes diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -105,11 +105,17 @@ ##### Scenario 4 — High-throughput batching -Combine `produceMessageBatch` with `linger.ms`, `batch.size`, and -`compression` to trade a few milliseconds of latency for substantially -higher throughput. The result contains only records that failed to -enqueue. +Set `linger.ms`, `batch.size`, and `compression` to trade a few +milliseconds of latency for substantially higher throughput. That is where +the batching happens: librdkafka coalesces its own send queue, for every +produce call. +`produceMessageBatch` is a convenience over that, not a second lever — it +loops calling `produceMessage` per record and returns only the records that +failed to enqueue. Using it does not reduce network round-trips; `hw-kafka-client` +exposes no API-level batch send (tracked as upstream issue +`hw-kafka-client-no-produce-batch-binding`, see `mori upstream-issues show`). + ```haskell batchProps = brokersList ["localhost:9092"] @@ -226,8 +232,16 @@ loop ``` -`pollMessage` returns `Nothing` when the timeout elapses without a message -arriving; non-timeout failures are thrown via the `Error KafkaError` effect. +`pollMessage` returns `Nothing` when nothing was delivered. That covers the +timeout, and also three partition-scoped conditions that librdkafka reports as +errors but which a healthy consumer meets in normal operation: partition EOF, +an offset reset, and an as-yet-unknown topic or partition. Everything else -- +transport failures, authentication failures, and fatal errors among them -- is +thrown via the `Error KafkaError` effect. + +Use `pollMessageEither` when you need to see those conditions rather than have +them swallowed, for example to detect partition EOF in a bounded read. The full +policy, and the reasoning for each code, is in `Kafka.Effectful.Consumer.Classify`. ### Running it diff --git a/examples/OtelTracing.hs b/examples/OtelTracing.hs --- a/examples/OtelTracing.hs +++ b/examples/OtelTracing.hs @@ -1,38 +1,37 @@ -{- | End-to-end OpenTelemetry tracing demo. - -This program produces a single record through 'runKafkaProducerTraced' -and then consumes it through 'runKafkaConsumerTraced'. It captures the -producer-side trace ID (from an outer parent span we open so its trace -ID propagates to the produce span the interpreter opens) and the -consumer-side trace ID (from the inbound parent span the consumer -interpreter attaches to the thread context after extracting the W3C -@traceparent@ header), then compares the two. A successful run prints -two equal trace IDs and exits zero. A mismatch (or any kafka error) -exits non-zero. - -Manual run procedure: - -@ - cabal run example-otel-tracing -f examples -- \\ - --bootstrap-servers localhost:9092 \\ - --topic otel-demo -@ - -Expected output (trace IDs are 32-hex-char strings, regenerated each -run): - -@ - [otel-tracing] producer trace id: 4bf92f3577b34da6a3ce929d0e0e4736 - [otel-tracing] consumer trace id: 4bf92f3577b34da6a3ce929d0e0e4736 - [otel-tracing] trace IDs match — context propagated through Kafka headers -@ - -If a Jaeger v2 instance is reachable at @http:\/\/localhost:4318@ -(the default OTLP HTTP endpoint), the same trace appears with a -producer span as the parent and a child consumer span. Otherwise the -flow still works locally and the OTLP exporter silently drops the -spans. --} +-- | End-to-end OpenTelemetry tracing demo. +-- +-- This program produces a single record through 'runKafkaProducerTraced' +-- and then consumes it through 'runKafkaConsumerTraced'. It captures the +-- producer-side trace ID (from an outer parent span we open so its trace +-- ID propagates to the produce span the interpreter opens) and the +-- consumer-side trace ID (from the inbound parent span the consumer +-- interpreter attaches to the thread context after extracting the W3C +-- @traceparent@ header), then compares the two. A successful run prints +-- two equal trace IDs and exits zero. A mismatch (or any kafka error) +-- exits non-zero. +-- +-- Manual run procedure: +-- +-- @ +-- cabal run example-otel-tracing -f examples -- \\ +-- --bootstrap-servers localhost:9092 \\ +-- --topic otel-demo +-- @ +-- +-- Expected output (trace IDs are 32-hex-char strings, regenerated each +-- run): +-- +-- @ +-- [otel-tracing] producer trace id: 4bf92f3577b34da6a3ce929d0e0e4736 +-- [otel-tracing] consumer trace id: 4bf92f3577b34da6a3ce929d0e0e4736 +-- [otel-tracing] trace IDs match — context propagated through Kafka headers +-- @ +-- +-- If a Jaeger v2 instance is reachable at @http:\/\/localhost:4318@ +-- (the default OTLP HTTP endpoint), the same trace appears with a +-- producer span as the parent and a child consumer span. Otherwise the +-- flow still works locally and the OTLP exporter silently drops the +-- spans. module Main (main) where import Data.IORef (IORef, newIORef, readIORef, writeIORef) @@ -43,28 +42,28 @@ import Effectful.Error.Static (runError) import Kafka.Effectful import Kafka.Effectful.Consumer qualified as KEC -import Kafka.Effectful.OpenTelemetry ( - runKafkaConsumerTraced, +import Kafka.Effectful.OpenTelemetry + ( runKafkaConsumerTraced, runKafkaProducerTraced, - ) + ) import Kafka.Effectful.Producer qualified as KEP import OpenTelemetry.Attributes (emptyAttributes) import OpenTelemetry.Context qualified as Context import OpenTelemetry.Context.ThreadLocal (getContext) -import OpenTelemetry.Trace ( - initializeGlobalTracerProvider, +import OpenTelemetry.Trace + ( initializeGlobalTracerProvider, makeTracer, shutdownTracerProvider, tracerOptions, - ) -import OpenTelemetry.Trace.Core ( - InstrumentationLibrary (..), + ) +import OpenTelemetry.Trace.Core + ( InstrumentationLibrary (..), SpanContext (traceId), Tracer, defaultSpanArguments, getSpanContext, inSpan'', - ) + ) import OpenTelemetry.Trace.Id (Base (Base16), traceIdBaseEncodedText) import System.Environment (getArgs) import System.Exit (exitFailure, exitSuccess) @@ -73,58 +72,58 @@ -- CLI data Args = Args - { bootstrapServers :: Text - , topic :: Text - } + { bootstrapServers :: Text, + topic :: Text + } parseArgs :: [String] -> Maybe Args parseArgs = go (Args "" "") where go acc [] = - if Text.null acc.bootstrapServers || Text.null acc.topic - then Nothing - else Just acc + if Text.null acc.bootstrapServers || Text.null acc.topic + then Nothing + else Just acc go acc ("--bootstrap-servers" : v : rest) = - go acc{bootstrapServers = Text.pack v} rest - go acc ("--topic" : v : rest) = go acc{topic = Text.pack v} rest + go acc {bootstrapServers = Text.pack v} rest + go acc ("--topic" : v : rest) = go acc {topic = Text.pack v} rest go _ _ = Nothing usage :: String usage = - "usage: example-otel-tracing --bootstrap-servers HOST:PORT --topic NAME" + "usage: example-otel-tracing --bootstrap-servers HOST:PORT --topic NAME" -- Wiring producerProps :: Text -> ProducerProperties producerProps host = - KEP.brokersList [BrokerAddress host] - <> KEP.sendTimeout (Timeout 10000) - <> KEP.extraProp "enable.idempotence" "true" - <> KEP.extraProp "acks" "all" + KEP.brokersList [BrokerAddress host] + <> KEP.sendTimeout (Timeout 10000) + <> KEP.extraProp "enable.idempotence" "true" + <> KEP.extraProp "acks" "all" consumerProps :: Text -> ConsumerProperties consumerProps host = - KEC.brokersList [BrokerAddress host] - <> KEC.groupId (ConsumerGroupId "kafka-effectful-otel-demo") + KEC.brokersList [BrokerAddress host] + <> KEC.groupId (ConsumerGroupId "kafka-effectful-otel-demo") mkRecord :: Text -> ProducerRecord mkRecord t = - ProducerRecord - { prTopic = TopicName t - , prPartition = UnassignedPartition - , prKey = Just "k1" - , prValue = Just "hello otel" - , prHeaders = mempty - } + ProducerRecord + { prTopic = TopicName t, + prPartition = UnassignedPartition, + prKey = Just "k1", + prValue = Just "hello otel", + prHeaders = mempty + } instrumentation :: InstrumentationLibrary instrumentation = - InstrumentationLibrary - { libraryName = "kafka-effectful-example" - , libraryVersion = "0.2.0.0" - , librarySchemaUrl = "" - , libraryAttributes = emptyAttributes - } + InstrumentationLibrary + { libraryName = "kafka-effectful-example", + libraryVersion = "0.2.0.0", + librarySchemaUrl = "", + libraryAttributes = emptyAttributes + } -- Capture the trace ID of whatever span is currently active on the -- thread. Used on both sides: the producer wraps its work in an @@ -133,12 +132,12 @@ -- context after extracting the @traceparent@ header. captureCurrentTraceId :: (IOE :> es) => IORef (Maybe Text) -> Eff es () captureCurrentTraceId ref = Effectful.liftIO $ do - ctx <- getContext - case Context.lookupSpan ctx of - Nothing -> pure () - Just s -> do - sc <- getSpanContext s - writeIORef ref (Just (traceIdBaseEncodedText Base16 (traceId sc))) + ctx <- getContext + case Context.lookupSpan ctx of + Nothing -> pure () + Just s -> do + sc <- getSpanContext s + writeIORef ref (Just (traceIdBaseEncodedText Base16 (traceId sc))) -- Poll up to 30 one-second timeouts looking for the record we just -- produced. Captures the consumer-side trace ID after the first @@ -146,78 +145,78 @@ -- attached the inbound parent span, so the active context's trace -- ID equals what the producer published on the wire. pollUntilRecord :: - (KafkaConsumer :> es, IOE :> es) => - IORef (Maybe Text) -> - Eff es () + (KafkaConsumer :> es, IOE :> es) => + IORef (Maybe Text) -> + Eff es () pollUntilRecord ref = loop (30 :: Int) where loop 0 = pure () loop n = do - mbRecord <- pollMessage (Timeout 1000) - case mbRecord of - Nothing -> loop (n - 1) - Just _ -> captureCurrentTraceId ref + mbRecord <- pollMessage (Timeout 1000) + case mbRecord of + Nothing -> loop (n - 1) + Just _ -> captureCurrentTraceId ref main :: IO () main = do - rawArgs <- getArgs - args <- case parseArgs rawArgs of - Nothing -> hPutStrLn stderr usage *> exitFailure - Just a -> pure a + rawArgs <- getArgs + args <- case parseArgs rawArgs of + Nothing -> hPutStrLn stderr usage *> exitFailure + Just a -> pure a - tp <- initializeGlobalTracerProvider - let tracer :: Tracer - tracer = makeTracer tp instrumentation tracerOptions + tp <- initializeGlobalTracerProvider + let tracer :: Tracer + tracer = makeTracer tp instrumentation tracerOptions - producerTraceRef <- newIORef Nothing - consumerTraceRef <- newIORef Nothing + producerTraceRef <- newIORef Nothing + consumerTraceRef <- newIORef Nothing - producerResult <- - runEff . runError @KafkaError $ - runKafkaProducerTraced tracer (producerProps args.bootstrapServers) $ - inSpan'' tracer "publish" defaultSpanArguments $ \_parentSpan -> do - captureCurrentTraceId producerTraceRef - produceMessage (mkRecord args.topic) - flushProducer - case producerResult of - Left (_cs, err) -> do - hPutStrLn stderr $ "producer error: " <> show err - _ <- shutdownTracerProvider tp Nothing - exitFailure - Right () -> pure () + producerResult <- + runEff . runError @KafkaError $ + runKafkaProducerTraced tracer (producerProps args.bootstrapServers) $ + inSpan'' tracer "publish" defaultSpanArguments $ \_parentSpan -> do + captureCurrentTraceId producerTraceRef + produceMessage (mkRecord args.topic) + flushProducer + case producerResult of + Left (_cs, err) -> do + hPutStrLn stderr $ "producer error: " <> show err + _ <- shutdownTracerProvider tp Nothing + exitFailure + Right () -> pure () - consumerResult <- - runEff . runError @KafkaError $ - runKafkaConsumerTraced - tracer - (consumerProps args.bootstrapServers) - (topics [TopicName args.topic] <> offsetReset Earliest) - (pollUntilRecord consumerTraceRef) - case consumerResult of - Left (_cs, err) -> do - hPutStrLn stderr $ "consumer error: " <> show err - _ <- shutdownTracerProvider tp Nothing - exitFailure - Right () -> pure () + consumerResult <- + runEff . runError @KafkaError $ + runKafkaConsumerTraced + tracer + (consumerProps args.bootstrapServers) + (topics [TopicName args.topic] <> offsetReset Earliest) + (pollUntilRecord consumerTraceRef) + case consumerResult of + Left (_cs, err) -> do + hPutStrLn stderr $ "consumer error: " <> show err + _ <- shutdownTracerProvider tp Nothing + exitFailure + Right () -> pure () - pid <- readIORef producerTraceRef - cid <- readIORef consumerTraceRef - _ <- shutdownTracerProvider tp Nothing - case (pid, cid) of - (Just p, Just c) -> do - putStrLn $ "[otel-tracing] producer trace id: " <> Text.unpack p - putStrLn $ "[otel-tracing] consumer trace id: " <> Text.unpack c - if p == c - then do - putStrLn - "[otel-tracing] trace IDs match — context propagated through Kafka headers" - exitSuccess - else do - putStrLn "[otel-tracing] trace IDs differ" - exitFailure - (Nothing, _) -> do - hPutStrLn stderr "[otel-tracing] failed to capture producer trace id" - exitFailure - (_, Nothing) -> do - hPutStrLn stderr "[otel-tracing] consumer never received the record (timed out)" - exitFailure + pid <- readIORef producerTraceRef + cid <- readIORef consumerTraceRef + _ <- shutdownTracerProvider tp Nothing + case (pid, cid) of + (Just p, Just c) -> do + putStrLn $ "[otel-tracing] producer trace id: " <> Text.unpack p + putStrLn $ "[otel-tracing] consumer trace id: " <> Text.unpack c + if p == c + then do + putStrLn + "[otel-tracing] trace IDs match — context propagated through Kafka headers" + exitSuccess + else do + putStrLn "[otel-tracing] trace IDs differ" + exitFailure + (Nothing, _) -> do + hPutStrLn stderr "[otel-tracing] failed to capture producer trace id" + exitFailure + (_, Nothing) -> do + hPutStrLn stderr "[otel-tracing] consumer never received the record (timed out)" + exitFailure diff --git a/examples/SyncPublish.hs b/examples/SyncPublish.hs --- a/examples/SyncPublish.hs +++ b/examples/SyncPublish.hs @@ -1,11 +1,10 @@ -{- | Scenario 2 of @producer-best-practices.md@: publish one record -synchronously and print the broker-assigned offset. - -Assumes a Kafka broker at localhost:9092 with the topic -@kafka-effectful-sync-demo@ already created (or auto-create enabled). -Change the 'brokerHost' and 'topicName' bindings below if your local -broker lives somewhere else. --} +-- | Scenario 2 of @producer-best-practices.md@: publish one record +-- synchronously and print the broker-assigned offset. +-- +-- Assumes a Kafka broker at localhost:9092 with the topic +-- @kafka-effectful-sync-demo@ already created (or auto-create enabled). +-- Change the 'brokerHost' and 'topicName' bindings below if your local +-- broker lives somewhere else. module Main (main) where import Effectful (runEff) @@ -23,29 +22,29 @@ producerProps :: ProducerProperties producerProps = - brokersList [brokerHost] - <> sendTimeout (Timeout 10000) - <> extraProp "enable.idempotence" "true" - <> extraProp "acks" "all" + brokersList [brokerHost] + <> sendTimeout (Timeout 10000) + <> extraProp "enable.idempotence" "true" + <> extraProp "acks" "all" record :: ProducerRecord record = - ProducerRecord - { prTopic = topicName - , prPartition = UnassignedPartition - , prKey = Just "demo-key" - , prValue = Just "hello from produceMessageSync" - , prHeaders = mempty - } + ProducerRecord + { prTopic = topicName, + prPartition = UnassignedPartition, + prKey = Just "demo-key", + prValue = Just "hello from produceMessageSync", + prHeaders = mempty + } main :: IO () main = do - result <- runEff . runError @KafkaError $ - runKafkaProducer producerProps $ do - produceMessageSync record - case result of - Right (Offset offset) -> - putStrLn $ "delivered offset " <> show offset - Left (_callStack, err) -> do - hPutStrLn stderr $ "kafka error: " <> show err - exitFailure + result <- runEff . runError @KafkaError $ + runKafkaProducer producerProps $ do + produceMessageSync record + case result of + Right (Offset offset) -> + putStrLn $ "delivered offset " <> show offset + Left (_callStack, err) -> do + hPutStrLn stderr $ "kafka error: " <> show err + exitFailure diff --git a/examples/TransactionalEtl.hs b/examples/TransactionalEtl.hs --- a/examples/TransactionalEtl.hs +++ b/examples/TransactionalEtl.hs @@ -1,17 +1,16 @@ -{- | Scenario 5 of @producer-best-practices.md@: consume from one topic, -uppercase the value, and produce to another topic — all inside a -producer transaction, with consumer offsets committed as part of the -same transaction. - -Assumes a Kafka broker at localhost:9092 with topics @source@ and -@destination@ already created (or auto-create enabled). - -To exercise the exactly-once guarantee: - - 1. seed records into @source@ (e.g. @kcat -P -b localhost:9092 -t source@) - 2. run this example; watch @destination@ (@kcat -C -e -b localhost:9092 -t destination@) - 3. kill -9 the process mid-batch, restart it, and confirm no duplicates. --} +-- | Scenario 5 of @producer-best-practices.md@: consume from one topic, +-- uppercase the value, and produce to another topic — all inside a +-- producer transaction, with consumer offsets committed as part of the +-- same transaction. +-- +-- Assumes a Kafka broker at localhost:9092 with topics @source@ and +-- @destination@ already created (or auto-create enabled). +-- +-- To exercise the exactly-once guarantee: +-- +-- 1. seed records into @source@ (e.g. @kcat -P -b localhost:9092 -t source@) +-- 2. run this example; watch @destination@ (@kcat -C -e -b localhost:9092 -t destination@) +-- 3. kill -9 the process mid-batch, restart it, and confirm no duplicates. module Main (main) where import Control.Monad (forever, unless) @@ -38,81 +37,80 @@ producerProps :: ProducerProperties producerProps = - P.brokersList [brokerHost] - <> P.sendTimeout (Timeout 30000) - <> P.extraProp "transactional.id" "kafka-effectful-etl-1" - <> P.extraProp "enable.idempotence" "true" - <> P.extraProp "acks" "all" + P.brokersList [brokerHost] + <> P.sendTimeout (Timeout 30000) + <> P.extraProp "transactional.id" "kafka-effectful-etl-1" + <> P.extraProp "enable.idempotence" "true" + <> P.extraProp "acks" "all" consumerProps :: ConsumerProperties consumerProps = - C.brokersList [brokerHost] - <> C.groupId (ConsumerGroupId "kafka-effectful-etl-group") - <> C.noAutoCommit - <> C.extraProp "isolation.level" "read_committed" + C.brokersList [brokerHost] + <> C.groupId (ConsumerGroupId "kafka-effectful-etl-group") + <> C.noAutoCommit + <> C.extraProp "isolation.level" "read_committed" sourceSubscription :: Subscription sourceSubscription = topics [sourceTopic] <> offsetReset Earliest -- | Uppercase ASCII bytes in the value; drop anything else. transform :: - ConsumerRecord (Maybe ByteString) (Maybe ByteString) -> - ProducerRecord + ConsumerRecord (Maybe ByteString) (Maybe ByteString) -> + ProducerRecord transform msg = - ProducerRecord - { prTopic = destinationTopic - , prPartition = UnassignedPartition - , prKey = crKey msg - , prValue = fmap (BS8.map toUpper) (crValue msg) - , prHeaders = mempty - } + ProducerRecord + { prTopic = destinationTopic, + prPartition = UnassignedPartition, + prKey = crKey msg, + prValue = fmap (BS8.map toUpper) (crValue msg), + prHeaders = mempty + } -{- | Keep only the last record per source partition — that is the offset -to commit into the transaction. --} +-- | Keep only the last record per source partition — that is the offset +-- to commit into the transaction. lastPerPartition :: - [ConsumerRecord (Maybe ByteString) (Maybe ByteString)] -> - [ConsumerRecord (Maybe ByteString) (Maybe ByteString)] + [ConsumerRecord (Maybe ByteString) (Maybe ByteString)] -> + [ConsumerRecord (Maybe ByteString) (Maybe ByteString)] lastPerPartition = - Map.elems . Map.fromList . fmap (\r -> ((crTopic r, crPartition r), r)) + Map.elems . Map.fromList . fmap (\r -> ((crTopic r, crPartition r), r)) handleTxResult :: - (KafkaProducer :> es, Error KafkaError :> es, IOE :> es) => - Maybe TxError -> - Eff es () + (KafkaProducer :> es, Error KafkaError :> es, IOE :> es) => + Maybe TxError -> + Eff es () handleTxResult Nothing = pure () handleTxResult (Just err) - | kafkaErrorTxnRequiresAbort err = abortTransaction (Timeout 5000) - | kafkaErrorIsRetriable err = - liftIO $ hPutStrLn stderr "retriable tx error — retry the whole transaction" - | kafkaErrorIsFatal err = throwError (getKafkaError err) - | otherwise = - liftIO $ hPutStrLn stderr $ "tx error: " <> show (getKafkaError err) + | kafkaErrorTxnRequiresAbort err = abortTransaction (Timeout 5000) + | kafkaErrorIsRetriable err = + liftIO $ hPutStrLn stderr "retriable tx error — retry the whole transaction" + | kafkaErrorIsFatal err = throwError (getKafkaError err) + | otherwise = + liftIO $ hPutStrLn stderr $ "tx error: " <> show (getKafkaError err) etlLoop :: - (KafkaProducer :> es, KafkaConsumer :> es, Error KafkaError :> es, IOE :> es) => - Eff es () + (KafkaProducer :> es, KafkaConsumer :> es, Error KafkaError :> es, IOE :> es) => + Eff es () etlLoop = do - initTransactions (Timeout 10000) - forever $ do - msgs <- pollMessageBatch (Timeout 500) (BatchSize 100) - let records = rights msgs - unless (null records) $ do - beginTransaction - for_ records (produceMessage . transform) - for_ (lastPerPartition records) $ \r -> - commitOffsetMessageTransaction r (Timeout 5000) - >>= handleTxResult - commitTransaction (Timeout 5000) >>= handleTxResult + initTransactions (Timeout 10000) + forever $ do + msgs <- pollMessageBatch (Timeout 500) (BatchSize 100) + let records = rights msgs + unless (null records) $ do + beginTransaction + for_ records (produceMessage . transform) + for_ (lastPerPartition records) $ \r -> + commitOffsetMessageTransaction r (Timeout 5000) + >>= handleTxResult + commitTransaction (Timeout 5000) >>= handleTxResult main :: IO () main = do - result <- - runEff . runError @KafkaError $ - runKafkaProducer producerProps $ - runKafkaConsumer consumerProps sourceSubscription etlLoop - case result of - Right () -> pure () - Left (_callStack, err) -> do - hPutStrLn stderr $ "kafka error: " <> show err - exitFailure + result <- + runEff . runError @KafkaError $ + runKafkaProducer producerProps $ + runKafkaConsumer consumerProps sourceSubscription etlLoop + case result of + Right () -> pure () + Left (_callStack, err) -> do + hPutStrLn stderr $ "kafka error: " <> show err + exitFailure diff --git a/kafka-effectful.cabal b/kafka-effectful.cabal --- a/kafka-effectful.cabal +++ b/kafka-effectful.cabal @@ -1,43 +1,50 @@ -cabal-version: 3.4 -name: kafka-effectful -version: 0.3.0.0 -synopsis: Effectful effects for hw-kafka-client +cabal-version: 3.4 +name: kafka-effectful +version: 0.3.1.0 +synopsis: Effectful effects for hw-kafka-client description: Effectful effects and interpreters for hw-kafka-client, a Haskell binding to Apache Kafka via librdkafka. Provides typed, composable KafkaProducer and KafkaConsumer effects. -license: MIT -license-file: LICENSE -author: Nadeem Bitar -maintainer: Nadeem Bitar -category: Network, Messaging -build-type: Simple +license: MIT +license-file: LICENSE +author: Nadeem Bitar +maintainer: Nadeem Bitar +category: Network, Messaging +build-type: Simple extra-doc-files: CHANGELOG.md README.md source-repository head - type: git + type: git location: https://github.com/shinzui/kafka-effectful.git flag examples description: Build example executables - manual: True - default: False + manual: True + default: False common warnings ghc-options: - -Wall -Wcompat -Widentities -Wincomplete-uni-patterns - -Wincomplete-record-updates -Wredundant-constraints - -fhide-source-paths -Wmissing-export-lists -Wpartial-fields + -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + -fhide-source-paths + -Wmissing-export-lists + -Wpartial-fields -Wmissing-deriving-strategies library - import: warnings + import: warnings exposed-modules: Kafka.Effectful Kafka.Effectful.Consumer + Kafka.Effectful.Consumer.Classify Kafka.Effectful.Consumer.Effect Kafka.Effectful.Consumer.Interpreter Kafka.Effectful.OpenTelemetry @@ -51,21 +58,21 @@ Kafka.Effectful.Producer.Transaction build-depends: - , base >=4.21 && <5 - , bytestring >=0.11 && <0.13 - , case-insensitive >=1.2 && <1.3 - , containers >=0.6 && <0.8 - , effectful-core >=2.5 && <2.7 - , hs-opentelemetry-api ^>=1.0 - , hs-opentelemetry-semantic-conventions >=1.40 && <2 - , http-types >=0.12 && <0.13 - , hw-kafka-client >=5.3 && <6 - , text >=2.0 && <2.2 - , unliftio-core >=0.2 && <0.3 - , unordered-containers >=0.2 && <0.3 + base >=4.21 && <5, + bytestring >=0.11 && <0.13, + case-insensitive >=1.2 && <1.3, + containers >=0.6 && <0.8, + effectful-core >=2.5 && <2.8, + hs-opentelemetry-api ^>=1.0, + hs-opentelemetry-semantic-conventions >=1.40 && <2, + http-types >=0.12 && <0.13, + hw-kafka-client >=5.3 && <6, + text >=2.0 && <2.2, + unliftio-core >=0.2 && <0.3, + unordered-containers >=0.2 && <0.3, - hs-source-dirs: src - default-language: GHC2024 + hs-source-dirs: src + default-language: GHC2024 default-extensions: DataKinds DuplicateRecordFields @@ -80,10 +87,10 @@ TypeOperators executable example-sync-publish - import: warnings - main-is: SyncPublish.hs - hs-source-dirs: examples - default-language: GHC2024 + import: warnings + main-is: SyncPublish.hs + hs-source-dirs: examples + default-language: GHC2024 default-extensions: ImportQualifiedPost LambdaCase @@ -92,19 +99,18 @@ if !flag(examples) buildable: False - build-depends: - , base >=4.21 && <5 - , bytestring >=0.11 && <0.13 - , effectful-core >=2.5 && <2.7 - , hw-kafka-client >=5.3 && <6 - , kafka-effectful + base >=4.21 && <5, + bytestring >=0.11 && <0.13, + effectful-core >=2.5 && <2.8, + hw-kafka-client >=5.3 && <6, + kafka-effectful, executable example-transactional-etl - import: warnings - main-is: TransactionalEtl.hs - hs-source-dirs: examples - default-language: GHC2024 + import: warnings + main-is: TransactionalEtl.hs + hs-source-dirs: examples + default-language: GHC2024 default-extensions: ImportQualifiedPost LambdaCase @@ -113,25 +119,23 @@ if !flag(examples) buildable: False - build-depends: - , base >=4.21 && <5 - , bytestring >=0.11 && <0.13 - , containers >=0.6 && <0.8 - , effectful-core >=2.5 && <2.7 - , hw-kafka-client >=5.3 && <6 - , kafka-effectful + base >=4.21 && <5, + bytestring >=0.11 && <0.13, + containers >=0.6 && <0.8, + effectful-core >=2.5 && <2.8, + hw-kafka-client >=5.3 && <6, + kafka-effectful, executable example-otel-tracing - import: warnings - main-is: OtelTracing.hs - hs-source-dirs: examples - + import: warnings + main-is: OtelTracing.hs + hs-source-dirs: examples -- The hs-opentelemetry batch span processor requires the threaded -- runtime; without it, initializeGlobalTracerProvider raises at -- runtime. - ghc-options: -threaded - default-language: GHC2024 + ghc-options: -threaded + default-language: GHC2024 default-extensions: DuplicateRecordFields ImportQualifiedPost @@ -143,30 +147,28 @@ if !flag(examples) buildable: False - build-depends: - , base >=4.21 && <5 - , bytestring >=0.11 && <0.13 - , effectful-core >=2.5 && <2.7 - , hs-opentelemetry-api ^>=1.0 - , hs-opentelemetry-exporter-otlp ^>=1.0 - , hs-opentelemetry-sdk ^>=1.0 - , hw-kafka-client >=5.3 && <6 - , kafka-effectful - , text >=2.0 && <2.2 + base >=4.21 && <5, + bytestring >=0.11 && <0.13, + effectful-core >=2.5 && <2.8, + hs-opentelemetry-api ^>=1.0, + hs-opentelemetry-exporter-otlp ^>=1.0, + hs-opentelemetry-sdk ^>=1.0, + hw-kafka-client >=5.3 && <6, + kafka-effectful, + text >=2.0 && <2.2, test-suite kafka-effectful-test - import: warnings - type: exitcode-stdio-1.0 - main-is: Main.hs - hs-source-dirs: test - + import: warnings + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test -- The hs-opentelemetry batch span processor requires the threaded -- runtime. Without -threaded, even initializing the global tracer -- provider in PropagationTest's withResource block raises an -- exception at runtime. - ghc-options: -threaded - default-language: GHC2024 + ghc-options: -threaded + default-language: GHC2024 default-extensions: DataKinds DuplicateRecordFields @@ -179,24 +181,27 @@ TypeOperators other-modules: + Kafka.Effectful.Consumer.ClassifyTest + Kafka.Effectful.Consumer.InterpreterTest + Kafka.Effectful.OpenTelemetry.ConsumerSpanTest Kafka.Effectful.OpenTelemetry.PropagationTest Kafka.Effectful.OpenTelemetry.SemanticTest Kafka.Effectful.OpenTelemetry.ShibuyaCompatibilityTest build-depends: - , base >=4.21 && <5 - , bytestring >=0.11 && <0.13 - , case-insensitive >=1.2 && <1.3 - , containers >=0.6 && <0.8 - , effectful-core >=2.5 && <2.7 - , hs-opentelemetry-api ^>=1.0 - , hs-opentelemetry-exporter-in-memory ^>=1.0 - , hs-opentelemetry-sdk ^>=1.0 - , hs-opentelemetry-semantic-conventions >=1.40 && <2 - , http-types >=0.12 && <0.13 - , hw-kafka-client >=5.3 && <6 - , kafka-effectful - , tasty ^>=1.5 - , tasty-hunit ^>=0.10 - , text >=2.0 && <2.2 - , unordered-containers >=0.2 && <0.3 + base >=4.21 && <5, + bytestring >=0.11 && <0.13, + case-insensitive >=1.2 && <1.3, + containers >=0.6 && <0.8, + effectful-core >=2.5 && <2.8, + hs-opentelemetry-api ^>=1.0, + hs-opentelemetry-exporter-in-memory ^>=1.0, + hs-opentelemetry-sdk ^>=1.0, + hs-opentelemetry-semantic-conventions >=1.40 && <2, + http-types >=0.12 && <0.13, + hw-kafka-client >=5.3 && <6, + kafka-effectful, + tasty ^>=1.5, + tasty-hunit ^>=0.10, + text >=2.0 && <2.2, + unordered-containers >=0.2 && <0.3, diff --git a/src/Kafka/Effectful.hs b/src/Kafka/Effectful.hs --- a/src/Kafka/Effectful.hs +++ b/src/Kafka/Effectful.hs @@ -1,5 +1,5 @@ -module Kafka.Effectful ( - -- * Producer Effect +module Kafka.Effectful + ( -- * Producer Effect KafkaProducer, runKafkaProducer, produceMessage, @@ -25,6 +25,7 @@ -- ** Polling pollMessage, + pollMessageEither, pollMessageBatch, -- ** Offset Management @@ -88,11 +89,11 @@ Headers, headersFromList, headersToList, -) + ) where -import Kafka.Effectful.Consumer ( - CallbackPollMode (..), +import Kafka.Effectful.Consumer + ( CallbackPollMode (..), ConsumerGroupId (..), ConsumerProperties (..), ConsumerRecord (..), @@ -117,6 +118,7 @@ pausePartitions, pollMessage, pollMessageBatch, + pollMessageEither, position, resumePartitions, runKafkaConsumer, @@ -125,9 +127,9 @@ storeOffsets, subscription, topics, - ) -import Kafka.Effectful.Producer ( - DeliveryReport (..), + ) +import Kafka.Effectful.Producer + ( DeliveryReport (..), ImmediateError (..), KafkaProducer, ProducePartition (..), @@ -148,9 +150,9 @@ produceMessageBatch, produceMessageSync, runKafkaProducer, - ) -import Kafka.Types ( - BatchSize (..), + ) +import Kafka.Types + ( BatchSize (..), BrokerAddress (..), ClientId (..), Headers, @@ -164,4 +166,4 @@ TopicName (..), headersFromList, headersToList, - ) + ) diff --git a/src/Kafka/Effectful/Consumer.hs b/src/Kafka/Effectful/Consumer.hs --- a/src/Kafka/Effectful/Consumer.hs +++ b/src/Kafka/Effectful/Consumer.hs @@ -1,5 +1,5 @@ -module Kafka.Effectful.Consumer ( - -- * Effect +module Kafka.Effectful.Consumer + ( -- * Effect KafkaConsumer, -- * Interpreter @@ -7,6 +7,7 @@ -- * Polling pollMessage, + pollMessageEither, pollMessageBatch, -- * Offset Management @@ -92,13 +93,13 @@ Headers, headersFromList, headersToList, -) + ) where import Kafka.Consumer.ConsumerProperties (CallbackPollMode (..), ConsumerProperties (..)) import Kafka.Consumer.ConsumerProperties qualified as K import Kafka.Consumer.Subscription (Subscription (..), extraSubscriptionProps, offsetReset, topics) import Kafka.Consumer.Types (ConsumerGroupId (..), ConsumerRecord (..), Offset (..), OffsetCommit (..), OffsetReset (..), PartitionOffset (..), RebalanceEvent (..), SubscribedPartitions (..), Timestamp (..), TopicPartition (..)) -import Kafka.Effectful.Consumer.Effect (KafkaConsumer, askConsumerHandle, assign, assignment, commitAllOffsets, commitOffsetMessage, commitPartitionsOffsets, committed, pausePartitions, pollMessage, pollMessageBatch, position, resumePartitions, seekPartitions, storeOffsetMessage, storeOffsets, subscription) +import Kafka.Effectful.Consumer.Effect (KafkaConsumer, askConsumerHandle, assign, assignment, commitAllOffsets, commitOffsetMessage, commitPartitionsOffsets, committed, pausePartitions, pollMessage, pollMessageBatch, pollMessageEither, position, resumePartitions, seekPartitions, storeOffsetMessage, storeOffsets, subscription) import Kafka.Effectful.Consumer.Interpreter (runKafkaConsumer) import Kafka.Types (BatchSize (..), BrokerAddress (..), ClientId (..), Headers, KafkaCompressionCodec (..), KafkaDebug (..), KafkaError (..), KafkaLogLevel (..), Millis (..), PartitionId (..), Timeout (..), TopicName (..), headersFromList, headersToList) diff --git a/src/Kafka/Effectful/Consumer/Classify.hs b/src/Kafka/Effectful/Consumer/Classify.hs new file mode 100644 --- /dev/null +++ b/src/Kafka/Effectful/Consumer/Classify.hs @@ -0,0 +1,101 @@ +-- | How the consumer interpreters treat the errors librdkafka hands back +-- /in-band/ — that is, as a @Left@ inside a poll result or a @Just@ from a +-- commit — rather than by throwing. +-- +-- Both the plain and the traced interpreter route every such error through this +-- module, so the policy is stated once, is unit-testable without a broker, and +-- cannot drift between the two interpreters. +-- +-- The distinction that matters is between conditions that mean __this consumer +-- is broken__ and conditions that are just __flow control__. librdkafka reports +-- both the same way, and treating the second kind as failure is how a healthy +-- consumer ends up in a crash loop: the interpreter throws, the bracket closes +-- the consumer, the supervisor restarts it, it re-subscribes, and it meets the +-- same partition-scoped condition again. +-- +-- @since 0.4.0.0 +module Kafka.Effectful.Consumer.Classify + ( -- * Poll errors + PollErrorDisposition (..), + classifyPollError, + + -- * Commit errors + isBenignCommitError, + ) +where + +import Kafka.Consumer (RdKafkaRespErrT (..)) +import Kafka.Types (KafkaError (..)) + +-- | What an interpreter does with an in-band poll error. +-- +-- @since 0.4.0.0 +data PollErrorDisposition + = -- | @RdKafkaRespErrTimedOut@: the poll interval elapsed with no + -- message. Not an error at all; the poll returns 'Nothing'. + PollTimeout + | -- | A partition-scoped flow-control condition that a healthy consumer + -- is expected to meet during normal operation. The poll returns + -- 'Nothing' and the consumer keeps running. + PollBenign + | -- | Anything else, including every fatal error: rethrown through the + -- @Error@ effect. + PollThrow + deriving stock (Eq, Show) + +-- | Classify an in-band poll error. +-- +-- Three codes are treated as benign, each because librdkafka uses it to report +-- a normal, partition-scoped fact rather than a failure of the consumer: +-- +-- * @RdKafkaRespErrPartitionEof@ — the consumer has caught up with a +-- partition. Delivered on every catch-up when @enable.partition.eof@ is set, +-- so throwing on it kills a consumer precisely when it has succeeded. +-- +-- * @RdKafkaRespErrAutoOffsetReset@ — the consumer's position was reset, or a +-- reset was attempted and refused. librdkafka raises this as a consumer error +-- only under @auto.offset.reset=error@ or when a reset itself fails; a +-- successful reset after retention loss merely logs. Either way the condition +-- is scoped to one partition's position, and it is delivered before any new +-- commit can move that position, so throwing on it loops forever. +-- +-- * @RdKafkaRespErrUnknownTopicOrPart@ — the topic or partition is not known +-- yet. Normal inside a topic-creation window, and it resolves itself once +-- metadata propagates. +-- +-- Everything else throws. That deliberately includes @RdKafkaRespErrFatal@, the +-- generic code librdkafka delivers once a fatal error has been raised on the +-- client — a fenced static group member being the canonical case — after which +-- the consumer is permanently dead and must be closed. It also includes +-- @RdKafkaRespErrSaslAuthenticationFailed@, where retrying in a poll loop never +-- helps and can lock accounts. Both of those are matched by the catch-all +-- rather than by name, so a fatal cause this table has never heard of still +-- throws; that is the intended failure direction. +-- +-- This table is the interpreter-side counterpart of @hw-kafka-streamly@'s +-- @Kafka.Streamly.Stream.isFatal@, which classifies the same codes for stream +-- consumers. They should be read together when either changes. +-- +-- @since 0.4.0.0 +classifyPollError :: KafkaError -> PollErrorDisposition +classifyPollError = \case + KafkaResponseError RdKafkaRespErrTimedOut -> PollTimeout + KafkaResponseError RdKafkaRespErrPartitionEof -> PollBenign + KafkaResponseError RdKafkaRespErrAutoOffsetReset -> PollBenign + KafkaResponseError RdKafkaRespErrUnknownTopicOrPart -> PollBenign + _ -> PollThrow +{-# INLINE classifyPollError #-} + +-- | Whether a commit result means "there was nothing to commit" rather than +-- "the commit failed". +-- +-- This holds for exactly @RdKafkaRespErrNoOffset@. hw-kafka-client's own +-- offset-commit callback documentation says the code "is not to be considered +-- an error": it is what librdkafka returns when a commit is requested and no +-- offsets have advanced — an idle consumer, or a shutdown commit on a consumer +-- that never received anything. +-- +-- @since 0.4.0.0 +isBenignCommitError :: KafkaError -> Bool +isBenignCommitError = (==) (KafkaResponseError RdKafkaRespErrNoOffset) +{-# INLINE isBenignCommitError #-} diff --git a/src/Kafka/Effectful/Consumer/Effect.hs b/src/Kafka/Effectful/Consumer/Effect.hs --- a/src/Kafka/Effectful/Consumer/Effect.hs +++ b/src/Kafka/Effectful/Consumer/Effect.hs @@ -1,9 +1,10 @@ -module Kafka.Effectful.Consumer.Effect ( - -- * Effect +module Kafka.Effectful.Consumer.Effect + ( -- * Effect KafkaConsumer (..), -- * Polling pollMessage, + pollMessageEither, pollMessageBatch, -- * Offset Management @@ -27,119 +28,159 @@ -- * Internal — cross-effect plumbing askConsumerHandle, -) + ) where import Data.ByteString (ByteString) import Data.Map.Strict (Map) import Effectful (Dispatch (..), DispatchOf, Eff, Effect, (:>)) import Effectful.Dispatch.Dynamic (send) -import Kafka.Consumer.Types ( - ConsumerRecord, +import Kafka.Consumer.Types + ( ConsumerRecord, OffsetCommit, SubscribedPartitions, TopicPartition, - ) + ) import Kafka.Consumer.Types qualified as KC -import Kafka.Types ( - BatchSize, +import Kafka.Types + ( BatchSize, KafkaError, PartitionId, Timeout, TopicName, - ) + ) -- | Effect for Kafka consumer operations. data KafkaConsumer :: Effect where - PollMessage :: - Timeout -> - KafkaConsumer m (Maybe (ConsumerRecord (Maybe ByteString) (Maybe ByteString))) - PollMessageBatch :: - Timeout -> - BatchSize -> - KafkaConsumer m [Either KafkaError (ConsumerRecord (Maybe ByteString) (Maybe ByteString))] - CommitOffsetMessage :: - OffsetCommit -> - ConsumerRecord k v -> - KafkaConsumer m () - CommitAllOffsets :: - OffsetCommit -> - KafkaConsumer m () - CommitPartitionsOffsets :: - OffsetCommit -> - [TopicPartition] -> - KafkaConsumer m () - StoreOffsets :: - [TopicPartition] -> - KafkaConsumer m () - StoreOffsetMessage :: - ConsumerRecord k v -> - KafkaConsumer m () - Assign :: - [TopicPartition] -> - KafkaConsumer m () - PausePartitions :: - [(TopicName, PartitionId)] -> - KafkaConsumer m () - ResumePartitions :: - [(TopicName, PartitionId)] -> - KafkaConsumer m () - SeekPartitions :: - [TopicPartition] -> - Timeout -> - KafkaConsumer m () - Committed :: - Timeout -> - [(TopicName, PartitionId)] -> - KafkaConsumer m [TopicPartition] - Position :: - [(TopicName, PartitionId)] -> - KafkaConsumer m [TopicPartition] - Assignment :: - KafkaConsumer m (Map TopicName [PartitionId]) - Subscription :: - KafkaConsumer m [(TopicName, SubscribedPartitions)] - AskConsumerHandle :: - KafkaConsumer m KC.KafkaConsumer + PollMessage :: + Timeout -> + KafkaConsumer m (Maybe (ConsumerRecord (Maybe ByteString) (Maybe ByteString))) + PollMessageEither :: + Timeout -> + KafkaConsumer m (Either KafkaError (ConsumerRecord (Maybe ByteString) (Maybe ByteString))) + PollMessageBatch :: + Timeout -> + BatchSize -> + KafkaConsumer m [Either KafkaError (ConsumerRecord (Maybe ByteString) (Maybe ByteString))] + CommitOffsetMessage :: + OffsetCommit -> + ConsumerRecord k v -> + KafkaConsumer m () + CommitAllOffsets :: + OffsetCommit -> + KafkaConsumer m () + CommitPartitionsOffsets :: + OffsetCommit -> + [TopicPartition] -> + KafkaConsumer m () + StoreOffsets :: + [TopicPartition] -> + KafkaConsumer m () + StoreOffsetMessage :: + ConsumerRecord k v -> + KafkaConsumer m () + Assign :: + [TopicPartition] -> + KafkaConsumer m () + PausePartitions :: + [(TopicName, PartitionId)] -> + KafkaConsumer m () + ResumePartitions :: + [(TopicName, PartitionId)] -> + KafkaConsumer m () + SeekPartitions :: + [TopicPartition] -> + Timeout -> + KafkaConsumer m () + Committed :: + Timeout -> + [(TopicName, PartitionId)] -> + KafkaConsumer m [TopicPartition] + Position :: + [(TopicName, PartitionId)] -> + KafkaConsumer m [TopicPartition] + Assignment :: + KafkaConsumer m (Map TopicName [PartitionId]) + Subscription :: + KafkaConsumer m [(TopicName, SubscribedPartitions)] + AskConsumerHandle :: + KafkaConsumer m KC.KafkaConsumer type instance DispatchOf KafkaConsumer = 'Dynamic -- Polling -{- | Poll for a single message. - -Returns 'Nothing' when the timeout elapses without a message arriving. -Throws 'KafkaError' via the 'Error' effect for any non-timeout failure -(for example, a broker transport error or an assignment revocation). --} +-- | Poll for a single message. +-- +-- Returns 'Nothing' when nothing was delivered, which covers the timeout and +-- three partition-scoped conditions that librdkafka reports as errors but which +-- a healthy consumer is expected to meet during normal operation: +-- +-- * @RdKafkaRespErrPartitionEof@ — caught up with a partition. +-- * @RdKafkaRespErrAutoOffsetReset@ — the position was reset, or a reset was +-- refused. Raised as a consumer error only under @auto.offset.reset=error@ or +-- when a reset itself fails; a successful reset after retention loss only +-- logs. +-- * @RdKafkaRespErrUnknownTopicOrPart@ — the topic or partition is not known +-- yet, normal inside a topic-creation window. +-- +-- Every other in-band error is thrown as 'KafkaError' via the 'Error' effect — +-- transport failures, authentication failures, and fatal errors among them. +-- +-- Use 'pollMessageEither' when you need to observe the swallowed conditions, +-- for example to detect partition EOF in a bounded read. The full policy lives +-- in "Kafka.Effectful.Consumer.Classify". pollMessage :: - (KafkaConsumer :> es) => - Timeout -> - Eff es (Maybe (ConsumerRecord (Maybe ByteString) (Maybe ByteString))) + (KafkaConsumer :> es) => + Timeout -> + Eff es (Maybe (ConsumerRecord (Maybe ByteString) (Maybe ByteString))) pollMessage = send . PollMessage +-- | Poll for a single message, returning every in-band condition as a +-- 'Left' instead of swallowing or throwing it. +-- +-- Nothing is hidden: timeouts, partition EOF, offset resets and hard failures +-- all arrive as @Left@. Use this for bounded reads that must observe partition +-- EOF to know when to stop, or wherever the full librdkafka taxonomy matters. +-- +-- @since 0.4.0.0 +pollMessageEither :: + (KafkaConsumer :> es) => + Timeout -> + Eff es (Either KafkaError (ConsumerRecord (Maybe ByteString) (Maybe ByteString))) +pollMessageEither = send . PollMessageEither + -- | Poll for a batch of messages. Per-message errors are preserved in the 'Either'. pollMessageBatch :: - (KafkaConsumer :> es) => - Timeout -> - BatchSize -> - Eff es [Either KafkaError (ConsumerRecord (Maybe ByteString) (Maybe ByteString))] + (KafkaConsumer :> es) => + Timeout -> + BatchSize -> + Eff es [Either KafkaError (ConsumerRecord (Maybe ByteString) (Maybe ByteString))] pollMessageBatch t b = send $ PollMessageBatch t b -- Offset Management -- | Commit the offset of a specific message. Throws 'KafkaError' on failure. +-- +-- A commit that finds nothing to commit (@RdKafkaRespErrNoOffset@) is a +-- success, not a failure — see "Kafka.Effectful.Consumer.Classify". commitOffsetMessage :: - (KafkaConsumer :> es) => OffsetCommit -> ConsumerRecord k v -> Eff es () + (KafkaConsumer :> es) => OffsetCommit -> ConsumerRecord k v -> Eff es () commitOffsetMessage oc cr = send $ CommitOffsetMessage oc cr --- | Commit offsets for all currently assigned partitions. Throws 'KafkaError' on failure. +-- | Commit offsets for all currently assigned partitions. Throws +-- 'KafkaError' on failure. +-- +-- An idle consumer with nothing to commit succeeds rather than throwing; see +-- 'commitOffsetMessage'. commitAllOffsets :: (KafkaConsumer :> es) => OffsetCommit -> Eff es () commitAllOffsets = send . CommitAllOffsets -- | Commit offsets for specific partitions. Throws 'KafkaError' on failure. +-- +-- A commit with nothing to commit succeeds; see 'commitOffsetMessage'. commitPartitionsOffsets :: - (KafkaConsumer :> es) => OffsetCommit -> [TopicPartition] -> Eff es () + (KafkaConsumer :> es) => OffsetCommit -> [TopicPartition] -> Eff es () commitPartitionsOffsets oc tps = send $ CommitPartitionsOffsets oc tps -- | Store offsets locally without committing to the broker. Throws 'KafkaError' on failure. @@ -172,17 +213,17 @@ -- | Get committed offsets for the specified partitions. Throws 'KafkaError' on failure. committed :: - (KafkaConsumer :> es) => - Timeout -> - [(TopicName, PartitionId)] -> - Eff es [TopicPartition] + (KafkaConsumer :> es) => + Timeout -> + [(TopicName, PartitionId)] -> + Eff es [TopicPartition] committed t ps = send $ Committed t ps -- | Get the current position (last consumed offset + 1). Throws 'KafkaError' on failure. position :: - (KafkaConsumer :> es) => - [(TopicName, PartitionId)] -> - Eff es [TopicPartition] + (KafkaConsumer :> es) => + [(TopicName, PartitionId)] -> + Eff es [TopicPartition] position = send . Position -- | Get the current partition assignment. @@ -193,17 +234,16 @@ subscription :: (KafkaConsumer :> es) => Eff es [(TopicName, SubscribedPartitions)] subscription = send Subscription -{- | Escape hatch: return the raw @Kafka.Consumer.KafkaConsumer@ handle -acquired by @runKafkaConsumer@. - -Exposed to enable the cross-effect -'Kafka.Effectful.Producer.Transaction.commitOffsetMessageTransaction' -helper, which must reach both the producer and consumer handles to -call the underlying transactional offset-commit primitive. New -operations should go through the 'KafkaConsumer' effect rather than -this handle. - -@since 0.2.0.0 --} +-- | Escape hatch: return the raw @Kafka.Consumer.KafkaConsumer@ handle +-- acquired by @runKafkaConsumer@. +-- +-- Exposed to enable the cross-effect +-- 'Kafka.Effectful.Producer.Transaction.commitOffsetMessageTransaction' +-- helper, which must reach both the producer and consumer handles to +-- call the underlying transactional offset-commit primitive. New +-- operations should go through the 'KafkaConsumer' effect rather than +-- this handle. +-- +-- @since 0.2.0.0 askConsumerHandle :: (KafkaConsumer :> es) => Eff es KC.KafkaConsumer askConsumerHandle = send AskConsumerHandle diff --git a/src/Kafka/Effectful/Consumer/Interpreter.hs b/src/Kafka/Effectful/Consumer/Interpreter.hs --- a/src/Kafka/Effectful/Consumer/Interpreter.hs +++ b/src/Kafka/Effectful/Consumer/Interpreter.hs @@ -4,10 +4,10 @@ -- 'interpret' to type-check. Suppress the warning at the file level. {-# OPTIONS_GHC -Wno-redundant-constraints #-} -module Kafka.Effectful.Consumer.Interpreter ( - -- * Interpreter +module Kafka.Effectful.Consumer.Interpreter + ( -- * Interpreter runKafkaConsumer, -) + ) where import Control.Monad (void) @@ -22,85 +22,99 @@ import Kafka.Consumer qualified as K import Kafka.Consumer.ConsumerProperties (ConsumerProperties) import Kafka.Consumer.Subscription (Subscription) +import Kafka.Effectful.Consumer.Classify + ( PollErrorDisposition (..), + classifyPollError, + isBenignCommitError, + ) import Kafka.Effectful.Consumer.Effect (KafkaConsumer (..)) import Kafka.Types (KafkaError (..)) -{- | Run the 'KafkaConsumer' effect. - -Acquires a consumer handle from the given properties and subscription, -and releases it when the effect scope ends. Errors are thrown via the -'Error' effect. --} +-- | Run the 'KafkaConsumer' effect. +-- +-- Acquires a consumer handle from the given properties and subscription, +-- and releases it when the effect scope ends. Errors are thrown via the +-- 'Error' effect. runKafkaConsumer :: - (IOE :> es, Error KafkaError :> es) => - ConsumerProperties -> - Subscription -> - Eff (KafkaConsumer : es) a -> - Eff es a + (IOE :> es, Error KafkaError :> es) => + ConsumerProperties -> + Subscription -> + Eff (KafkaConsumer : es) a -> + Eff es a runKafkaConsumer props sub action = - fst - <$> Exception.generalBracket - acquire - release - (\consumer -> interpret (handleConsumer consumer) action) + fst + <$> Exception.generalBracket + acquire + release + (\consumer -> interpret (handleConsumer consumer) action) where acquire = do - result <- Effectful.liftIO $ K.newConsumer props sub - case result of - Left err -> throwError err - Right consumer -> pure consumer + result <- Effectful.liftIO $ K.newConsumer props sub + case result of + Left err -> throwError err + Right consumer -> pure consumer release consumer = \case - ExitCaseSuccess _ -> do - mbErr <- Effectful.liftIO $ K.closeConsumer consumer - for_ mbErr throwError - ExitCaseException _ -> - Effectful.liftIO . void $ K.closeConsumer consumer - ExitCaseAbort -> - Effectful.liftIO . void $ K.closeConsumer consumer + ExitCaseSuccess _ -> do + mbErr <- Effectful.liftIO $ K.closeConsumer consumer + for_ mbErr throwError + ExitCaseException _ -> + Effectful.liftIO . void $ K.closeConsumer consumer + ExitCaseAbort -> + Effectful.liftIO . void $ K.closeConsumer consumer handleConsumer :: - (IOE :> es, Error KafkaError :> es) => - K.KafkaConsumer -> - EffectHandler KafkaConsumer es + (IOE :> es, Error KafkaError :> es) => + K.KafkaConsumer -> + EffectHandler KafkaConsumer es handleConsumer consumer _env = \case - PollMessage timeout -> do - result <- Effectful.liftIO $ K.pollMessage consumer timeout - case result of - Left (KafkaResponseError RdKafkaRespErrTimedOut) -> pure Nothing - Left err -> throwError err - Right msg -> pure (Just msg) - PollMessageBatch timeout batchSize -> - Effectful.liftIO $ K.pollMessageBatch consumer timeout batchSize - CommitOffsetMessage oc cr -> throwOnJust $ K.commitOffsetMessage oc consumer cr - CommitAllOffsets oc -> throwOnJust $ K.commitAllOffsets oc consumer - CommitPartitionsOffsets oc tps -> throwOnJust $ K.commitPartitionsOffsets oc consumer tps - StoreOffsets tps -> throwOnJust $ K.storeOffsets consumer tps - StoreOffsetMessage cr -> throwOnJust $ K.storeOffsetMessage consumer cr - Assign tps -> throwOnJust $ K.assign consumer tps - PausePartitions parts -> - throwOnKafkaErr (K.pausePartitions consumer parts) - ResumePartitions parts -> - throwOnKafkaErr (K.resumePartitions consumer parts) - SeekPartitions tps timeout -> throwOnJust $ K.seekPartitions consumer tps timeout - Committed timeout parts -> throwOnLeft $ K.committed consumer timeout parts - Position parts -> throwOnLeft $ K.position consumer parts - Assignment -> throwOnLeft $ K.assignment consumer - Subscription -> throwOnLeft $ K.subscription consumer - AskConsumerHandle -> pure consumer + PollMessage timeout -> do + result <- Effectful.liftIO $ K.pollMessage consumer timeout + case result of + Left err -> case classifyPollError err of + PollTimeout -> pure Nothing + PollBenign -> pure Nothing + PollThrow -> throwError err + Right msg -> pure (Just msg) + PollMessageEither timeout -> + Effectful.liftIO $ K.pollMessage consumer timeout + PollMessageBatch timeout batchSize -> + Effectful.liftIO $ K.pollMessageBatch consumer timeout batchSize + CommitOffsetMessage oc cr -> throwOnJustCommit $ K.commitOffsetMessage oc consumer cr + CommitAllOffsets oc -> throwOnJustCommit $ K.commitAllOffsets oc consumer + CommitPartitionsOffsets oc tps -> throwOnJustCommit $ K.commitPartitionsOffsets oc consumer tps + StoreOffsets tps -> throwOnJust $ K.storeOffsets consumer tps + StoreOffsetMessage cr -> throwOnJust $ K.storeOffsetMessage consumer cr + Assign tps -> throwOnJust $ K.assign consumer tps + PausePartitions parts -> + throwOnKafkaErr (K.pausePartitions consumer parts) + ResumePartitions parts -> + throwOnKafkaErr (K.resumePartitions consumer parts) + SeekPartitions tps timeout -> throwOnJust $ K.seekPartitions consumer tps timeout + Committed timeout parts -> throwOnLeft $ K.committed consumer timeout parts + Position parts -> throwOnLeft $ K.position consumer parts + Assignment -> throwOnLeft $ K.assignment consumer + Subscription -> throwOnLeft $ K.subscription consumer + AskConsumerHandle -> pure consumer where throwOnJust action' = do - mbErr <- Effectful.liftIO action' - for_ mbErr throwError + mbErr <- Effectful.liftIO action' + for_ mbErr throwError + -- Commits get their own thrower: "nothing to commit" is a success. + throwOnJustCommit action' = do + mbErr <- Effectful.liftIO action' + for_ mbErr $ \err -> + if isBenignCommitError err then pure () else throwError err + throwOnLeft action' = do - result <- Effectful.liftIO action' - case result of - Left err -> throwError err - Right a -> pure a + result <- Effectful.liftIO action' + case result of + Left err -> throwError err + Right a -> pure a throwOnKafkaErr action' = do - err <- Effectful.liftIO action' - case err of - KafkaResponseError RdKafkaRespErrNoError -> pure () - _ -> throwError err + err <- Effectful.liftIO action' + case err of + KafkaResponseError RdKafkaRespErrNoError -> pure () + _ -> throwError err diff --git a/src/Kafka/Effectful/OpenTelemetry.hs b/src/Kafka/Effectful/OpenTelemetry.hs --- a/src/Kafka/Effectful/OpenTelemetry.hs +++ b/src/Kafka/Effectful/OpenTelemetry.hs @@ -1,28 +1,27 @@ -{- | Single-import facade for the OpenTelemetry-aware variants of -@kafka-effectful@\'s producer and consumer interpreters, plus the -pure attribute-builder helpers and W3C trace-context propagation -helpers that the traced interpreters are built from. - -Typical wiring: - -> import Kafka.Effectful.OpenTelemetry -> import OpenTelemetry.Trace (initializeGlobalTracerProvider, makeTracer, tracerOptions) -> -> tracer <- do -> tp <- initializeGlobalTracerProvider -> pure (makeTracer tp \"my-app\" tracerOptions) -> -> runEff . runError . runKafkaProducerTraced tracer producerProps $ do -> produceMessage record - -The facade does not re-export the upstream @Tracer@, @Span@, etc. -types; users who need those import them from @OpenTelemetry.Trace@ -or @OpenTelemetry.Trace.Core@ directly. - -@since 0.2.0.0 --} -module Kafka.Effectful.OpenTelemetry ( - -- * Traced interpreters +-- | Single-import facade for the OpenTelemetry-aware variants of +-- @kafka-effectful@\'s producer and consumer interpreters, plus the +-- pure attribute-builder helpers and W3C trace-context propagation +-- helpers that the traced interpreters are built from. +-- +-- Typical wiring: +-- +-- > import Kafka.Effectful.OpenTelemetry +-- > import OpenTelemetry.Trace (initializeGlobalTracerProvider, makeTracer, tracerOptions) +-- > +-- > tracer <- do +-- > tp <- initializeGlobalTracerProvider +-- > pure (makeTracer tp \"my-app\" tracerOptions) +-- > +-- > runEff . runError . runKafkaProducerTraced tracer producerProps $ do +-- > produceMessage record +-- +-- The facade does not re-export the upstream @Tracer@, @Span@, etc. +-- types; users who need those import them from @OpenTelemetry.Trace@ +-- or @OpenTelemetry.Trace.Core@ directly. +-- +-- @since 0.2.0.0 +module Kafka.Effectful.OpenTelemetry + ( -- * Traced interpreters runKafkaProducerTraced, runKafkaConsumerTraced, @@ -41,24 +40,24 @@ textMapToKafkaHeaders, kafkaHeadersToRequestHeaders, requestHeadersToKafkaHeaders, -) + ) where import Kafka.Effectful.OpenTelemetry.Consumer.Interpreter (runKafkaConsumerTraced) import Kafka.Effectful.OpenTelemetry.Producer.Interpreter (runKafkaProducerTraced) -import Kafka.Effectful.OpenTelemetry.Propagation ( - extractTraceContextFromRecord, +import Kafka.Effectful.OpenTelemetry.Propagation + ( extractTraceContextFromRecord, injectTraceContextIntoRecord, kafkaHeadersToRequestHeaders, kafkaHeadersToTextMap, requestHeadersToKafkaHeaders, textMapToKafkaHeaders, - ) -import Kafka.Effectful.OpenTelemetry.Semantic ( - consumerRecordAttributes, + ) +import Kafka.Effectful.OpenTelemetry.Semantic + ( consumerRecordAttributes, consumerRecordAttributesWith, consumerSpanName, producerRecordAttributes, producerRecordAttributesWith, producerSpanName, - ) + ) diff --git a/src/Kafka/Effectful/OpenTelemetry/Consumer/Interpreter.hs b/src/Kafka/Effectful/OpenTelemetry/Consumer/Interpreter.hs --- a/src/Kafka/Effectful/OpenTelemetry/Consumer/Interpreter.hs +++ b/src/Kafka/Effectful/OpenTelemetry/Consumer/Interpreter.hs @@ -4,29 +4,43 @@ -- 'interpret' to type-check. Suppress the warning at the file level. {-# OPTIONS_GHC -Wno-redundant-constraints #-} -{- | OpenTelemetry-traced interpreter for the 'KafkaConsumer' effect. - -Drop-in alternative to 'Kafka.Effectful.Consumer.Interpreter.runKafkaConsumer' -that opens a Consumer-kind span on every successful record return from -'pollMessage' \/ 'pollMessageBatch', rooted at the W3C trace context -extracted from the record\'s Kafka headers (or as a new root span when -no inbound context is present). Polls that return @Nothing@ on timeout -do not open a span, preserving the existing timeout-returns-@Nothing@ -semantics. - -Non-polling operations (offset commit, partition assignment, etc.) are -passed through unchanged. - -The design parallels the upstream -@hs-opentelemetry-instrumentation-hw-kafka-client@\'s -@OpenTelemetry.Instrumentation.Kafka.pollMessage@. - -@since 0.2.0.0 --} -module Kafka.Effectful.OpenTelemetry.Consumer.Interpreter ( - -- * Interpreter +-- | OpenTelemetry-traced interpreter for the 'KafkaConsumer' effect. +-- +-- Drop-in alternative to 'Kafka.Effectful.Consumer.Interpreter.runKafkaConsumer' +-- that opens a Consumer-kind span on every successful record return from +-- 'pollMessage' \/ 'pollMessageBatch', rooted at the W3C trace context +-- extracted from the record\'s Kafka headers (or as a new root span when +-- no inbound context is present). Polls that return @Nothing@ on timeout +-- do not open a span, preserving the existing timeout-returns-@Nothing@ +-- semantics. +-- +-- Non-polling operations (offset commit, partition assignment, etc.) are +-- passed through unchanged. +-- +-- Each record\'s context is installed only for the duration of its own span and +-- is then detached, so records never chain onto one another: a record with no +-- inbound context starts a new root even when the record before it on the same +-- thread carried a remote one. That per-record isolation is what makes the +-- \"new root span when no inbound context is present\" promise above true in +-- practice. +-- +-- Note that the span covers only the act of receiving the record, not the +-- application\'s processing of it — it is effectively a zero-duration marker at +-- the point of delivery. Covering processing would require a handler-wrapping +-- API, which is deliberately out of scope for this module. +-- +-- The design parallels the upstream +-- @hs-opentelemetry-instrumentation-hw-kafka-client@\'s +-- @OpenTelemetry.Instrumentation.Kafka.pollMessage@. +-- +-- @since 0.2.0.0 +module Kafka.Effectful.OpenTelemetry.Consumer.Interpreter + ( -- * Interpreter runKafkaConsumerTraced, -) + + -- * Internal — exported for tests + withConsumerSpan, + ) where import Control.Monad (void) @@ -43,157 +57,199 @@ import Kafka.Consumer.ConsumerProperties (ConsumerProperties) import Kafka.Consumer.Subscription (Subscription) import Kafka.Consumer.Types (ConsumerRecord (crTopic)) +import Kafka.Effectful.Consumer.Classify + ( PollErrorDisposition (..), + classifyPollError, + isBenignCommitError, + ) import Kafka.Effectful.Consumer.Effect (KafkaConsumer (..)) -import Kafka.Effectful.OpenTelemetry.Propagation ( - extractTraceContextFromRecord, - ) -import Kafka.Effectful.OpenTelemetry.Semantic ( - consumerRecordAttributesWith, +import Kafka.Effectful.OpenTelemetry.Propagation + ( extractTraceContextFromRecord, + ) +import Kafka.Effectful.OpenTelemetry.Semantic + ( consumerRecordAttributesWith, consumerSpanName, - ) + ) import Kafka.Types (KafkaError (..)) -import OpenTelemetry.Context.ThreadLocal (attachContext, getContext) +import OpenTelemetry.Context qualified as Context +import OpenTelemetry.Context.ThreadLocal (attachContext, detachContext) import OpenTelemetry.SemanticsConfig (getSemanticsOptions, lookupStability) -import OpenTelemetry.Trace.Core ( - SpanArguments (kind), +import OpenTelemetry.Trace.Core + ( SpanArguments (kind), SpanKind (Consumer), Tracer, addAttributesToSpanArguments, defaultSpanArguments, inSpan'', - ) - -{- | Run the 'KafkaConsumer' effect with OpenTelemetry tracing. - -Identical in shape to 'Kafka.Effectful.Consumer.Interpreter.runKafkaConsumer', -plus an additional 'Tracer' argument. On every successful record return -from 'pollMessage' \/ 'pollMessageBatch' the interpreter: - -* extracts a W3C trace context from the record\'s headers and - attaches it as the current thread\'s 'OpenTelemetry.Context.Context'; -* opens a Consumer-kind span named @\"process \\"@, - populated with the spec-aligned @messaging.*@ attribute set plus - the @messaging.kafka.consumer.group@ attribute (read from the - @group.id@ entry of the supplied 'ConsumerProperties'). - -Polls that time out (return @Nothing@) do not open a span. Per-record -errors in batch polls (@Left err@ entries) are kept in place in the -returned list and do not get spans either. The consumer handle is -acquired and released via 'Exception.generalBracket', exactly as -'runKafkaConsumer' does. + ) -@since 0.2.0.0 --} +-- | Run the 'KafkaConsumer' effect with OpenTelemetry tracing. +-- +-- Identical in shape to 'Kafka.Effectful.Consumer.Interpreter.runKafkaConsumer', +-- plus an additional 'Tracer' argument. On every successful record return +-- from 'pollMessage' \/ 'pollMessageBatch' the interpreter: +-- +-- * extracts a W3C trace context from the record\'s headers and +-- attaches it as the current thread\'s 'OpenTelemetry.Context.Context'; +-- * opens a Consumer-kind span named @\"process \\"@, +-- populated with the spec-aligned @messaging.*@ attribute set plus +-- the @messaging.kafka.consumer.group@ attribute (read from the +-- @group.id@ entry of the supplied 'ConsumerProperties'). +-- +-- Polls that time out (return @Nothing@) do not open a span. Per-record +-- errors in batch polls (@Left err@ entries) are kept in place in the +-- returned list and do not get spans either. The consumer handle is +-- acquired and released via 'Exception.generalBracket', exactly as +-- 'runKafkaConsumer' does. +-- +-- @since 0.2.0.0 runKafkaConsumerTraced :: - (IOE :> es, Error KafkaError :> es) => - Tracer -> - ConsumerProperties -> - Subscription -> - Eff (KafkaConsumer : es) a -> - Eff es a + (IOE :> es, Error KafkaError :> es) => + Tracer -> + ConsumerProperties -> + Subscription -> + Eff (KafkaConsumer : es) a -> + Eff es a runKafkaConsumerTraced tracer props sub action = - fst - <$> Exception.generalBracket - acquire - release - ( \consumer -> - interpret (handleTracedConsumer tracer props consumer) action - ) + fst + <$> Exception.generalBracket + acquire + release + ( \consumer -> + interpret (handleTracedConsumer tracer props consumer) action + ) where acquire = do - result <- Effectful.liftIO $ K.newConsumer props sub - case result of - Left err -> throwError err - Right consumer -> pure consumer + result <- Effectful.liftIO $ K.newConsumer props sub + case result of + Left err -> throwError err + Right consumer -> pure consumer release consumer = \case - ExitCaseSuccess _ -> do - mbErr <- Effectful.liftIO $ K.closeConsumer consumer - for_ mbErr throwError - ExitCaseException _ -> - Effectful.liftIO . void $ K.closeConsumer consumer - ExitCaseAbort -> - Effectful.liftIO . void $ K.closeConsumer consumer + ExitCaseSuccess _ -> do + mbErr <- Effectful.liftIO $ K.closeConsumer consumer + for_ mbErr throwError + ExitCaseException _ -> + Effectful.liftIO . void $ K.closeConsumer consumer + ExitCaseAbort -> + Effectful.liftIO . void $ K.closeConsumer consumer handleTracedConsumer :: - (IOE :> es, Error KafkaError :> es) => - Tracer -> - ConsumerProperties -> - K.KafkaConsumer -> - EffectHandler KafkaConsumer es + (IOE :> es, Error KafkaError :> es) => + Tracer -> + ConsumerProperties -> + K.KafkaConsumer -> + EffectHandler KafkaConsumer es handleTracedConsumer tracer props consumer _env = \case - PollMessage timeout -> do - result <- Effectful.liftIO $ K.pollMessage consumer timeout - case result of - Left (KafkaResponseError RdKafkaRespErrTimedOut) -> pure Nothing - Left err -> throwError err - Right cr -> Just <$> withConsumerSpan tracer props cr (pure cr) - PollMessageBatch timeout batchSize -> do - results <- - Effectful.liftIO $ - K.pollMessageBatch consumer timeout batchSize - traverse openSpanForResult results - where - openSpanForResult (Left err) = pure (Left err) - openSpanForResult (Right cr) = - Right <$> withConsumerSpan tracer props cr (pure cr) - CommitOffsetMessage oc cr -> throwOnJust $ K.commitOffsetMessage oc consumer cr - CommitAllOffsets oc -> throwOnJust $ K.commitAllOffsets oc consumer - CommitPartitionsOffsets oc tps -> throwOnJust $ K.commitPartitionsOffsets oc consumer tps - StoreOffsets tps -> throwOnJust $ K.storeOffsets consumer tps - StoreOffsetMessage cr -> throwOnJust $ K.storeOffsetMessage consumer cr - Assign tps -> throwOnJust $ K.assign consumer tps - PausePartitions parts -> - throwOnKafkaErr (K.pausePartitions consumer parts) - ResumePartitions parts -> - throwOnKafkaErr (K.resumePartitions consumer parts) - SeekPartitions tps timeout -> throwOnJust $ K.seekPartitions consumer tps timeout - Committed timeout parts -> throwOnLeft $ K.committed consumer timeout parts - Position parts -> throwOnLeft $ K.position consumer parts - Assignment -> throwOnLeft $ K.assignment consumer - Subscription -> throwOnLeft $ K.subscription consumer - AskConsumerHandle -> pure consumer + PollMessage timeout -> do + result <- Effectful.liftIO $ K.pollMessage consumer timeout + case result of + Left err -> case classifyPollError err of + PollTimeout -> pure Nothing + PollBenign -> pure Nothing + PollThrow -> throwError err + Right cr -> Just <$> withConsumerSpan tracer props cr (pure cr) + PollMessageEither timeout -> do + result <- Effectful.liftIO $ K.pollMessage consumer timeout + case result of + Left err -> pure (Left err) + Right cr -> Right <$> withConsumerSpan tracer props cr (pure cr) + PollMessageBatch timeout batchSize -> do + results <- + Effectful.liftIO $ + K.pollMessageBatch consumer timeout batchSize + traverse openSpanForResult results + where + openSpanForResult (Left err) = pure (Left err) + openSpanForResult (Right cr) = + Right <$> withConsumerSpan tracer props cr (pure cr) + CommitOffsetMessage oc cr -> throwOnJustCommit $ K.commitOffsetMessage oc consumer cr + CommitAllOffsets oc -> throwOnJustCommit $ K.commitAllOffsets oc consumer + CommitPartitionsOffsets oc tps -> throwOnJustCommit $ K.commitPartitionsOffsets oc consumer tps + StoreOffsets tps -> throwOnJust $ K.storeOffsets consumer tps + StoreOffsetMessage cr -> throwOnJust $ K.storeOffsetMessage consumer cr + Assign tps -> throwOnJust $ K.assign consumer tps + PausePartitions parts -> + throwOnKafkaErr (K.pausePartitions consumer parts) + ResumePartitions parts -> + throwOnKafkaErr (K.resumePartitions consumer parts) + SeekPartitions tps timeout -> throwOnJust $ K.seekPartitions consumer tps timeout + Committed timeout parts -> throwOnLeft $ K.committed consumer timeout parts + Position parts -> throwOnLeft $ K.position consumer parts + Assignment -> throwOnLeft $ K.assignment consumer + Subscription -> throwOnLeft $ K.subscription consumer + AskConsumerHandle -> pure consumer where throwOnJust action' = do - mbErr <- Effectful.liftIO action' - for_ mbErr throwError + mbErr <- Effectful.liftIO action' + for_ mbErr throwError + -- Commits get their own thrower: "nothing to commit" is a success. + throwOnJustCommit action' = do + mbErr <- Effectful.liftIO action' + for_ mbErr $ \err -> + if isBenignCommitError err then pure () else throwError err + throwOnLeft action' = do - result <- Effectful.liftIO action' - case result of - Left err -> throwError err - Right a -> pure a + result <- Effectful.liftIO action' + case result of + Left err -> throwError err + Right a -> pure a throwOnKafkaErr action' = do - err <- Effectful.liftIO action' - case err of - KafkaResponseError RdKafkaRespErrNoError -> pure () - _ -> throwError err - -{- | Open a Consumer-kind span around an action that processes a single -record. + err <- Effectful.liftIO action' + case err of + KafkaResponseError RdKafkaRespErrNoError -> pure () + _ -> throwError err -Extracts the W3C trace context from the record\'s headers, attaches -it as the current thread context, then opens a span named -@\"process \\"@ populated with the @messaging.*@ attribute -set (including @messaging.kafka.consumer.group@ when known). --} +-- | Open a Consumer-kind span around an action that processes a single +-- record. +-- +-- Extracts the W3C trace context from the record\'s headers, installs it as +-- the current thread context for the duration, then opens a span named +-- @\"process \\"@ populated with the @messaging.*@ attribute +-- set (including @messaging.kafka.consumer.group@ when known). +-- +-- Two details of the context handling are load-bearing. +-- +-- The record\'s headers are extracted into 'Context.empty', /not/ into the +-- ambient thread-local context. That is what makes \"no headers → new root +-- span\" actually true. Extracting into the ambient context instead would +-- inherit whatever happens to be installed, which — immediately after another +-- traced record on the same thread — is that record\'s remote context, silently +-- chaining unrelated messages into one trace. +-- +-- The attach is paired with its 'detachContext' token in a bracket, so the +-- caller\'s ambient context is restored however this returns. Without that, the +-- last record\'s context stays installed on the thread forever: it leaks into +-- subsequent records, into the rest of the batch walk, and into whatever the +-- application does after the poll. +-- +-- Note that the span covers only the supplied action, which at both call sites +-- is @pure cr@ — so it is effectively a zero-duration marker at the point the +-- record was received, not a measurement of how long the record took to +-- process. Covering user processing would need a handler-wrapping API and is +-- deliberately out of scope here. withConsumerSpan :: - (IOE :> es) => - Tracer -> - ConsumerProperties -> - ConsumerRecord (Maybe ByteString) (Maybe ByteString) -> - Eff es a -> - Eff es a + (IOE :> es) => + Tracer -> + ConsumerProperties -> + ConsumerRecord (Maybe ByteString) (Maybe ByteString) -> + Eff es a -> + Eff es a withConsumerSpan tracer props cr action = do - semOpts <- Effectful.liftIO $ lookupStability "messaging" <$> getSemanticsOptions - inboundCtx <- Effectful.liftIO $ do - currentCtx <- getContext - extractTraceContextFromRecord cr currentCtx - void $ attachContext inboundCtx - inSpan'' tracer (consumerSpanName (crTopic cr)) (spanArgs semOpts) $ \_span -> action + semOpts <- Effectful.liftIO $ lookupStability "messaging" <$> getSemanticsOptions + inboundCtx <- + Effectful.liftIO $ extractTraceContextFromRecord cr Context.empty + Exception.bracket + (attachContext inboundCtx) + detachContext + ( \_token -> + inSpan'' tracer (consumerSpanName (crTopic cr)) (spanArgs semOpts) $ + \_span -> action + ) where spanArgs semOpts = - addAttributesToSpanArguments - (consumerRecordAttributesWith semOpts props cr) - defaultSpanArguments{kind = Consumer} + addAttributesToSpanArguments + (consumerRecordAttributesWith semOpts props cr) + defaultSpanArguments {kind = Consumer} diff --git a/src/Kafka/Effectful/OpenTelemetry/Producer/Interpreter.hs b/src/Kafka/Effectful/OpenTelemetry/Producer/Interpreter.hs --- a/src/Kafka/Effectful/OpenTelemetry/Producer/Interpreter.hs +++ b/src/Kafka/Effectful/OpenTelemetry/Producer/Interpreter.hs @@ -4,30 +4,29 @@ -- 'interpret' to type-check. Suppress the warning at the file level. {-# OPTIONS_GHC -Wno-redundant-constraints #-} -{- | OpenTelemetry-traced interpreter for the 'KafkaProducer' effect. - -Drop-in alternative to 'Kafka.Effectful.Producer.Interpreter.runKafkaProducer' -that opens a Producer-kind span around every record-sending operation -('produceMessage', 'produceMessage'', 'produceMessageSync', -'produceMessageBatch'), populates the span with the spec-aligned -@messaging.*@ attribute set, and injects the current OTel context as -W3C @traceparent@\/@tracestate@ headers on the record before handing -it off to the underlying @hw-kafka-client@ produce call. - -Non-sending operations (flush, transactional begin\/commit\/abort, etc.) -are passed through unchanged — they do not represent message sends and -therefore do not get a span. - -The design parallels the upstream -@hs-opentelemetry-instrumentation-hw-kafka-client@\'s -@OpenTelemetry.Instrumentation.Kafka.produceMessage@. - -@since 0.2.0.0 --} -module Kafka.Effectful.OpenTelemetry.Producer.Interpreter ( - -- * Interpreter +-- | OpenTelemetry-traced interpreter for the 'KafkaProducer' effect. +-- +-- Drop-in alternative to 'Kafka.Effectful.Producer.Interpreter.runKafkaProducer' +-- that opens a Producer-kind span around every record-sending operation +-- ('produceMessage', 'produceMessage'', 'produceMessageSync', +-- 'produceMessageBatch'), populates the span with the spec-aligned +-- @messaging.*@ attribute set, and injects the current OTel context as +-- W3C @traceparent@\/@tracestate@ headers on the record before handing +-- it off to the underlying @hw-kafka-client@ produce call. +-- +-- Non-sending operations (flush, transactional begin\/commit\/abort, etc.) +-- are passed through unchanged — they do not represent message sends and +-- therefore do not get a span. +-- +-- The design parallels the upstream +-- @hs-opentelemetry-instrumentation-hw-kafka-client@\'s +-- @OpenTelemetry.Instrumentation.Kafka.produceMessage@. +-- +-- @since 0.2.0.0 +module Kafka.Effectful.OpenTelemetry.Producer.Interpreter + ( -- * Interpreter runKafkaProducerTraced, -) + ) where import Control.Concurrent.MVar qualified as Concurrent @@ -38,13 +37,13 @@ import Effectful.Dispatch.Dynamic (EffectHandler, interpret) import Effectful.Error.Static (Error, throwError) import Effectful.Exception qualified as Exception -import Kafka.Effectful.OpenTelemetry.Propagation ( - injectTraceContextIntoRecord, - ) -import Kafka.Effectful.OpenTelemetry.Semantic ( - producerRecordAttributesWith, +import Kafka.Effectful.OpenTelemetry.Propagation + ( injectTraceContextIntoRecord, + ) +import Kafka.Effectful.OpenTelemetry.Semantic + ( producerRecordAttributesWith, producerSpanName, - ) + ) import Kafka.Effectful.Producer.Effect (KafkaProducer (..)) import Kafka.Producer (ProducerRecord (prTopic)) import Kafka.Producer qualified as K @@ -56,8 +55,8 @@ import OpenTelemetry.Context.ThreadLocal (getContext) import OpenTelemetry.SemanticConventions (error_type) import OpenTelemetry.SemanticsConfig (getSemanticsOptions, lookupStability) -import OpenTelemetry.Trace.Core ( - Span, +import OpenTelemetry.Trace.Core + ( Span, SpanArguments (kind), SpanKind (Producer), SpanStatus (Error), @@ -67,156 +66,154 @@ defaultSpanArguments, inSpan'', setStatus, - ) - -{- | Run the 'KafkaProducer' effect with OpenTelemetry tracing. - -Identical in shape to 'Kafka.Effectful.Producer.Interpreter.runKafkaProducer', -plus an additional 'Tracer' argument used to open a Producer-kind -span around every record-sending operation. The current -'OpenTelemetry.Context.Context' is injected as W3C trace-context -headers on the outgoing record before the underlying -@hw-kafka-client@ produce call runs, so that downstream consumers -can extract the context and continue the trace. - -The producer handle is acquired and released via 'Exception.bracket', -exactly as 'runKafkaProducer' does. Errors are thrown via the -'Error' effect. + ) -@since 0.2.0.0 --} +-- | Run the 'KafkaProducer' effect with OpenTelemetry tracing. +-- +-- Identical in shape to 'Kafka.Effectful.Producer.Interpreter.runKafkaProducer', +-- plus an additional 'Tracer' argument used to open a Producer-kind +-- span around every record-sending operation. The current +-- 'OpenTelemetry.Context.Context' is injected as W3C trace-context +-- headers on the outgoing record before the underlying +-- @hw-kafka-client@ produce call runs, so that downstream consumers +-- can extract the context and continue the trace. +-- +-- The producer handle is acquired and released via 'Exception.bracket', +-- exactly as 'runKafkaProducer' does. Errors are thrown via the +-- 'Error' effect. +-- +-- @since 0.2.0.0 runKafkaProducerTraced :: - (IOE :> es, Error KafkaError :> es) => - Tracer -> - ProducerProperties -> - Eff (KafkaProducer : es) a -> - Eff es a + (IOE :> es, Error KafkaError :> es) => + Tracer -> + ProducerProperties -> + Eff (KafkaProducer : es) a -> + Eff es a runKafkaProducerTraced tracer props action = - Exception.bracket - acquire - (Effectful.liftIO . K.closeProducer) - (\producer -> interpret (handleTracedProducer tracer producer) action) + Exception.bracket + acquire + (Effectful.liftIO . K.closeProducer) + (\producer -> interpret (handleTracedProducer tracer producer) action) where acquire = do - result <- Effectful.liftIO $ K.newProducer props - case result of - Left err -> throwError err - Right producer -> pure producer + result <- Effectful.liftIO $ K.newProducer props + case result of + Left err -> throwError err + Right producer -> pure producer handleTracedProducer :: - (IOE :> es, Error KafkaError :> es) => - Tracer -> - K.KafkaProducer -> - EffectHandler KafkaProducer es + (IOE :> es, Error KafkaError :> es) => + Tracer -> + K.KafkaProducer -> + EffectHandler KafkaProducer es handleTracedProducer tracer producer _env = \case - ProduceMessage record -> - withProducerSpan tracer record $ \span_ instrumentedRecord -> do - mbErr <- Effectful.liftIO $ K.produceMessage producer instrumentedRecord - for_ mbErr $ \err -> do - recordKafkaError span_ err - throwError err - ProduceMessage' record cb -> - withProducerSpan tracer record $ \span_ instrumentedRecord -> do - res <- - Effectful.liftIO $ - K.produceMessage' producer instrumentedRecord cb - case res of - Left (K.ImmediateError err) -> do - recordKafkaError span_ err - throwError err - Right () -> pure () - ProduceMessageSync record -> - withProducerSpan tracer record $ \span_ instrumentedRecord -> do - var <- Effectful.liftIO Concurrent.newEmptyMVar - res <- - Effectful.liftIO $ - K.produceMessage' producer instrumentedRecord (Concurrent.putMVar var) - case res of - Left (K.ImmediateError err) -> do - recordKafkaError span_ err - throwError err - Right () -> do - Effectful.liftIO $ K.flushProducer producer - report <- Effectful.liftIO $ Concurrent.takeMVar var - case report of - K.DeliverySuccess _ offset -> pure offset - K.DeliveryFailure _ err -> do - recordKafkaError span_ err - throwError err - K.NoMessageError err -> do - recordKafkaError span_ err - throwError err - ProduceMessageBatch records -> do - -- One span per record so the Producer-kind attributes - -- (partition, key) are per-record, matching the upstream - -- reference. Spans are opened sequentially as the list is - -- traversed. - results <- - traverse - ( \r -> - withProducerSpan tracer r $ \span_ instrumentedRecord -> do - mbErr <- - Effectful.liftIO $ - K.produceMessage producer instrumentedRecord - for_ mbErr (recordKafkaError span_) - pure (r, mbErr) - ) - records - pure [(r, err) | (r, Just err) <- results] - FlushProducer -> - Effectful.liftIO $ K.flushProducer producer - InitTransactions timeout -> - throwOnJust $ K.initTransactions producer timeout - BeginTransaction -> - throwOnJust $ K.beginTransaction producer - CommitTransaction timeout -> - Effectful.liftIO $ K.commitTransaction producer timeout - AbortTransaction timeout -> - throwOnJust $ K.abortTransaction producer timeout - SendOffsetsToTransaction consumer record timeout -> + ProduceMessage record -> + withProducerSpan tracer record $ \span_ instrumentedRecord -> do + mbErr <- Effectful.liftIO $ K.produceMessage producer instrumentedRecord + for_ mbErr $ \err -> do + recordKafkaError span_ err + throwError err + ProduceMessage' record cb -> + withProducerSpan tracer record $ \span_ instrumentedRecord -> do + res <- Effectful.liftIO $ - K.commitOffsetMessageTransaction producer consumer record timeout - AskProducerHandle -> - pure producer + K.produceMessage' producer instrumentedRecord cb + case res of + Left (K.ImmediateError err) -> do + recordKafkaError span_ err + throwError err + Right () -> pure () + ProduceMessageSync record -> + withProducerSpan tracer record $ \span_ instrumentedRecord -> do + var <- Effectful.liftIO Concurrent.newEmptyMVar + res <- + Effectful.liftIO $ + K.produceMessage' producer instrumentedRecord (Concurrent.putMVar var) + case res of + Left (K.ImmediateError err) -> do + recordKafkaError span_ err + throwError err + Right () -> do + Effectful.liftIO $ K.flushProducer producer + report <- Effectful.liftIO $ Concurrent.takeMVar var + case report of + K.DeliverySuccess _ offset -> pure offset + K.DeliveryFailure _ err -> do + recordKafkaError span_ err + throwError err + K.NoMessageError err -> do + recordKafkaError span_ err + throwError err + ProduceMessageBatch records -> do + -- One span per record so the Producer-kind attributes + -- (partition, key) are per-record, matching the upstream + -- reference. Spans are opened sequentially as the list is + -- traversed. + results <- + traverse + ( \r -> + withProducerSpan tracer r $ \span_ instrumentedRecord -> do + mbErr <- + Effectful.liftIO $ + K.produceMessage producer instrumentedRecord + for_ mbErr (recordKafkaError span_) + pure (r, mbErr) + ) + records + pure [(r, err) | (r, Just err) <- results] + FlushProducer -> + Effectful.liftIO $ K.flushProducer producer + InitTransactions timeout -> + throwOnJust $ K.initTransactions producer timeout + BeginTransaction -> + throwOnJust $ K.beginTransaction producer + CommitTransaction timeout -> + Effectful.liftIO $ K.commitTransaction producer timeout + AbortTransaction timeout -> + throwOnJust $ K.abortTransaction producer timeout + SendOffsetsToTransaction consumer record timeout -> + Effectful.liftIO $ + K.commitOffsetMessageTransaction producer consumer record timeout + AskProducerHandle -> + pure producer where throwOnJust action' = do - mbErr <- Effectful.liftIO action' - for_ mbErr throwError - -{- | Open a Producer-kind span around a record-sending action. + mbErr <- Effectful.liftIO action' + for_ mbErr throwError -Builds the @messaging.*@ attribute set from the record, opens a -span named @\"send \\"@, injects the current OTel context -as W3C trace-context headers onto a clone of the record, and runs -the supplied action with that instrumented record. --} +-- | Open a Producer-kind span around a record-sending action. +-- +-- Builds the @messaging.*@ attribute set from the record, opens a +-- span named @\"send \\"@, injects the current OTel context +-- as W3C trace-context headers onto a clone of the record, and runs +-- the supplied action with that instrumented record. withProducerSpan :: - (IOE :> es) => - Tracer -> - ProducerRecord -> - (Span -> ProducerRecord -> Eff es a) -> - Eff es a + (IOE :> es) => + Tracer -> + ProducerRecord -> + (Span -> ProducerRecord -> Eff es a) -> + Eff es a withProducerSpan tracer record action = do - semOpts <- Effectful.liftIO $ lookupStability "messaging" <$> getSemanticsOptions - inSpan'' tracer (producerSpanName (prTopic record)) (spanArgs semOpts) $ \newSpan -> do - ctx <- getContext - instrumentedRecord <- - Effectful.liftIO $ - injectTraceContextIntoRecord (Context.insertSpan newSpan ctx) record - action newSpan instrumentedRecord + semOpts <- Effectful.liftIO $ lookupStability "messaging" <$> getSemanticsOptions + inSpan'' tracer (producerSpanName (prTopic record)) (spanArgs semOpts) $ \newSpan -> do + ctx <- getContext + instrumentedRecord <- + Effectful.liftIO $ + injectTraceContextIntoRecord (Context.insertSpan newSpan ctx) record + action newSpan instrumentedRecord where spanArgs semOpts = - addAttributesToSpanArguments - (producerRecordAttributesWith semOpts record) - defaultSpanArguments{kind = Producer} + addAttributesToSpanArguments + (producerRecordAttributesWith semOpts record) + defaultSpanArguments {kind = Producer} recordKafkaError :: - (IOE :> es) => - Span -> - KafkaError -> - Eff es () + (IOE :> es) => + Span -> + KafkaError -> + Eff es () recordKafkaError span_ err = do - let errText = Text.pack (show err) - Effectful.liftIO $ do - addAttribute span_ (unkey error_type) errText - setStatus span_ (Error errText) + let errText = Text.pack (show err) + Effectful.liftIO $ do + addAttribute span_ (unkey error_type) errText + setStatus span_ (Error errText) diff --git a/src/Kafka/Effectful/OpenTelemetry/Propagation.hs b/src/Kafka/Effectful/OpenTelemetry/Propagation.hs --- a/src/Kafka/Effectful/OpenTelemetry/Propagation.hs +++ b/src/Kafka/Effectful/OpenTelemetry/Propagation.hs @@ -1,16 +1,15 @@ -{- | Bridges between @hw-kafka-client@\'s 'Kafka.Types.Headers' and -OpenTelemetry propagation carriers, plus convenience helpers that -fetch the global propagator and inject\/extract trace context against -a record\'s headers in one call. - -The traced interpreters use the @hs-opentelemetry-api@ 1.0 -'TextMap' carrier. The older @http-types@ 'RequestHeaders' helpers -remain available for users who imported them directly. - -@since 0.2.0.0 --} -module Kafka.Effectful.OpenTelemetry.Propagation ( - -- * Header bridges +-- | Bridges between @hw-kafka-client@\'s 'Kafka.Types.Headers' and +-- OpenTelemetry propagation carriers, plus convenience helpers that +-- fetch the global propagator and inject\/extract trace context against +-- a record\'s headers in one call. +-- +-- The traced interpreters use the @hs-opentelemetry-api@ 1.0 +-- 'TextMap' carrier. The older @http-types@ 'RequestHeaders' helpers +-- remain available for users who imported them directly. +-- +-- @since 0.2.0.0 +module Kafka.Effectful.OpenTelemetry.Propagation + ( -- * Header bridges kafkaHeadersToTextMap, textMapToKafkaHeaders, kafkaHeadersToRequestHeaders, @@ -19,107 +18,127 @@ -- * W3C trace-context round-trip extractTraceContextFromRecord, injectTraceContextIntoRecord, -) + ) where import Data.Bifunctor (first) import Data.CaseInsensitive qualified as CI +import Data.Text qualified as Text import Data.Text.Encoding qualified as Text import Kafka.Consumer.Types (ConsumerRecord (crHeaders)) import Kafka.Producer.Types (ProducerRecord (prHeaders)) import Kafka.Types (Headers, headersFromList, headersToList) import Network.HTTP.Types (RequestHeaders) import OpenTelemetry.Context (Context) -import OpenTelemetry.Propagator ( - TextMap, +import OpenTelemetry.Propagator + ( TextMap, emptyTextMap, extract, getGlobalTextMapPropagator, inject, + propagatorFields, textMapFromList, textMapToList, - ) - -{- | Convert @hw-kafka-client@ 'Headers' to the OpenTelemetry 1.0 -'TextMap' propagation carrier. + ) -Header names and values are decoded as UTF-8, matching upstream -@hs-opentelemetry-instrumentation-hw-kafka-client@ 1.0. --} +-- | Convert @hw-kafka-client@ 'Headers' to the OpenTelemetry 1.0 +-- 'TextMap' propagation carrier. +-- +-- Header names and values are decoded as UTF-8 /leniently/: bytes that are not +-- valid UTF-8 become the replacement character @U+FFFD@ rather than raising. +-- This deliberately diverges from upstream +-- @hs-opentelemetry-instrumentation-hw-kafka-client@ 1.0, which decodes +-- partially. Kafka headers are arbitrary bytes and applications routinely put +-- non-text payloads in them; a partial decode turns one such header into an +-- exception that propagates out of carrier construction and costs the record +-- its entire inbound trace context. kafkaHeadersToTextMap :: Headers -> TextMap kafkaHeadersToTextMap = - textMapFromList - . map - ( \(k, v) -> - (Text.decodeUtf8 k, Text.decodeUtf8 v) - ) - . headersToList + textMapFromList + . map + ( \(k, v) -> + (Text.decodeUtf8Lenient k, Text.decodeUtf8Lenient v) + ) + . headersToList -{- | Convert the OpenTelemetry 1.0 'TextMap' propagation carrier back -to @hw-kafka-client@ 'Headers'. --} +-- | Convert the OpenTelemetry 1.0 'TextMap' propagation carrier back +-- to @hw-kafka-client@ 'Headers'. textMapToKafkaHeaders :: TextMap -> Headers textMapToKafkaHeaders = - headersFromList - . map - ( \(k, v) -> - (Text.encodeUtf8 k, Text.encodeUtf8 v) - ) - . textMapToList + headersFromList + . map + ( \(k, v) -> + (Text.encodeUtf8 k, Text.encodeUtf8 v) + ) + . textMapToList -{- | Convert @hw-kafka-client@ 'Headers' (case-sensitive) to -@http-types@ 'RequestHeaders' (case-insensitive). Each -@(bsKey, bsVal)@ becomes @(CI.mk bsKey, bsVal)@. --} +-- | Convert @hw-kafka-client@ 'Headers' (case-sensitive) to +-- @http-types@ 'RequestHeaders' (case-insensitive). Each +-- @(bsKey, bsVal)@ becomes @(CI.mk bsKey, bsVal)@. kafkaHeadersToRequestHeaders :: Headers -> RequestHeaders kafkaHeadersToRequestHeaders = map (first CI.mk) . headersToList -{- | Convert @http-types@ 'RequestHeaders' (case-insensitive) back to -@hw-kafka-client@ 'Headers' (case-sensitive). The -'CI.foldedCase' lower-case form of each key is used as the -resulting Kafka header key. --} +-- | Convert @http-types@ 'RequestHeaders' (case-insensitive) back to +-- @hw-kafka-client@ 'Headers' (case-sensitive). The +-- 'CI.foldedCase' lower-case form of each key is used as the +-- resulting Kafka header key. requestHeadersToKafkaHeaders :: RequestHeaders -> Headers requestHeadersToKafkaHeaders = headersFromList . map (first CI.foldedCase) -{- | Extract a W3C trace context from a 'ConsumerRecord'\'s headers -and merge it into the supplied 'Context'. - -This fetches the global text-map propagator, hands it the record\'s -headers, and returns the resulting 'Context'. If the record carries -no @traceparent@ header the propagator returns the input 'Context' -unchanged. - -This is the building block that the traced consumer interpreter uses -to root a per-message Consumer-kind span at the inbound trace -context. --} +-- | Extract a W3C trace context from a 'ConsumerRecord'\'s headers +-- and merge it into the supplied 'Context'. +-- +-- This fetches the global text-map propagator, hands it the record\'s +-- headers, and returns the resulting 'Context'. If the record carries +-- no @traceparent@ header the propagator returns the input 'Context' +-- unchanged. +-- +-- Only the headers the configured propagator actually declares — via +-- 'propagatorFields', typically @traceparent@, @tracestate@ and @baggage@ — +-- are put into the carrier. Application payload headers are never handed to +-- the propagator, so their contents cannot affect trace extraction. Filtering +-- by the propagator\'s own field list rather than a hard-coded set keeps custom +-- propagator stacks working. +-- +-- This is the building block that the traced consumer interpreter uses +-- to root a per-message Consumer-kind span at the inbound trace +-- context. extractTraceContextFromRecord :: - ConsumerRecord k v -> - Context -> - IO Context + ConsumerRecord k v -> + Context -> + IO Context extractTraceContextFromRecord record ctx = do - propagator <- getGlobalTextMapPropagator - extract propagator (kafkaHeadersToTextMap (crHeaders record)) ctx - -{- | Inject the supplied 'Context'\'s W3C trace context into a -'ProducerRecord'\'s headers, returning the augmented record. - -Existing headers on the record are preserved; the propagator-emitted -headers (typically @traceparent@ and optionally @tracestate@) are -appended via 'Headers'\'s 'Semigroup' instance. The original record is -not mutated. + propagator <- getGlobalTextMapPropagator + -- 'TextMap' looks keys up case-insensitively, so the filter must match + -- case-insensitively too or a header spelled "TraceParent" -- which used + -- to resolve fine -- would be dropped before the propagator ever saw it. + let fields = map Text.toLower (propagatorFields propagator) + carrier = + textMapFromList + [ (key, Text.decodeUtf8Lenient value) + | (rawKey, value) <- headersToList (crHeaders record), + let key = Text.decodeUtf8Lenient rawKey, + Text.toLower key `elem` fields + ] + extract propagator carrier ctx -This is the building block that the traced producer interpreter uses -to publish the current span\'s context on the wire so that downstream -consumers can extract it and continue the trace. --} +-- | Inject the supplied 'Context'\'s W3C trace context into a +-- 'ProducerRecord'\'s headers, returning the augmented record. +-- +-- Existing headers on the record are preserved; the propagator-emitted +-- headers (typically @traceparent@ and optionally @tracestate@) are +-- appended via 'Headers'\'s 'Semigroup' instance. The original record is +-- not mutated. +-- +-- This is the building block that the traced producer interpreter uses +-- to publish the current span\'s context on the wire so that downstream +-- consumers can extract it and continue the trace. injectTraceContextIntoRecord :: - Context -> - ProducerRecord -> - IO ProducerRecord + Context -> + ProducerRecord -> + IO ProducerRecord injectTraceContextIntoRecord ctx record = do - propagator <- getGlobalTextMapPropagator - extraHeaders <- inject propagator ctx emptyTextMap - let merged = prHeaders record <> textMapToKafkaHeaders extraHeaders - pure record{prHeaders = merged} + propagator <- getGlobalTextMapPropagator + extraHeaders <- inject propagator ctx emptyTextMap + let merged = prHeaders record <> textMapToKafkaHeaders extraHeaders + pure record {prHeaders = merged} diff --git a/src/Kafka/Effectful/OpenTelemetry/Semantic.hs b/src/Kafka/Effectful/OpenTelemetry/Semantic.hs --- a/src/Kafka/Effectful/OpenTelemetry/Semantic.hs +++ b/src/Kafka/Effectful/OpenTelemetry/Semantic.hs @@ -1,30 +1,29 @@ -{- | Pure helpers that translate Kafka producer and consumer records -into the OpenTelemetry messaging-semantic-conventions attribute set. - -The functions here do not perform any I\/O and do not depend on a -'OpenTelemetry.Trace.Core.Tracer'. They exist as building blocks for -the traced interpreters in -"Kafka.Effectful.OpenTelemetry.Producer.Interpreter" and -"Kafka.Effectful.OpenTelemetry.Consumer.Interpreter", and are also -exposed so users who want to write a custom interpreter or a -framework wrapper can produce the same spec-aligned attribute set -without having to redefine the keys themselves. - -The attribute keys and value types follow the OpenTelemetry messaging -semantic conventions v1.40 as exposed by -@hs-opentelemetry-semantic-conventions@. Operation and consumer-group -keys follow @hs-opentelemetry-api@ 1.0\'s stability opt-in policy: -legacy by default, stable with @OTEL_SEMCONV_STABILITY_OPT_IN=messaging@, -and both with @OTEL_SEMCONV_STABILITY_OPT_IN=messaging\/dup@. - -The design parallels the upstream -@hs-opentelemetry-instrumentation-hw-kafka-client@\'s -@OpenTelemetry.Instrumentation.Kafka@ module. - -@since 0.2.0.0 --} -module Kafka.Effectful.OpenTelemetry.Semantic ( - -- * Constants +-- | Pure helpers that translate Kafka producer and consumer records +-- into the OpenTelemetry messaging-semantic-conventions attribute set. +-- +-- The functions here do not perform any I\/O and do not depend on a +-- 'OpenTelemetry.Trace.Core.Tracer'. They exist as building blocks for +-- the traced interpreters in +-- "Kafka.Effectful.OpenTelemetry.Producer.Interpreter" and +-- "Kafka.Effectful.OpenTelemetry.Consumer.Interpreter", and are also +-- exposed so users who want to write a custom interpreter or a +-- framework wrapper can produce the same spec-aligned attribute set +-- without having to redefine the keys themselves. +-- +-- The attribute keys and value types follow the OpenTelemetry messaging +-- semantic conventions v1.40 as exposed by +-- @hs-opentelemetry-semantic-conventions@. Operation and consumer-group +-- keys follow @hs-opentelemetry-api@ 1.0\'s stability opt-in policy: +-- legacy by default, stable with @OTEL_SEMCONV_STABILITY_OPT_IN=messaging@, +-- and both with @OTEL_SEMCONV_STABILITY_OPT_IN=messaging\/dup@. +-- +-- The design parallels the upstream +-- @hs-opentelemetry-instrumentation-hw-kafka-client@\'s +-- @OpenTelemetry.Instrumentation.Kafka@ module. +-- +-- @since 0.2.0.0 +module Kafka.Effectful.OpenTelemetry.Semantic + ( -- * Constants kafkaMessagingSystem, producerOperationName, consumerOperationName, @@ -38,7 +37,7 @@ producerRecordAttributesWith, consumerRecordAttributes, consumerRecordAttributesWith, -) + ) where import Data.ByteString (ByteString) @@ -48,19 +47,19 @@ import Data.Text (Text) import Data.Text.Encoding (decodeUtf8') import Kafka.Consumer.ConsumerProperties (ConsumerProperties (cpProps)) -import Kafka.Consumer.Types ( - ConsumerRecord (crKey, crOffset, crPartition, crTopic, crValue), +import Kafka.Consumer.Types + ( ConsumerRecord (crKey, crOffset, crPartition, crTopic, crValue), Offset (unOffset), - ) -import Kafka.Producer.Types ( - ProducePartition (SpecifiedPartition, UnassignedPartition), + ) +import Kafka.Producer.Types + ( ProducePartition (SpecifiedPartition, UnassignedPartition), ProducerRecord (prKey, prPartition, prTopic, prValue), - ) + ) import Kafka.Types (PartitionId (unPartitionId), TopicName (..)) import OpenTelemetry.Attributes.Attribute (toAttribute) import OpenTelemetry.Attributes.Map (AttributeMap, insertAttributeByKey) -import OpenTelemetry.SemanticConventions ( - messaging_client_id, +import OpenTelemetry.SemanticConventions + ( messaging_client_id, messaging_consumer_group_name, messaging_destination_name, messaging_kafka_consumer_group, @@ -72,229 +71,219 @@ messaging_operation_name, messaging_operation_type, messaging_system, - ) + ) import OpenTelemetry.SemanticsConfig (StabilityOpt (..)) -{- | The constant @"kafka"@ used as the value of the -@messaging.system@ attribute. --} +-- | The constant @"kafka"@ used as the value of the +-- @messaging.system@ attribute. kafkaMessagingSystem :: Text kafkaMessagingSystem = "kafka" -{- | The operation name carried by producer-side spans -(@\"send\"@). The full span name is built by 'producerSpanName'. --} +-- | The operation name carried by producer-side spans +-- (@\"send\"@). The full span name is built by 'producerSpanName'. producerOperationName :: Text producerOperationName = "send" -{- | The operation name carried by consumer-side spans -(@\"process\"@). The full span name is built by 'consumerSpanName'. --} +-- | The operation name carried by consumer-side spans +-- (@\"process\"@). The full span name is built by 'consumerSpanName'. consumerOperationName :: Text consumerOperationName = "process" -{- | Build the canonical producer span name @\"send \\"@. - -This is the name shape the OTel messaging semantic conventions -recommend for Producer-kind spans (e.g. @"send orders"@). --} +-- | Build the canonical producer span name @\"send \\"@. +-- +-- This is the name shape the OTel messaging semantic conventions +-- recommend for Producer-kind spans (e.g. @"send orders"@). producerSpanName :: TopicName -> Text producerSpanName (TopicName t) = producerOperationName <> " " <> t -{- | Build the canonical consumer span name @\"process \\"@. - -This is the name shape the OTel messaging semantic conventions -recommend for Consumer-kind spans (e.g. @"process orders"@). --} +-- | Build the canonical consumer span name @\"process \\"@. +-- +-- This is the name shape the OTel messaging semantic conventions +-- recommend for Consumer-kind spans (e.g. @"process orders"@). consumerSpanName :: TopicName -> Text consumerSpanName (TopicName t) = consumerOperationName <> " " <> t -{- | Build the OpenTelemetry attribute map for a Producer-kind span -describing a single 'ProducerRecord'. - -The map always includes @messaging.system=kafka@, -@messaging.destination.name=@, and -@messaging.operation=send@. It also includes -@messaging.kafka.destination.partition@ (Int64) when the record -targets a 'SpecifiedPartition' (omitted for 'UnassignedPartition', -since the broker will pick the partition), and -@messaging.kafka.message.key@ (Text) when the record\'s @prKey@ -is present and decodes as UTF-8. --} +-- | Build the OpenTelemetry attribute map for a Producer-kind span +-- describing a single 'ProducerRecord'. +-- +-- The map always includes @messaging.system=kafka@, +-- @messaging.destination.name=@, and +-- @messaging.operation=send@. It also includes +-- @messaging.kafka.destination.partition@ (Int64) when the record +-- targets a 'SpecifiedPartition' (omitted for 'UnassignedPartition', +-- since the broker will pick the partition), and +-- @messaging.kafka.message.key@ (Text) when the record\'s @prKey@ +-- is present and decodes as UTF-8. producerRecordAttributes :: ProducerRecord -> AttributeMap producerRecordAttributes = producerRecordAttributesWith Old -{- | Build the OpenTelemetry attribute map for a Producer-kind span -using the supplied messaging semantic-convention stability mode. --} +-- | Build the OpenTelemetry attribute map for a Producer-kind span +-- using the supplied messaging semantic-convention stability mode. producerRecordAttributesWith :: - StabilityOpt -> - ProducerRecord -> - AttributeMap + StabilityOpt -> + ProducerRecord -> + AttributeMap producerRecordAttributesWith semOpts record = - addOperation semOpts - . addDestination - . addPartition - . addKey - . addBodySize - . addSystem - $ mempty + addOperation semOpts + . addDestination + . addPartition + . addKey + . addBodySize + . addSystem + $ mempty where addSystem = - insertAttributeByKey messaging_system $ - toAttribute kafkaMessagingSystem + insertAttributeByKey messaging_system $ + toAttribute kafkaMessagingSystem addOperation = \case - Old -> - insertAttributeByKey messaging_operation $ - toAttribute producerOperationName - Stable -> - insertAttributeByKey messaging_operation_name (toAttribute producerOperationName) - . insertAttributeByKey messaging_operation_type (toAttribute producerOperationName) - StableAndOld -> - insertAttributeByKey messaging_operation (toAttribute producerOperationName) - . insertAttributeByKey messaging_operation_name (toAttribute producerOperationName) - . insertAttributeByKey messaging_operation_type (toAttribute producerOperationName) + Old -> + insertAttributeByKey messaging_operation $ + toAttribute producerOperationName + Stable -> + insertAttributeByKey messaging_operation_name (toAttribute producerOperationName) + . insertAttributeByKey messaging_operation_type (toAttribute producerOperationName) + StableAndOld -> + insertAttributeByKey messaging_operation (toAttribute producerOperationName) + . insertAttributeByKey messaging_operation_name (toAttribute producerOperationName) + . insertAttributeByKey messaging_operation_type (toAttribute producerOperationName) addDestination = - insertAttributeByKey messaging_destination_name $ - toAttribute (unTopicName (prTopic record)) + insertAttributeByKey messaging_destination_name $ + toAttribute (unTopicName (prTopic record)) addPartition = case prPartition record of - SpecifiedPartition p -> - insertAttributeByKey messaging_kafka_destination_partition $ - toAttribute (fromIntegral p :: Int64) - UnassignedPartition -> id + SpecifiedPartition p -> + insertAttributeByKey messaging_kafka_destination_partition $ + toAttribute (fromIntegral p :: Int64) + UnassignedPartition -> id addKey = case prKey record >>= decodeKey of - Just k -> - insertAttributeByKey messaging_kafka_message_key $ - toAttribute k - Nothing -> id + Just k -> + insertAttributeByKey messaging_kafka_message_key $ + toAttribute k + Nothing -> id addBodySize = case prValue record of - Just v -> - insertAttributeByKey messaging_message_body_size $ - toAttribute (fromIntegral (BS.length v) :: Int64) - Nothing -> id - -{- | Build the OpenTelemetry attribute map for a Consumer-kind span -describing a single 'ConsumerRecord'. - -The map always includes @messaging.system=kafka@, -@messaging.destination.name=@, -@messaging.operation=process@, -@messaging.kafka.destination.partition@ (Int64), and -@messaging.kafka.message.offset@ (Int64). It also includes -@messaging.kafka.message.key@ (Text) when the record\'s @crKey@ -is present and decodes as UTF-8. + Just v -> + insertAttributeByKey messaging_message_body_size $ + toAttribute (fromIntegral (BS.length v) :: Int64) + Nothing -> id -Note: consumer-group and client-id attributes need -@Kafka.Consumer.ConsumerProperties@, not just the record. Use -'consumerRecordAttributesWith' when those properties are available. --} +-- | Build the OpenTelemetry attribute map for a Consumer-kind span +-- describing a single 'ConsumerRecord'. +-- +-- The map always includes @messaging.system=kafka@, +-- @messaging.destination.name=@, +-- @messaging.operation=process@, +-- @messaging.kafka.destination.partition@ (Int64), and +-- @messaging.kafka.message.offset@ (Int64). It also includes +-- @messaging.kafka.message.key@ (Text) when the record\'s @crKey@ +-- is present and decodes as UTF-8. +-- +-- Note: consumer-group and client-id attributes need +-- @Kafka.Consumer.ConsumerProperties@, not just the record. Use +-- 'consumerRecordAttributesWith' when those properties are available. consumerRecordAttributes :: - ConsumerRecord (Maybe ByteString) (Maybe ByteString) -> - AttributeMap + ConsumerRecord (Maybe ByteString) (Maybe ByteString) -> + AttributeMap consumerRecordAttributes = consumerRecordAttributesLegacy consumerRecordAttributesLegacy :: - ConsumerRecord (Maybe ByteString) (Maybe ByteString) -> - AttributeMap + ConsumerRecord (Maybe ByteString) (Maybe ByteString) -> + AttributeMap consumerRecordAttributesLegacy record = - addConsumerCommon Old record + addConsumerCommon Old record -{- | Build the OpenTelemetry attribute map for a Consumer-kind span -using the supplied messaging semantic-convention stability mode and -consumer properties. --} +-- | Build the OpenTelemetry attribute map for a Consumer-kind span +-- using the supplied messaging semantic-convention stability mode and +-- consumer properties. consumerRecordAttributesWith :: - StabilityOpt -> - ConsumerProperties -> - ConsumerRecord (Maybe ByteString) (Maybe ByteString) -> - AttributeMap + StabilityOpt -> + ConsumerProperties -> + ConsumerRecord (Maybe ByteString) (Maybe ByteString) -> + AttributeMap consumerRecordAttributesWith semOpts props record = - addConsumerGroup semOpts - . addClientId - $ addConsumerCommon semOpts record + addConsumerGroup semOpts + . addClientId + $ addConsumerCommon semOpts record where addConsumerGroup = \case - Old -> addOldConsumerGroup - Stable -> addStableConsumerGroup - StableAndOld -> addOldConsumerGroup . addStableConsumerGroup + Old -> addOldConsumerGroup + Stable -> addStableConsumerGroup + StableAndOld -> addOldConsumerGroup . addStableConsumerGroup addOldConsumerGroup attrs = - case Map.lookup "group.id" (cpProps props) of - Just groupId -> - insertAttributeByKey - messaging_kafka_consumer_group - (toAttribute groupId) - attrs - Nothing -> attrs + case Map.lookup "group.id" (cpProps props) of + Just groupId -> + insertAttributeByKey + messaging_kafka_consumer_group + (toAttribute groupId) + attrs + Nothing -> attrs addStableConsumerGroup attrs = - case Map.lookup "group.id" (cpProps props) of - Just groupId -> - insertAttributeByKey - messaging_consumer_group_name - (toAttribute groupId) - attrs - Nothing -> attrs + case Map.lookup "group.id" (cpProps props) of + Just groupId -> + insertAttributeByKey + messaging_consumer_group_name + (toAttribute groupId) + attrs + Nothing -> attrs addClientId attrs = - case Map.lookup "client.id" (cpProps props) of - Just clientId -> - insertAttributeByKey - messaging_client_id - (toAttribute clientId) - attrs - Nothing -> attrs + case Map.lookup "client.id" (cpProps props) of + Just clientId -> + insertAttributeByKey + messaging_client_id + (toAttribute clientId) + attrs + Nothing -> attrs addConsumerCommon :: - StabilityOpt -> - ConsumerRecord (Maybe ByteString) (Maybe ByteString) -> - AttributeMap + StabilityOpt -> + ConsumerRecord (Maybe ByteString) (Maybe ByteString) -> + AttributeMap addConsumerCommon semOpts record = - addOperation semOpts - . addDestination - . addPartition - . addOffset - . addKey - . addBodySize - . addSystem - $ mempty + addOperation semOpts + . addDestination + . addPartition + . addOffset + . addKey + . addBodySize + . addSystem + $ mempty where addSystem = - insertAttributeByKey messaging_system $ - toAttribute kafkaMessagingSystem + insertAttributeByKey messaging_system $ + toAttribute kafkaMessagingSystem addOperation = \case - Old -> - insertAttributeByKey messaging_operation $ - toAttribute consumerOperationName - Stable -> - insertAttributeByKey messaging_operation_name (toAttribute consumerOperationName) - . insertAttributeByKey messaging_operation_type (toAttribute consumerOperationName) - StableAndOld -> - insertAttributeByKey messaging_operation (toAttribute consumerOperationName) - . insertAttributeByKey messaging_operation_name (toAttribute consumerOperationName) - . insertAttributeByKey messaging_operation_type (toAttribute consumerOperationName) + Old -> + insertAttributeByKey messaging_operation $ + toAttribute consumerOperationName + Stable -> + insertAttributeByKey messaging_operation_name (toAttribute consumerOperationName) + . insertAttributeByKey messaging_operation_type (toAttribute consumerOperationName) + StableAndOld -> + insertAttributeByKey messaging_operation (toAttribute consumerOperationName) + . insertAttributeByKey messaging_operation_name (toAttribute consumerOperationName) + . insertAttributeByKey messaging_operation_type (toAttribute consumerOperationName) addDestination = - insertAttributeByKey messaging_destination_name $ - toAttribute (unTopicName (crTopic record)) + insertAttributeByKey messaging_destination_name $ + toAttribute (unTopicName (crTopic record)) addPartition = - insertAttributeByKey messaging_kafka_destination_partition $ - toAttribute (fromIntegral (unPartitionId (crPartition record)) :: Int64) + insertAttributeByKey messaging_kafka_destination_partition $ + toAttribute (fromIntegral (unPartitionId (crPartition record)) :: Int64) addOffset = - insertAttributeByKey messaging_kafka_message_offset $ - toAttribute (unOffset (crOffset record)) + insertAttributeByKey messaging_kafka_message_offset $ + toAttribute (unOffset (crOffset record)) addKey = case crKey record >>= decodeKey of - Just k -> - insertAttributeByKey messaging_kafka_message_key $ - toAttribute k - Nothing -> id + Just k -> + insertAttributeByKey messaging_kafka_message_key $ + toAttribute k + Nothing -> id addBodySize = case crValue record of - Just v -> - insertAttributeByKey messaging_message_body_size $ - toAttribute (fromIntegral (BS.length v) :: Int64) - Nothing -> id + Just v -> + insertAttributeByKey messaging_message_body_size $ + toAttribute (fromIntegral (BS.length v) :: Int64) + Nothing -> id -{- | Decode message-key bytes as UTF-8, returning 'Nothing' if the -bytes are not valid UTF-8. Matches the behavior of upstream -@OpenTelemetry.Instrumentation.Kafka@\'s @prKey \/ crKey@ handling. --} +-- | Decode message-key bytes as UTF-8, returning 'Nothing' if the +-- bytes are not valid UTF-8. Matches the behavior of upstream +-- @OpenTelemetry.Instrumentation.Kafka@\'s @prKey \/ crKey@ handling. decodeKey :: ByteString -> Maybe Text decodeKey bs = case decodeUtf8' bs of - Right t -> Just t - Left _ -> Nothing + Right t -> Just t + Left _ -> Nothing diff --git a/src/Kafka/Effectful/Producer.hs b/src/Kafka/Effectful/Producer.hs --- a/src/Kafka/Effectful/Producer.hs +++ b/src/Kafka/Effectful/Producer.hs @@ -1,5 +1,5 @@ -module Kafka.Effectful.Producer ( - -- * Effect +module Kafka.Effectful.Producer + ( -- * Effect KafkaProducer, -- * Interpreter @@ -67,11 +67,13 @@ headersFromList, headersToList, Offset (..), -) + ) where -import Kafka.Effectful.Producer.Effect ( - KafkaProducer, +-- Offset is in Consumer.Types +import Kafka.Consumer.Types (Offset (..)) +import Kafka.Effectful.Producer.Effect + ( KafkaProducer, abortTransaction, askProducerHandle, beginTransaction, @@ -82,20 +84,17 @@ produceMessage', produceMessageBatch, produceMessageSync, - ) + ) import Kafka.Effectful.Producer.Interpreter (runKafkaProducer) import Kafka.Effectful.Producer.Transaction (commitOffsetMessageTransaction) import Kafka.Producer.ProducerProperties (ProducerProperties (..)) import Kafka.Producer.ProducerProperties qualified as K import Kafka.Producer.Types (DeliveryReport (..), ImmediateError (..), ProducePartition (..), ProducerRecord (..)) -import Kafka.Transaction ( - TxError, +import Kafka.Transaction + ( TxError, getKafkaError, kafkaErrorIsFatal, kafkaErrorIsRetriable, kafkaErrorTxnRequiresAbort, - ) + ) import Kafka.Types (BrokerAddress (..), Headers, KafkaCompressionCodec (..), KafkaDebug (..), KafkaError (..), KafkaLogLevel (..), Timeout (..), TopicName (..), headersFromList, headersToList) - --- Offset is in Consumer.Types -import Kafka.Consumer.Types (Offset (..)) diff --git a/src/Kafka/Effectful/Producer/Effect.hs b/src/Kafka/Effectful/Producer/Effect.hs --- a/src/Kafka/Effectful/Producer/Effect.hs +++ b/src/Kafka/Effectful/Producer/Effect.hs @@ -1,5 +1,5 @@ -module Kafka.Effectful.Producer.Effect ( - -- * Effect +module Kafka.Effectful.Producer.Effect + ( -- * Effect KafkaProducer (..), -- * Operations @@ -18,7 +18,7 @@ -- ** Internal — cross-effect plumbing sendOffsetsToTransaction, askProducerHandle, -) + ) where import Effectful (Dispatch (..), DispatchOf, Eff, Effect, (:>)) @@ -32,186 +32,189 @@ -- | Effect for Kafka producer operations. data KafkaProducer :: Effect where - ProduceMessage :: - ProducerRecord -> - KafkaProducer m () - ProduceMessage' :: - ProducerRecord -> - (DeliveryReport -> IO ()) -> - KafkaProducer m () - ProduceMessageSync :: - ProducerRecord -> - KafkaProducer m Offset - ProduceMessageBatch :: - [ProducerRecord] -> - KafkaProducer m [(ProducerRecord, KafkaError)] - FlushProducer :: - KafkaProducer m () - InitTransactions :: - Timeout -> - KafkaProducer m () - BeginTransaction :: - KafkaProducer m () - CommitTransaction :: - Timeout -> - KafkaProducer m (Maybe TxError) - AbortTransaction :: - Timeout -> - KafkaProducer m () - SendOffsetsToTransaction :: - KC.KafkaConsumer -> - ConsumerRecord k v -> - Timeout -> - KafkaProducer m (Maybe TxError) - AskProducerHandle :: - KafkaProducer m KP.KafkaProducer + ProduceMessage :: + ProducerRecord -> + KafkaProducer m () + ProduceMessage' :: + ProducerRecord -> + (DeliveryReport -> IO ()) -> + KafkaProducer m () + ProduceMessageSync :: + ProducerRecord -> + KafkaProducer m Offset + ProduceMessageBatch :: + [ProducerRecord] -> + KafkaProducer m [(ProducerRecord, KafkaError)] + FlushProducer :: + KafkaProducer m () + InitTransactions :: + Timeout -> + KafkaProducer m () + BeginTransaction :: + KafkaProducer m () + CommitTransaction :: + Timeout -> + KafkaProducer m (Maybe TxError) + AbortTransaction :: + Timeout -> + KafkaProducer m () + SendOffsetsToTransaction :: + KC.KafkaConsumer -> + ConsumerRecord k v -> + Timeout -> + KafkaProducer m (Maybe TxError) + AskProducerHandle :: + KafkaProducer m KP.KafkaProducer type instance DispatchOf KafkaProducer = 'Dynamic -{- | Send a single message to Kafka. -Throws 'KafkaError' via the 'Error' effect on failure. --} +-- | Send a single message to Kafka. +-- Throws 'KafkaError' via the 'Error' effect on failure. produceMessage :: (KafkaProducer :> es) => ProducerRecord -> Eff es () produceMessage = send . ProduceMessage -{- | Send a single message with a per-message 'DeliveryReport' callback. - -The callback runs on a librdkafka-forked thread, so blocking operations -(such as writing to an @MVar@) are safe. Throws 'KafkaError' via the -'Error' effect when the underlying send fails to enqueue -(@ImmediateError@). - -This is the low-level primitive for Scenario 2 of -@hw-kafka-client@'s producer best practices. Callers that only need a -single synchronous send should prefer 'produceMessageSync'. - -@since 0.2.0.0 --} +-- | Send a single message with a per-message 'DeliveryReport' callback. +-- +-- The callback runs on a librdkafka-forked thread, so blocking operations +-- (such as writing to an @MVar@) are safe. Throws 'KafkaError' via the +-- 'Error' effect when the underlying send fails to enqueue +-- (@ImmediateError@). +-- +-- This is the low-level primitive for Scenario 2 of +-- @hw-kafka-client@'s producer best practices. Callers that only need a +-- single synchronous send should prefer 'produceMessageSync'. +-- +-- @since 0.2.0.0 produceMessage' :: - (KafkaProducer :> es) => - ProducerRecord -> - (DeliveryReport -> IO ()) -> - Eff es () + (KafkaProducer :> es) => + ProducerRecord -> + (DeliveryReport -> IO ()) -> + Eff es () produceMessage' record cb = send (ProduceMessage' record cb) -{- | Send a single message and block until the broker acknowledges it, -returning the broker-assigned 'Offset'. - -Throws 'KafkaError' via the 'Error' effect on enqueue failure -(@ImmediateError@) or on delivery failure reported via the -'DeliveryReport'. - -This is the high-level convenience for Scenario 2 of -@hw-kafka-client@'s producer best practices. - -@since 0.2.0.0 --} +-- | Send a single message and block until the broker acknowledges it, +-- returning the broker-assigned 'Offset'. +-- +-- Throws 'KafkaError' via the 'Error' effect on enqueue failure +-- (@ImmediateError@) or on delivery failure reported via the +-- 'DeliveryReport'. +-- +-- This is the high-level convenience for Scenario 2 of +-- @hw-kafka-client@'s producer best practices. +-- +-- @since 0.2.0.0 produceMessageSync :: - (KafkaProducer :> es) => - ProducerRecord -> - Eff es Offset + (KafkaProducer :> es) => + ProducerRecord -> + Eff es Offset produceMessageSync = send . ProduceMessageSync -{- | Send many records in one call. - -Returns only the records that failed to enqueue, paired with the -error librdkafka reported for that record. Successful records are -omitted. This mirrors @Kafka.Producer.produceMessageBatch@. - -Combined with @linger.ms@ and @batch.size@ set on the -@ProducerProperties@, this is the throughput-oriented path — Scenario -4 of @hw-kafka-client@'s producer best practices. - -@since 0.2.0.0 --} +-- | Send many records in one call. +-- +-- Returns only the records that failed to enqueue, paired with the +-- error librdkafka reported for that record. Successful records are +-- omitted. +-- +-- __This is a per-record loop, not a batch send.__ It issues one +-- @produceMessage@ per record and therefore saves no network +-- round-trips over calling 'produceMessage' yourself in a loop. What it +-- gives you is the batch-shaped signature and the collected failures. +-- +-- Throughput comes from @linger.ms@, @batch.size@ and @compression@ on +-- the @ProducerProperties@ — librdkafka coalesces its own send queue, +-- and it does so for every produce call regardless of which function +-- you use. Setting those and calling 'produceMessage' performs +-- identically. +-- +-- @hw-kafka-client@ exposes no API-level batch send: it removed its own +-- @produceMessageBatch@ in October 2021 (and that was a @mapM@ too), and +-- librdkafka's @rd_kafka_produce_batch@ has never been bound. Tracked as +-- upstream issue @hw-kafka-client-no-produce-batch-binding@ — run +-- @mori upstream-issues show hw-kafka-client-no-produce-batch-binding@. +-- +-- @since 0.2.0.0 produceMessageBatch :: - (KafkaProducer :> es) => - [ProducerRecord] -> - Eff es [(ProducerRecord, KafkaError)] + (KafkaProducer :> es) => + [ProducerRecord] -> + Eff es [(ProducerRecord, KafkaError)] produceMessageBatch = send . ProduceMessageBatch -- | Flush the producer's outbound queue, blocking until all messages are sent. flushProducer :: (KafkaProducer :> es) => Eff es () flushProducer = send FlushProducer -{- | Initialise the transactional producer. - -Must be called exactly once per producer, after @runKafkaProducer@ -has acquired the handle and before any call to 'beginTransaction'. -The producer's @ProducerProperties@ must set @transactional.id@, -@enable.idempotence=true@, and @acks=all@. - -Throws 'KafkaError' via the 'Error' effect on failure. - -@since 0.2.0.0 --} +-- | Initialise the transactional producer. +-- +-- Must be called exactly once per producer, after @runKafkaProducer@ +-- has acquired the handle and before any call to 'beginTransaction'. +-- The producer's @ProducerProperties@ must set @transactional.id@, +-- @enable.idempotence=true@, and @acks=all@. +-- +-- Throws 'KafkaError' via the 'Error' effect on failure. +-- +-- @since 0.2.0.0 initTransactions :: (KafkaProducer :> es) => Timeout -> Eff es () initTransactions = send . InitTransactions -{- | Open a new transaction. - -Must be preceded by exactly one successful 'initTransactions' on the -same producer handle. Throws 'KafkaError' via the 'Error' effect on -failure. - -@since 0.2.0.0 --} +-- | Open a new transaction. +-- +-- Must be preceded by exactly one successful 'initTransactions' on the +-- same producer handle. Throws 'KafkaError' via the 'Error' effect on +-- failure. +-- +-- @since 0.2.0.0 beginTransaction :: (KafkaProducer :> es) => Eff es () beginTransaction = send BeginTransaction -{- | Commit the currently-open transaction. - -Returns @Nothing@ on success or @Just TxError@ on failure. The -caller must branch on the three 'TxError' discriminators -(@kafkaErrorTxnRequiresAbort@ first, then @kafkaErrorIsRetriable@, -then @kafkaErrorIsFatal@) to decide whether to abort, retry, or -crash. - -@since 0.2.0.0 --} +-- | Commit the currently-open transaction. +-- +-- Returns @Nothing@ on success or @Just TxError@ on failure. The +-- caller must branch on the three 'TxError' discriminators +-- (@kafkaErrorTxnRequiresAbort@ first, then @kafkaErrorIsRetriable@, +-- then @kafkaErrorIsFatal@) to decide whether to abort, retry, or +-- crash. +-- +-- @since 0.2.0.0 commitTransaction :: (KafkaProducer :> es) => Timeout -> Eff es (Maybe TxError) commitTransaction = send . CommitTransaction -{- | Abort the currently-open transaction. - -Throws 'KafkaError' via the 'Error' effect on failure. - -@since 0.2.0.0 --} +-- | Abort the currently-open transaction. +-- +-- Throws 'KafkaError' via the 'Error' effect on failure. +-- +-- @since 0.2.0.0 abortTransaction :: (KafkaProducer :> es) => Timeout -> Eff es () abortTransaction = send . AbortTransaction -{- | Send the consumer offsets for a single 'ConsumerRecord' to the -open transaction. - -This is plumbing used by -'Kafka.Effectful.Producer.Transaction.commitOffsetMessageTransaction' -and is not intended to be called directly — end-users should use the -helper, which picks up the consumer handle automatically via -@askConsumerHandle@. - -@since 0.2.0.0 --} +-- | Send the consumer offsets for a single 'ConsumerRecord' to the +-- open transaction. +-- +-- This is plumbing used by +-- 'Kafka.Effectful.Producer.Transaction.commitOffsetMessageTransaction' +-- and is not intended to be called directly — end-users should use the +-- helper, which picks up the consumer handle automatically via +-- @askConsumerHandle@. +-- +-- @since 0.2.0.0 sendOffsetsToTransaction :: - (KafkaProducer :> es) => - KC.KafkaConsumer -> - ConsumerRecord k v -> - Timeout -> - Eff es (Maybe TxError) + (KafkaProducer :> es) => + KC.KafkaConsumer -> + ConsumerRecord k v -> + Timeout -> + Eff es (Maybe TxError) sendOffsetsToTransaction consumer record timeout = - send (SendOffsetsToTransaction consumer record timeout) - -{- | Escape hatch: return the raw @Kafka.Producer.KafkaProducer@ handle -acquired by @runKafkaProducer@. - -Exposed to enable the cross-effect -'Kafka.Effectful.Producer.Transaction.commitOffsetMessageTransaction' -helper, which must reach both the producer and consumer handles to -call the underlying transactional offset-commit primitive. New -operations should go through the 'KafkaProducer' effect rather than -this handle. + send (SendOffsetsToTransaction consumer record timeout) -@since 0.2.0.0 --} +-- | Escape hatch: return the raw @Kafka.Producer.KafkaProducer@ handle +-- acquired by @runKafkaProducer@. +-- +-- Exposed to enable the cross-effect +-- 'Kafka.Effectful.Producer.Transaction.commitOffsetMessageTransaction' +-- helper, which must reach both the producer and consumer handles to +-- call the underlying transactional offset-commit primitive. New +-- operations should go through the 'KafkaProducer' effect rather than +-- this handle. +-- +-- @since 0.2.0.0 askProducerHandle :: (KafkaProducer :> es) => Eff es KP.KafkaProducer askProducerHandle = send AskProducerHandle diff --git a/src/Kafka/Effectful/Producer/Interpreter.hs b/src/Kafka/Effectful/Producer/Interpreter.hs --- a/src/Kafka/Effectful/Producer/Interpreter.hs +++ b/src/Kafka/Effectful/Producer/Interpreter.hs @@ -4,10 +4,10 @@ -- 'interpret' to type-check. Suppress the warning at the file level. {-# OPTIONS_GHC -Wno-redundant-constraints #-} -module Kafka.Effectful.Producer.Interpreter ( - -- * Interpreter +module Kafka.Effectful.Producer.Interpreter + ( -- * Interpreter runKafkaProducer, -) + ) where import Control.Concurrent.MVar qualified as Concurrent @@ -23,78 +23,86 @@ import Kafka.Transaction qualified as K import Kafka.Types (KafkaError) -{- | Run the 'KafkaProducer' effect. - -Acquires a producer handle from the given properties and releases it -when the effect scope ends. Errors are thrown via the 'Error' effect. --} +-- | Run the 'KafkaProducer' effect. +-- +-- Acquires a producer handle from the given properties and releases it +-- when the effect scope ends. Errors are thrown via the 'Error' effect. runKafkaProducer :: - (IOE :> es, Error KafkaError :> es) => - ProducerProperties -> - Eff (KafkaProducer : es) a -> - Eff es a + (IOE :> es, Error KafkaError :> es) => + ProducerProperties -> + Eff (KafkaProducer : es) a -> + Eff es a runKafkaProducer props action = - Exception.bracket - acquire - (Effectful.liftIO . K.closeProducer) - (\producer -> interpret (handleProducer producer) action) + Exception.bracket + acquire + (Effectful.liftIO . K.closeProducer) + (\producer -> interpret (handleProducer producer) action) where acquire = do - result <- Effectful.liftIO $ K.newProducer props - case result of - Left err -> throwError err - Right producer -> pure producer + result <- Effectful.liftIO $ K.newProducer props + case result of + Left err -> throwError err + Right producer -> pure producer handleProducer :: - (IOE :> es, Error KafkaError :> es) => - K.KafkaProducer -> - EffectHandler KafkaProducer es + (IOE :> es, Error KafkaError :> es) => + K.KafkaProducer -> + EffectHandler KafkaProducer es handleProducer producer _env = \case - ProduceMessage record -> do - mbErr <- Effectful.liftIO $ K.produceMessage producer record - for_ mbErr throwError - ProduceMessage' record cb -> do - res <- Effectful.liftIO $ K.produceMessage' producer record cb - case res of - Left (K.ImmediateError err) -> throwError err - Right () -> pure () - ProduceMessageBatch records -> Effectful.liftIO $ do - -- Hackage hw-kafka-client-5.3.0 does not export - -- 'Kafka.Producer.produceMessageBatch', so we inline the same - -- definition it ships on master: mapM over the list and keep - -- only the records that failed to enqueue. - results <- mapM (\r -> (r,) <$> K.produceMessage producer r) records - pure [(r, err) | (r, Just err) <- results] - ProduceMessageSync record -> do - var <- Effectful.liftIO Concurrent.newEmptyMVar - res <- - Effectful.liftIO $ - K.produceMessage' producer record (Concurrent.putMVar var) - case res of - Left (K.ImmediateError err) -> throwError err - Right () -> do - Effectful.liftIO $ K.flushProducer producer - report <- Effectful.liftIO $ Concurrent.takeMVar var - case report of - K.DeliverySuccess _ offset -> pure offset - K.DeliveryFailure _ err -> throwError err - K.NoMessageError err -> throwError err - FlushProducer -> + ProduceMessage record -> do + mbErr <- Effectful.liftIO $ K.produceMessage producer record + for_ mbErr throwError + ProduceMessage' record cb -> do + res <- Effectful.liftIO $ K.produceMessage' producer record cb + case res of + Left (K.ImmediateError err) -> throwError err + Right () -> pure () + ProduceMessageBatch records -> Effectful.liftIO $ do + -- This is a per-record loop, not a batch send, and it saves no + -- network round-trips over calling produceMessage yourself. The + -- value here is the batch-shaped signature and the failed-record + -- result, not throughput. + -- + -- hw-kafka-client exports no batch produce at all. It removed its + -- Haskell-level produceMessageBatch in 72e6f6d (Oct 2021, before + -- v5.3.0), and that function was itself a mapM over produceMessage. + -- Real batching would need a binding for librdkafka's + -- rd_kafka_produce_batch, which the package has never had. + -- + -- Tracked as upstream issue 'hw-kafka-client-no-produce-batch-binding'; + -- run `mori upstream-issues show hw-kafka-client-no-produce-batch-binding`. + results <- mapM (\r -> (r,) <$> K.produceMessage producer r) records + pure [(r, err) | (r, Just err) <- results] + ProduceMessageSync record -> do + var <- Effectful.liftIO Concurrent.newEmptyMVar + res <- + Effectful.liftIO $ + K.produceMessage' producer record (Concurrent.putMVar var) + case res of + Left (K.ImmediateError err) -> throwError err + Right () -> do Effectful.liftIO $ K.flushProducer producer - InitTransactions timeout -> - throwOnJust $ K.initTransactions producer timeout - BeginTransaction -> - throwOnJust $ K.beginTransaction producer - CommitTransaction timeout -> - Effectful.liftIO $ K.commitTransaction producer timeout - AbortTransaction timeout -> - throwOnJust $ K.abortTransaction producer timeout - SendOffsetsToTransaction consumer record timeout -> - Effectful.liftIO $ - K.commitOffsetMessageTransaction producer consumer record timeout - AskProducerHandle -> - pure producer + report <- Effectful.liftIO $ Concurrent.takeMVar var + case report of + K.DeliverySuccess _ offset -> pure offset + K.DeliveryFailure _ err -> throwError err + K.NoMessageError err -> throwError err + FlushProducer -> + Effectful.liftIO $ K.flushProducer producer + InitTransactions timeout -> + throwOnJust $ K.initTransactions producer timeout + BeginTransaction -> + throwOnJust $ K.beginTransaction producer + CommitTransaction timeout -> + Effectful.liftIO $ K.commitTransaction producer timeout + AbortTransaction timeout -> + throwOnJust $ K.abortTransaction producer timeout + SendOffsetsToTransaction consumer record timeout -> + Effectful.liftIO $ + K.commitOffsetMessageTransaction producer consumer record timeout + AskProducerHandle -> + pure producer where throwOnJust action' = do - mbErr <- Effectful.liftIO action' - for_ mbErr throwError + mbErr <- Effectful.liftIO action' + for_ mbErr throwError diff --git a/src/Kafka/Effectful/Producer/Transaction.hs b/src/Kafka/Effectful/Producer/Transaction.hs --- a/src/Kafka/Effectful/Producer/Transaction.hs +++ b/src/Kafka/Effectful/Producer/Transaction.hs @@ -1,6 +1,6 @@ -module Kafka.Effectful.Producer.Transaction ( - commitOffsetMessageTransaction, -) +module Kafka.Effectful.Producer.Transaction + ( commitOffsetMessageTransaction, + ) where import Effectful (Eff, (:>)) @@ -10,33 +10,32 @@ import Kafka.Transaction (TxError) import Kafka.Types (Timeout) -{- | Commit the offset of a single 'ConsumerRecord' inside the current -transaction of the surrounding 'KafkaProducer'. - -This is the cross-effect counterpart to the consumer's -@commitOffsetMessage@ — the record's offset is not stored via the -consumer's offset-commit path but instead shipped as part of the -producer's open transaction, which preserves the exactly-once -semantics required by Scenario 5 of @hw-kafka-client@'s producer -best practices. - -Returns @Nothing@ on success or @Just TxError@ on failure. The -caller must dispatch on the three 'TxError' discriminators -(@kafkaErrorTxnRequiresAbort@ first, then @kafkaErrorIsRetriable@, -then @kafkaErrorIsFatal@) to decide whether to abort the -transaction, retry the commit, or crash. - -The helper picks up the consumer handle automatically via -@askConsumerHandle@, so callers only need to have both 'KafkaProducer' -and 'KafkaConsumer' in the effect stack. - -@since 0.2.0.0 --} +-- | Commit the offset of a single 'ConsumerRecord' inside the current +-- transaction of the surrounding 'KafkaProducer'. +-- +-- This is the cross-effect counterpart to the consumer's +-- @commitOffsetMessage@ — the record's offset is not stored via the +-- consumer's offset-commit path but instead shipped as part of the +-- producer's open transaction, which preserves the exactly-once +-- semantics required by Scenario 5 of @hw-kafka-client@'s producer +-- best practices. +-- +-- Returns @Nothing@ on success or @Just TxError@ on failure. The +-- caller must dispatch on the three 'TxError' discriminators +-- (@kafkaErrorTxnRequiresAbort@ first, then @kafkaErrorIsRetriable@, +-- then @kafkaErrorIsFatal@) to decide whether to abort the +-- transaction, retry the commit, or crash. +-- +-- The helper picks up the consumer handle automatically via +-- @askConsumerHandle@, so callers only need to have both 'KafkaProducer' +-- and 'KafkaConsumer' in the effect stack. +-- +-- @since 0.2.0.0 commitOffsetMessageTransaction :: - (KafkaProducer :> es, KafkaConsumer :> es) => - ConsumerRecord k v -> - Timeout -> - Eff es (Maybe TxError) + (KafkaProducer :> es, KafkaConsumer :> es) => + ConsumerRecord k v -> + Timeout -> + Eff es (Maybe TxError) commitOffsetMessageTransaction record timeout = do - consumer <- askConsumerHandle - sendOffsetsToTransaction consumer record timeout + consumer <- askConsumerHandle + sendOffsetsToTransaction consumer record timeout diff --git a/test/Kafka/Effectful/Consumer/ClassifyTest.hs b/test/Kafka/Effectful/Consumer/ClassifyTest.hs new file mode 100644 --- /dev/null +++ b/test/Kafka/Effectful/Consumer/ClassifyTest.hs @@ -0,0 +1,75 @@ +-- | Pins the in-band error taxonomy the consumer interpreters apply. +-- +-- Laid out as label\/expectation tables deliberately, mirroring +-- @hw-kafka-streamly@\'s @test\/Kafka\/Streamly\/StreamTest.hs@, so the two +-- projects\' classifications of the same librdkafka codes can be read side by +-- side when either changes. +module Kafka.Effectful.Consumer.ClassifyTest (tests) where + +import Kafka.Consumer (RdKafkaRespErrT (..)) +import Kafka.Effectful.Consumer.Classify + ( PollErrorDisposition (..), + classifyPollError, + isBenignCommitError, + ) +import Kafka.Types (KafkaError (..)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +-- | Conditions a healthy consumer meets in normal operation. Swallowed. +benignPollErrors :: [(String, KafkaError)] +benignPollErrors = + [ ("RdKafkaRespErrPartitionEof", KafkaResponseError RdKafkaRespErrPartitionEof), + ("RdKafkaRespErrAutoOffsetReset", KafkaResponseError RdKafkaRespErrAutoOffsetReset), + ("RdKafkaRespErrUnknownTopicOrPart", KafkaResponseError RdKafkaRespErrUnknownTopicOrPart) + ] + +-- | Conditions that must reach the caller as a thrown error. +-- 'RdKafkaRespErrFatal' is the important one: it is what librdkafka delivers +-- once a fatal error has been raised on the client, after which the consumer is +-- permanently dead. +throwingPollErrors :: [(String, KafkaError)] +throwingPollErrors = + [ ("RdKafkaRespErrFatal", KafkaResponseError RdKafkaRespErrFatal), + ("RdKafkaRespErrSaslAuthenticationFailed", KafkaResponseError RdKafkaRespErrSaslAuthenticationFailed), + ("RdKafkaRespErrAuthentication", KafkaResponseError RdKafkaRespErrAuthentication), + ("RdKafkaRespErrDestroy", KafkaResponseError RdKafkaRespErrDestroy), + ("RdKafkaRespErrAllBrokersDown", KafkaResponseError RdKafkaRespErrAllBrokersDown), + ("KafkaBadConfiguration", KafkaBadConfiguration), + ("KafkaBadSpecification", KafkaBadSpecification ""), + -- A commit-only condition must not be mistaken for a benign poll + -- condition; the two tables are independent. + ("RdKafkaRespErrNoOffset", KafkaResponseError RdKafkaRespErrNoOffset) + ] + +tests :: TestTree +tests = + testGroup + "Classify" + [ testGroup "classifyPollError" classifyPollErrorTests, + testGroup "isBenignCommitError" isBenignCommitErrorTests + ] + +classifyPollErrorTests :: [TestTree] +classifyPollErrorTests = + [ testCase "timeout: RdKafkaRespErrTimedOut" $ + classifyPollError (KafkaResponseError RdKafkaRespErrTimedOut) @?= PollTimeout + ] + <> [ testCase ("benign: " <> label) (classifyPollError err @?= PollBenign) + | (label, err) <- benignPollErrors + ] + <> [ testCase ("throws: " <> label) (classifyPollError err @?= PollThrow) + | (label, err) <- throwingPollErrors + ] + +isBenignCommitErrorTests :: [TestTree] +isBenignCommitErrorTests = + [ testCase "accepts RdKafkaRespErrNoOffset" $ + isBenignCommitError (KafkaResponseError RdKafkaRespErrNoOffset) @?= True, + testCase "rejects RdKafkaRespErrAllBrokersDown" $ + isBenignCommitError (KafkaResponseError RdKafkaRespErrAllBrokersDown) @?= False, + testCase "rejects RdKafkaRespErrFatal" $ + isBenignCommitError (KafkaResponseError RdKafkaRespErrFatal) @?= False, + testCase "rejects a partition-EOF poll condition" $ + isBenignCommitError (KafkaResponseError RdKafkaRespErrPartitionEof) @?= False + ] diff --git a/test/Kafka/Effectful/Consumer/InterpreterTest.hs b/test/Kafka/Effectful/Consumer/InterpreterTest.hs new file mode 100644 --- /dev/null +++ b/test/Kafka/Effectful/Consumer/InterpreterTest.hs @@ -0,0 +1,81 @@ +-- | Interpreter-level tests that need no broker. +-- +-- librdkafka connects lazily, so @newConsumer@ against an unreachable broker +-- address succeeds and returns a usable handle. That is enough to exercise the +-- operations whose defects are local to the interpreter rather than to any +-- broker interaction — in particular the idle-commit path, where +-- @commitAllOffsets@ with nothing assigned yields +-- @RdKafkaRespErrNoOffset@, which hw-kafka-client documents as not an error. +-- +-- In-band benign poll classification (partition EOF, offset reset, +-- unknown topic) cannot be forced this way, because an offline client never +-- emits those conditions. That path is covered by +-- "Kafka.Effectful.Consumer.ClassifyTest" plus the fact that both interpreters +-- route through the same exported classifier. +module Kafka.Effectful.Consumer.InterpreterTest (tests) where + +import Effectful (Eff, IOE, runEff, (:>)) +import Effectful.Error.Static (Error, runErrorNoCallStack) +import Kafka.Consumer.ConsumerProperties + ( ConsumerProperties, + brokersList, + groupId, + ) +import Kafka.Consumer.Subscription (Subscription, topics) +import Kafka.Consumer.Types (ConsumerGroupId (..), OffsetCommit (OffsetCommit)) +import Kafka.Effectful.Consumer.Effect + ( KafkaConsumer, + commitAllOffsets, + pollMessage, + ) +import Kafka.Effectful.Consumer.Interpreter (runKafkaConsumer) +import Kafka.Types + ( BrokerAddress (..), + KafkaError, + Timeout (..), + TopicName (..), + ) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) + +-- | Point at a port nothing listens on. librdkafka will keep trying to +-- connect in the background; none of the operations under test wait for it. +offlineProps :: ConsumerProperties +offlineProps = + brokersList [BrokerAddress "localhost:1"] + <> groupId (ConsumerGroupId "kafka-effectful-test-group") + +offlineSubscription :: Subscription +offlineSubscription = topics [TopicName "kafka-effectful-test-topic"] + +-- | Run an action under the plain interpreter against the offline consumer. +runOffline :: + (forall es. (IOE :> es, Error KafkaError :> es, KafkaConsumer :> es) => Eff es a) -> + IO (Either KafkaError a) +runOffline action = + runEff . runErrorNoCallStack $ + runKafkaConsumer offlineProps offlineSubscription action + +tests :: TestTree +tests = + testGroup + "Interpreter (brokerless)" + [ -- Pins the half of pollMessage's contract that is not changing: a + -- timeout is not an error. + testCase "pollMessage returns Nothing on timeout" $ do + result <- runOffline (pollMessage (Timeout 100)) + case result of + Right Nothing -> pure () + Right (Just _) -> + assertFailure "expected no record from an offline consumer" + Left err -> + assertFailure ("expected a timeout to be swallowed, got: " <> show err), + -- The KSC-5 regression. With nothing assigned there is nothing to + -- commit, and librdkafka reports that as RdKafkaRespErrNoOffset -- + -- which hw-kafka-client's own callback documentation calls out as + -- "not to be considered an error". Before the fix this threw, so an + -- idle consumer could die on a shutdown commit. + testCase "commitAllOffsets succeeds when there is nothing to commit" $ do + result <- runOffline (commitAllOffsets OffsetCommit) + result @?= Right () + ] diff --git a/test/Kafka/Effectful/OpenTelemetry/ConsumerSpanTest.hs b/test/Kafka/Effectful/OpenTelemetry/ConsumerSpanTest.hs new file mode 100644 --- /dev/null +++ b/test/Kafka/Effectful/OpenTelemetry/ConsumerSpanTest.hs @@ -0,0 +1,210 @@ +-- | Trace-context hygiene tests for the traced consumer interpreter. +-- +-- These drive 'withConsumerSpan' directly rather than going through the +-- interpreter, because the interpreter closes over a live +-- @Kafka.Consumer.KafkaConsumer@ and calls hw-kafka-client IO, while the +-- behaviour under test — how a record\'s inbound trace context is extracted, +-- attached, and detached — is entirely broker-independent. +-- +-- Spans are captured with an in-memory exporter wired into a tracer provider +-- built fresh for each test case. Building it per case rather than sharing one +-- matters twice over: tasty runs test cases concurrently, so a shared span +-- reference would race, and @inSpan\'\'@ takes a fast path that skips context +-- modification entirely when the provider has no span processors, so a +-- processor-less provider would make these assertions vacuous. +module Kafka.Effectful.OpenTelemetry.ConsumerSpanTest (tests) where + +import Data.ByteString (ByteString) +import Data.IORef (readIORef) +import Data.Text (Text) +import Effectful (runEff) +import Kafka.Consumer.ConsumerProperties (ConsumerProperties) +import Kafka.Consumer.Types + ( ConsumerRecord (..), + Offset (..), + Timestamp (NoTimestamp), + ) +import Kafka.Effectful.OpenTelemetry.Consumer.Interpreter (withConsumerSpan) +import Kafka.Types + ( PartitionId (..), + TopicName (..), + headersFromList, + ) +import OpenTelemetry.Context qualified as Context +import OpenTelemetry.Context.ThreadLocal (getContext) +import OpenTelemetry.Exporter.InMemory.Span (inMemoryListExporter) +import OpenTelemetry.Trace (initializeGlobalTracerProvider) +import OpenTelemetry.Trace.Core + ( ImmutableSpan (..), + SpanContext (..), + createTracerProvider, + emptyTracerProviderOptions, + forceFlushTracerProvider, + makeTracer, + tracerOptions, + ) +import OpenTelemetry.Trace.Id (Base (Base16), traceIdBaseEncodedText) +import Test.Tasty (TestTree, testGroup, withResource) +import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase) + +-- | The W3C trace-context specification\'s example traceparent. Trace ID +-- @0af7651916cd43dd8448eb211c80319c@. +sampleTraceparent :: ByteString +sampleTraceparent = + "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01" + +sampleTraceIdHex :: Text +sampleTraceIdHex = "0af7651916cd43dd8448eb211c80319c" + +-- | A second, distinct traceparent, for the batch-isolation case. +otherTraceparent :: ByteString +otherTraceparent = + "00-4bf92f3577b34da6a3ce929d0e0e4736-00f067aa0ba902b7-01" + +otherTraceIdHex :: Text +otherTraceIdHex = "4bf92f3577b34da6a3ce929d0e0e4736" + +-- | An invalid UTF-8 byte sequence: @0xC3@ opens a two-byte sequence but +-- @0x28@ is not a valid continuation byte. +invalidUtf8 :: ByteString +invalidUtf8 = "\xc3\x28" + +mkRecord :: + [(ByteString, ByteString)] -> + ConsumerRecord (Maybe ByteString) (Maybe ByteString) +mkRecord headers = + ConsumerRecord + { crTopic = TopicName "demo", + crPartition = PartitionId 0, + crOffset = Offset 0, + crTimestamp = NoTimestamp, + crHeaders = headersFromList headers, + crKey = Nothing, + crValue = Just "value" + } + +emptyProps :: ConsumerProperties +emptyProps = mempty + +-- | Run 'withConsumerSpan' over each record in order against a private +-- tracer provider, and return the exported spans in creation order. +runRecords :: + [ConsumerRecord (Maybe ByteString) (Maybe ByteString)] -> + IO [ImmutableSpan] +runRecords records = do + (processor, spansRef) <- inMemoryListExporter + provider <- createTracerProvider [processor] emptyTracerProviderOptions + let tracer = makeTracer provider "kafka-effectful-test" tracerOptions + runEff $ + mapM_ (\cr -> withConsumerSpan tracer emptyProps cr (pure ())) records + _ <- forceFlushTracerProvider provider Nothing + -- inMemoryListExporter conses each span as it ends, so the list is + -- newest-first; reverse to recover creation order. + reverse <$> readIORef spansRef + +traceIdHexOf :: ImmutableSpan -> Text +traceIdHexOf = traceIdBaseEncodedText Base16 . traceId . spanContext + +-- | Whether a context carries a span at all. Enough to detect a leak, and +-- avoids needing an 'Eq' instance for 'Context'. +hasSpan :: Context.Context -> Bool +hasSpan = maybe False (const True) . Context.lookupSpan + +tests :: TestTree +tests = + -- Establishes the SDK default propagator stack (W3C trace context), + -- which extractTraceContextFromRecord consults via the global lookup. + withResource initializeGlobalTracerProvider (\_ -> pure ()) $ \_ -> + testGroup + "ConsumerSpan" + [ testCase "a record with a traceparent gets the remote trace id" $ do + spans_ <- runRecords [mkRecord [("traceparent", sampleTraceparent)]] + case spans_ of + [s] -> + assertEqual + "span should inherit the inbound trace id" + sampleTraceIdHex + (traceIdHexOf s) + _ -> assertFailure ("expected exactly one span, got " <> show (length spans_)), + -- The KSC-6 regression. Before the fix, withConsumerSpan extracted + -- into the *current* thread-local context and discarded the token + -- it attached, so the previous record's remote context was still + -- installed when this headerless record arrived and its span + -- chained onto it -- contradicting the module's documented "new + -- root span when no inbound context is present". + testCase "a headerless record after a traced record starts a new root" $ do + spans_ <- + runRecords + [ mkRecord [("traceparent", sampleTraceparent)], + mkRecord [] + ] + case spans_ of + [_traced, headerless] -> do + assertBool + ( "headerless record must not inherit the previous record's trace id, got " + <> show (traceIdHexOf headerless) + ) + (traceIdHexOf headerless /= sampleTraceIdHex) + assertBool + "a new root span has no parent" + (maybe True (const False) (spanParent headerless)) + _ -> assertFailure ("expected exactly two spans, got " <> show (length spans_)), + -- The context leak observed from outside: whatever ambient context + -- the caller had must survive the call. Before the fix the + -- thread-local permanently retained the last record's context. + testCase "the caller's ambient context is restored" $ do + ctxBefore <- getContext + _ <- + runRecords + [ mkRecord [("traceparent", sampleTraceparent)], + mkRecord [] + ] + ctxAfter <- getContext + assertEqual + "thread-local context must not retain the last record's context" + (hasSpan ctxBefore) + (hasSpan ctxAfter), + -- The KSC-1 residual. A non-UTF-8 application header must not cost + -- the record its inbound trace context. Before the fix, building + -- the carrier decoded every header with partial decodeUtf8, the + -- exception escaped into the propagator's catch-all, and the whole + -- context -- traceparent included -- was dropped. + testCase "a non-UTF-8 header does not poison extraction" $ do + spans_ <- + runRecords + [ mkRecord + [ ("traceparent", sampleTraceparent), + ("payload-hint", invalidUtf8) + ] + ] + case spans_ of + [s] -> + assertEqual + "inbound trace id must survive an undecodable sibling header" + sampleTraceIdHex + (traceIdHexOf s) + _ -> assertFailure ("expected exactly one span, got " <> show (length spans_)), + -- Pins the PollMessageBatch walk, which calls withConsumerSpan once + -- per record on a single thread. + testCase "each record in a batch is isolated from its neighbours" $ do + spans_ <- + runRecords + [ mkRecord [("traceparent", sampleTraceparent)], + mkRecord [], + mkRecord [("traceparent", otherTraceparent)] + ] + case spans_ of + [first_, middle, third] -> do + assertEqual + "first record keeps its own remote trace" + sampleTraceIdHex + (traceIdHexOf first_) + assertBool + "middle record must be a new root, not a continuation" + (traceIdHexOf middle /= sampleTraceIdHex) + assertEqual + "third record picks up its own remote trace" + otherTraceIdHex + (traceIdHexOf third) + _ -> assertFailure ("expected exactly three spans, got " <> show (length spans_)) + ] diff --git a/test/Kafka/Effectful/OpenTelemetry/PropagationTest.hs b/test/Kafka/Effectful/OpenTelemetry/PropagationTest.hs --- a/test/Kafka/Effectful/OpenTelemetry/PropagationTest.hs +++ b/test/Kafka/Effectful/OpenTelemetry/PropagationTest.hs @@ -6,58 +6,57 @@ import Data.Text (Text) import Data.Text qualified as Text import Data.Text.Encoding qualified as Text.Encoding -import Kafka.Consumer.Types ( - ConsumerRecord (..), +import Kafka.Consumer.Types + ( ConsumerRecord (..), Offset (..), Timestamp (NoTimestamp), - ) -import Kafka.Effectful.OpenTelemetry.Propagation ( - extractTraceContextFromRecord, + ) +import Kafka.Effectful.OpenTelemetry.Propagation + ( extractTraceContextFromRecord, injectTraceContextIntoRecord, kafkaHeadersToRequestHeaders, kafkaHeadersToTextMap, requestHeadersToKafkaHeaders, textMapToKafkaHeaders, - ) -import Kafka.Producer.Types ( - ProducePartition (UnassignedPartition), + ) +import Kafka.Producer.Types + ( ProducePartition (UnassignedPartition), ProducerRecord (..), - ) -import Kafka.Types ( - PartitionId (..), + ) +import Kafka.Types + ( PartitionId (..), TopicName (..), headersFromList, headersToList, - ) + ) import OpenTelemetry.Context qualified as Context import OpenTelemetry.Propagator (textMapLookup) import OpenTelemetry.Trace (initializeGlobalTracerProvider) -import OpenTelemetry.Trace.Core ( - SpanContext (..), +import OpenTelemetry.Trace.Core + ( SpanContext (..), defaultTraceFlags, getSpanContext, wrapSpanContext, - ) -import OpenTelemetry.Trace.Id ( - Base (Base16), + ) +import OpenTelemetry.Trace.Id + ( Base (Base16), SpanId, TraceId, baseEncodedToSpanId, baseEncodedToTraceId, traceIdBaseEncodedText, - ) + ) import OpenTelemetry.Trace.TraceState qualified as TraceState import Test.Tasty (TestTree, testGroup, withResource) import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase) -{- | Known traceparent value derived from the W3C trace-context -specification\'s example. Trace ID -@0af7651916cd43dd8448eb211c80319c@, span ID -@b7ad6b7169203331@, sampled (flag @01@). --} +-- | Known traceparent value derived from the W3C trace-context +-- specification\'s example. Trace ID +-- @0af7651916cd43dd8448eb211c80319c@, span ID +-- @b7ad6b7169203331@, sampled (flag @01@). sampleTraceparent :: ByteString sampleTraceparent = - "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01" + "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01" sampleTraceIdHex :: Text sampleTraceIdHex = "0af7651916cd43dd8448eb211c80319c" @@ -67,143 +66,142 @@ tests :: TestTree tests = - -- Initialize the global tracer provider exactly once for the whole - -- test group. The SDK\'s default propagator pipeline includes - -- @w3cTraceContextPropagator@, which is what - -- @injectTraceContextIntoRecord@ \/ @extractTraceContextFromRecord@ - -- consult under the hood. - withResource initializeGlobalTracerProvider (\_ -> pure ()) $ \_ -> - testGroup - "Propagation" - [ testCase "round-trip kafka headers <-> TextMap" $ do - let original = - headersFromList - [ ("traceparent", sampleTraceparent) - , ("Custom-Header", "value") - ] - roundTripped = - textMapToKafkaHeaders - (kafkaHeadersToTextMap original) - lookup "traceparent" (headersToList roundTripped) - `shouldBeJust` sampleTraceparent - lookup "Custom-Header" (headersToList roundTripped) - `shouldBeJust` "value" - , testCase "kafkaHeadersToTextMap provides case-insensitive lookup" $ do - let h = headersFromList [("TraceParent", sampleTraceparent)] - tm = kafkaHeadersToTextMap h - textMapLookup "traceparent" tm - `shouldBeJust` Text.Encoding.decodeUtf8 sampleTraceparent - , testCase "request header compatibility helpers still case-fold" $ do - let original = - headersFromList - [ ("traceparent", sampleTraceparent) - , ("Custom-Header", "value") - ] - roundTripped = - requestHeadersToKafkaHeaders - (kafkaHeadersToRequestHeaders original) - lookup "traceparent" (headersToList roundTripped) - `shouldBeJust` sampleTraceparent - lookup "custom-header" (headersToList roundTripped) - `shouldBeJust` "value" - , testCase "kafkaHeadersToRequestHeaders preserves traceparent value" $ do - let h = headersFromList [("traceparent", sampleTraceparent)] - rh = kafkaHeadersToRequestHeaders h - lookup (CI.mk "traceparent") rh - `shouldBeJust` sampleTraceparent - , testCase "injectTraceContextIntoRecord adds W3C traceparent" $ do - tid <- decodeHexTraceId sampleTraceIdHex - sid <- decodeHexSpanId sampleSpanIdHex - let ctx = - Context.insertSpan - (wrapSpanContext (frozenContextWith tid sid)) - Context.empty - injected <- - injectTraceContextIntoRecord - ctx - emptyProducerRecord - let injectedHeaders = headersToList (prHeaders injected) - case lookup "traceparent" injectedHeaders of - Nothing -> - assertFailure - "expected the producer record to carry a traceparent header" - Just header -> - assertBool - ( "traceparent did not contain the trace-id " - <> Text.unpack sampleTraceIdHex - <> ", got: " - <> BSC.unpack header - ) - (BSC.pack (Text.unpack sampleTraceIdHex) `BSC.isInfixOf` header) - , testCase "extractTraceContextFromRecord recovers parent context" $ do - let cr = consumerRecordWithHeaders sampleTraceparent - ctx <- - extractTraceContextFromRecord cr Context.empty - case Context.lookupSpan ctx of - Nothing -> - assertFailure - "expected the extracted context to carry a span" - Just span_ -> do - sc <- getSpanContext span_ - let recovered = traceIdBaseEncodedText Base16 (traceId sc) - assertEqual - "recovered trace-id should match the inbound traceparent" - sampleTraceIdHex - recovered - ] + -- Initialize the global tracer provider exactly once for the whole + -- test group. The SDK\'s default propagator pipeline includes + -- @w3cTraceContextPropagator@, which is what + -- @injectTraceContextIntoRecord@ \/ @extractTraceContextFromRecord@ + -- consult under the hood. + withResource initializeGlobalTracerProvider (\_ -> pure ()) $ \_ -> + testGroup + "Propagation" + [ testCase "round-trip kafka headers <-> TextMap" $ do + let original = + headersFromList + [ ("traceparent", sampleTraceparent), + ("Custom-Header", "value") + ] + roundTripped = + textMapToKafkaHeaders + (kafkaHeadersToTextMap original) + lookup "traceparent" (headersToList roundTripped) + `shouldBeJust` sampleTraceparent + lookup "Custom-Header" (headersToList roundTripped) + `shouldBeJust` "value", + testCase "kafkaHeadersToTextMap provides case-insensitive lookup" $ do + let h = headersFromList [("TraceParent", sampleTraceparent)] + tm = kafkaHeadersToTextMap h + textMapLookup "traceparent" tm + `shouldBeJust` Text.Encoding.decodeUtf8 sampleTraceparent, + testCase "request header compatibility helpers still case-fold" $ do + let original = + headersFromList + [ ("traceparent", sampleTraceparent), + ("Custom-Header", "value") + ] + roundTripped = + requestHeadersToKafkaHeaders + (kafkaHeadersToRequestHeaders original) + lookup "traceparent" (headersToList roundTripped) + `shouldBeJust` sampleTraceparent + lookup "custom-header" (headersToList roundTripped) + `shouldBeJust` "value", + testCase "kafkaHeadersToRequestHeaders preserves traceparent value" $ do + let h = headersFromList [("traceparent", sampleTraceparent)] + rh = kafkaHeadersToRequestHeaders h + lookup (CI.mk "traceparent") rh + `shouldBeJust` sampleTraceparent, + testCase "injectTraceContextIntoRecord adds W3C traceparent" $ do + tid <- decodeHexTraceId sampleTraceIdHex + sid <- decodeHexSpanId sampleSpanIdHex + let ctx = + Context.insertSpan + (wrapSpanContext (frozenContextWith tid sid)) + Context.empty + injected <- + injectTraceContextIntoRecord + ctx + emptyProducerRecord + let injectedHeaders = headersToList (prHeaders injected) + case lookup "traceparent" injectedHeaders of + Nothing -> + assertFailure + "expected the producer record to carry a traceparent header" + Just header -> + assertBool + ( "traceparent did not contain the trace-id " + <> Text.unpack sampleTraceIdHex + <> ", got: " + <> BSC.unpack header + ) + (BSC.pack (Text.unpack sampleTraceIdHex) `BSC.isInfixOf` header), + testCase "extractTraceContextFromRecord recovers parent context" $ do + let cr = consumerRecordWithHeaders sampleTraceparent + ctx <- + extractTraceContextFromRecord cr Context.empty + case Context.lookupSpan ctx of + Nothing -> + assertFailure + "expected the extracted context to carry a span" + Just span_ -> do + sc <- getSpanContext span_ + let recovered = traceIdBaseEncodedText Base16 (traceId sc) + assertEqual + "recovered trace-id should match the inbound traceparent" + sampleTraceIdHex + recovered + ] shouldBeJust :: (Eq a, Show a) => Maybe a -> a -> IO () shouldBeJust Nothing expected = - assertFailure ("expected Just " <> show expected <> ", got Nothing") + assertFailure ("expected Just " <> show expected <> ", got Nothing") shouldBeJust (Just actual) expected = - assertEqual "values differ" expected actual + assertEqual "values differ" expected actual decodeHexTraceId :: Text -> IO TraceId decodeHexTraceId hex = - case baseEncodedToTraceId Base16 (BSC.pack (Text.unpack hex)) of - Right tid -> pure tid - Left err -> assertFailure ("invalid hex trace id: " <> err) >> error "unreachable" + case baseEncodedToTraceId Base16 (BSC.pack (Text.unpack hex)) of + Right tid -> pure tid + Left err -> assertFailure ("invalid hex trace id: " <> err) >> error "unreachable" decodeHexSpanId :: Text -> IO SpanId decodeHexSpanId hex = - case baseEncodedToSpanId Base16 (BSC.pack (Text.unpack hex)) of - Right sid -> pure sid - Left err -> assertFailure ("invalid hex span id: " <> err) >> error "unreachable" + case baseEncodedToSpanId Base16 (BSC.pack (Text.unpack hex)) of + Right sid -> pure sid + Left err -> assertFailure ("invalid hex span id: " <> err) >> error "unreachable" -{- | Build a 'SpanContext' that carries the supplied trace and span -IDs. Trace flags are 'defaultTraceFlags' (unsampled); the W3C -propagator preserves the bytes anyway. --} +-- | Build a 'SpanContext' that carries the supplied trace and span +-- IDs. Trace flags are 'defaultTraceFlags' (unsampled); the W3C +-- propagator preserves the bytes anyway. frozenContextWith :: TraceId -> SpanId -> SpanContext frozenContextWith tid sid = - SpanContext - { traceId = tid - , spanId = sid - , traceFlags = defaultTraceFlags - , isRemote = False - , traceState = TraceState.empty - } + SpanContext + { traceId = tid, + spanId = sid, + traceFlags = defaultTraceFlags, + isRemote = False, + traceState = TraceState.empty + } emptyProducerRecord :: ProducerRecord emptyProducerRecord = - ProducerRecord - { prTopic = TopicName "demo" - , prPartition = UnassignedPartition - , prKey = Nothing - , prValue = Just "value" - , prHeaders = headersFromList [] - } + ProducerRecord + { prTopic = TopicName "demo", + prPartition = UnassignedPartition, + prKey = Nothing, + prValue = Just "value", + prHeaders = headersFromList [] + } consumerRecordWithHeaders :: - ByteString -> - ConsumerRecord (Maybe ByteString) (Maybe ByteString) + ByteString -> + ConsumerRecord (Maybe ByteString) (Maybe ByteString) consumerRecordWithHeaders traceparent = - ConsumerRecord - { crTopic = TopicName "demo" - , crPartition = PartitionId 0 - , crOffset = Offset 0 - , crTimestamp = NoTimestamp - , crHeaders = headersFromList [("traceparent", traceparent)] - , crKey = Nothing - , crValue = Just "value" - } + ConsumerRecord + { crTopic = TopicName "demo", + crPartition = PartitionId 0, + crOffset = Offset 0, + crTimestamp = NoTimestamp, + crHeaders = headersFromList [("traceparent", traceparent)], + crKey = Nothing, + crValue = Just "value" + } diff --git a/test/Kafka/Effectful/OpenTelemetry/SemanticTest.hs b/test/Kafka/Effectful/OpenTelemetry/SemanticTest.hs --- a/test/Kafka/Effectful/OpenTelemetry/SemanticTest.hs +++ b/test/Kafka/Effectful/OpenTelemetry/SemanticTest.hs @@ -6,177 +6,177 @@ import Data.Int (Int64) import Data.Text (Text) import Kafka.Consumer.ConsumerProperties qualified as ConsumerProperties -import Kafka.Consumer.Types ( - ConsumerGroupId (..), +import Kafka.Consumer.Types + ( ConsumerGroupId (..), ConsumerRecord (..), Offset (..), Timestamp (NoTimestamp), - ) -import Kafka.Effectful.OpenTelemetry.Semantic ( - consumerRecordAttributes, + ) +import Kafka.Effectful.OpenTelemetry.Semantic + ( consumerRecordAttributes, consumerRecordAttributesWith, producerRecordAttributes, producerRecordAttributesWith, - ) -import Kafka.Producer.Types ( - ProducePartition (SpecifiedPartition, UnassignedPartition), + ) +import Kafka.Producer.Types + ( ProducePartition (SpecifiedPartition, UnassignedPartition), ProducerRecord (..), - ) -import Kafka.Types ( - ClientId (..), + ) +import Kafka.Types + ( ClientId (..), PartitionId (..), TopicName (..), headersFromList, - ) -import OpenTelemetry.Attributes.Attribute ( - Attribute (AttributeValue), + ) +import OpenTelemetry.Attributes.Attribute + ( Attribute (AttributeValue), PrimitiveAttribute (IntAttribute, TextAttribute), - ) + ) import OpenTelemetry.SemanticsConfig (StabilityOpt (..)) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) tests :: TestTree tests = - testGroup - "Semantic" - [ producerTests - , consumerTests - ] + testGroup + "Semantic" + [ producerTests, + consumerTests + ] producerTests :: TestTree producerTests = - testGroup - "producerRecordAttributes" - [ testCase "legacy helper keeps old operation key" $ do - let attrs = producerRecordAttributes (sampleProducerRecord (Just "k1")) - HashMap.lookup "messaging.system" attrs @?= Just (textAttr "kafka") - HashMap.lookup "messaging.destination.name" attrs @?= Just (textAttr "orders") - HashMap.lookup "messaging.operation" attrs @?= Just (textAttr "send") - assertAbsent "messaging.operation.name" attrs - assertAbsent "messaging.operation.type" attrs - , testCase "stable mode uses stable operation keys" $ do - let attrs = producerRecordAttributesWith Stable (sampleProducerRecord (Just "k1")) - HashMap.lookup "messaging.operation.name" attrs @?= Just (textAttr "send") - HashMap.lookup "messaging.operation.type" attrs @?= Just (textAttr "send") - assertAbsent "messaging.operation" attrs - , testCase "duplicate mode emits old and stable operation keys" $ do - let attrs = producerRecordAttributesWith StableAndOld (sampleProducerRecord (Just "k1")) - HashMap.lookup "messaging.operation" attrs @?= Just (textAttr "send") - HashMap.lookup "messaging.operation.name" attrs @?= Just (textAttr "send") - HashMap.lookup "messaging.operation.type" attrs @?= Just (textAttr "send") - , testCase "adds partition, key, and body size when available" $ do - let attrs = producerRecordAttributesWith Old (sampleProducerRecord (Just "hello")) - HashMap.lookup "messaging.kafka.destination.partition" attrs - @?= Just (intAttr 42) - HashMap.lookup "messaging.kafka.message.key" attrs - @?= Just (textAttr "hello") - HashMap.lookup "messaging.message.body.size" attrs - @?= Just (intAttr 5) - , testCase "omits partition for UnassignedPartition" $ do - let attrs = - producerRecordAttributesWith - Old - (sampleProducerRecord (Just "k1")) - { prPartition = UnassignedPartition - } - assertAbsent "messaging.kafka.destination.partition" attrs - , testCase "omits invalid or absent keys" $ do - let invalidAttrs = - producerRecordAttributesWith - Old - (sampleProducerRecord (Just (BS.pack [0xC3, 0x28]))) - missingAttrs = - producerRecordAttributesWith Old (sampleProducerRecord Nothing) - assertAbsent "messaging.kafka.message.key" invalidAttrs - assertAbsent "messaging.kafka.message.key" missingAttrs - ] + testGroup + "producerRecordAttributes" + [ testCase "legacy helper keeps old operation key" $ do + let attrs = producerRecordAttributes (sampleProducerRecord (Just "k1")) + HashMap.lookup "messaging.system" attrs @?= Just (textAttr "kafka") + HashMap.lookup "messaging.destination.name" attrs @?= Just (textAttr "orders") + HashMap.lookup "messaging.operation" attrs @?= Just (textAttr "send") + assertAbsent "messaging.operation.name" attrs + assertAbsent "messaging.operation.type" attrs, + testCase "stable mode uses stable operation keys" $ do + let attrs = producerRecordAttributesWith Stable (sampleProducerRecord (Just "k1")) + HashMap.lookup "messaging.operation.name" attrs @?= Just (textAttr "send") + HashMap.lookup "messaging.operation.type" attrs @?= Just (textAttr "send") + assertAbsent "messaging.operation" attrs, + testCase "duplicate mode emits old and stable operation keys" $ do + let attrs = producerRecordAttributesWith StableAndOld (sampleProducerRecord (Just "k1")) + HashMap.lookup "messaging.operation" attrs @?= Just (textAttr "send") + HashMap.lookup "messaging.operation.name" attrs @?= Just (textAttr "send") + HashMap.lookup "messaging.operation.type" attrs @?= Just (textAttr "send"), + testCase "adds partition, key, and body size when available" $ do + let attrs = producerRecordAttributesWith Old (sampleProducerRecord (Just "hello")) + HashMap.lookup "messaging.kafka.destination.partition" attrs + @?= Just (intAttr 42) + HashMap.lookup "messaging.kafka.message.key" attrs + @?= Just (textAttr "hello") + HashMap.lookup "messaging.message.body.size" attrs + @?= Just (intAttr 5), + testCase "omits partition for UnassignedPartition" $ do + let attrs = + producerRecordAttributesWith + Old + (sampleProducerRecord (Just "k1")) + { prPartition = UnassignedPartition + } + assertAbsent "messaging.kafka.destination.partition" attrs, + testCase "omits invalid or absent keys" $ do + let invalidAttrs = + producerRecordAttributesWith + Old + (sampleProducerRecord (Just (BS.pack [0xC3, 0x28]))) + missingAttrs = + producerRecordAttributesWith Old (sampleProducerRecord Nothing) + assertAbsent "messaging.kafka.message.key" invalidAttrs + assertAbsent "messaging.kafka.message.key" missingAttrs + ] consumerTests :: TestTree consumerTests = - testGroup - "consumerRecordAttributes" - [ testCase "legacy helper keeps old operation key" $ do - let attrs = consumerRecordAttributes (sampleConsumerRecord (Just "k1")) - HashMap.lookup "messaging.system" attrs @?= Just (textAttr "kafka") - HashMap.lookup "messaging.destination.name" attrs @?= Just (textAttr "orders") - HashMap.lookup "messaging.operation" attrs @?= Just (textAttr "process") - assertAbsent "messaging.operation.name" attrs - assertAbsent "messaging.operation.type" attrs - , testCase "old mode uses legacy consumer group key" $ do - let attrs = consumerRecordAttributesWith Old sampleConsumerProps (sampleConsumerRecord (Just "k1")) - HashMap.lookup "messaging.kafka.consumer.group" attrs - @?= Just (textAttr "orders-group") - assertAbsent "messaging.consumer.group.name" attrs - , testCase "stable mode uses stable operation and consumer group keys" $ do - let attrs = consumerRecordAttributesWith Stable sampleConsumerProps (sampleConsumerRecord (Just "k1")) - HashMap.lookup "messaging.operation.name" attrs @?= Just (textAttr "process") - HashMap.lookup "messaging.operation.type" attrs @?= Just (textAttr "process") - HashMap.lookup "messaging.consumer.group.name" attrs - @?= Just (textAttr "orders-group") - assertAbsent "messaging.operation" attrs - assertAbsent "messaging.kafka.consumer.group" attrs - , testCase "duplicate mode emits old and stable operation and group keys" $ do - let attrs = consumerRecordAttributesWith StableAndOld sampleConsumerProps (sampleConsumerRecord (Just "k1")) - HashMap.lookup "messaging.operation" attrs @?= Just (textAttr "process") - HashMap.lookup "messaging.operation.name" attrs @?= Just (textAttr "process") - HashMap.lookup "messaging.operation.type" attrs @?= Just (textAttr "process") - HashMap.lookup "messaging.kafka.consumer.group" attrs - @?= Just (textAttr "orders-group") - HashMap.lookup "messaging.consumer.group.name" attrs - @?= Just (textAttr "orders-group") - , testCase "adds client id, partition, offset, key, and body size" $ do - let attrs = consumerRecordAttributesWith Old sampleConsumerProps (sampleConsumerRecord (Just "hello")) - HashMap.lookup "messaging.client.id" attrs - @?= Just (textAttr "orders-client") - HashMap.lookup "messaging.kafka.destination.partition" attrs - @?= Just (intAttr 7) - HashMap.lookup "messaging.kafka.message.offset" attrs - @?= Just (intAttr 42) - HashMap.lookup "messaging.kafka.message.key" attrs - @?= Just (textAttr "hello") - HashMap.lookup "messaging.message.body.size" attrs - @?= Just (intAttr 5) - , testCase "omits invalid or absent keys" $ do - let invalidAttrs = - consumerRecordAttributesWith - Old - sampleConsumerProps - (sampleConsumerRecord (Just (BS.pack [0xC3, 0x28]))) - missingAttrs = - consumerRecordAttributesWith Old sampleConsumerProps (sampleConsumerRecord Nothing) - assertAbsent "messaging.kafka.message.key" invalidAttrs - assertAbsent "messaging.kafka.message.key" missingAttrs - ] + testGroup + "consumerRecordAttributes" + [ testCase "legacy helper keeps old operation key" $ do + let attrs = consumerRecordAttributes (sampleConsumerRecord (Just "k1")) + HashMap.lookup "messaging.system" attrs @?= Just (textAttr "kafka") + HashMap.lookup "messaging.destination.name" attrs @?= Just (textAttr "orders") + HashMap.lookup "messaging.operation" attrs @?= Just (textAttr "process") + assertAbsent "messaging.operation.name" attrs + assertAbsent "messaging.operation.type" attrs, + testCase "old mode uses legacy consumer group key" $ do + let attrs = consumerRecordAttributesWith Old sampleConsumerProps (sampleConsumerRecord (Just "k1")) + HashMap.lookup "messaging.kafka.consumer.group" attrs + @?= Just (textAttr "orders-group") + assertAbsent "messaging.consumer.group.name" attrs, + testCase "stable mode uses stable operation and consumer group keys" $ do + let attrs = consumerRecordAttributesWith Stable sampleConsumerProps (sampleConsumerRecord (Just "k1")) + HashMap.lookup "messaging.operation.name" attrs @?= Just (textAttr "process") + HashMap.lookup "messaging.operation.type" attrs @?= Just (textAttr "process") + HashMap.lookup "messaging.consumer.group.name" attrs + @?= Just (textAttr "orders-group") + assertAbsent "messaging.operation" attrs + assertAbsent "messaging.kafka.consumer.group" attrs, + testCase "duplicate mode emits old and stable operation and group keys" $ do + let attrs = consumerRecordAttributesWith StableAndOld sampleConsumerProps (sampleConsumerRecord (Just "k1")) + HashMap.lookup "messaging.operation" attrs @?= Just (textAttr "process") + HashMap.lookup "messaging.operation.name" attrs @?= Just (textAttr "process") + HashMap.lookup "messaging.operation.type" attrs @?= Just (textAttr "process") + HashMap.lookup "messaging.kafka.consumer.group" attrs + @?= Just (textAttr "orders-group") + HashMap.lookup "messaging.consumer.group.name" attrs + @?= Just (textAttr "orders-group"), + testCase "adds client id, partition, offset, key, and body size" $ do + let attrs = consumerRecordAttributesWith Old sampleConsumerProps (sampleConsumerRecord (Just "hello")) + HashMap.lookup "messaging.client.id" attrs + @?= Just (textAttr "orders-client") + HashMap.lookup "messaging.kafka.destination.partition" attrs + @?= Just (intAttr 7) + HashMap.lookup "messaging.kafka.message.offset" attrs + @?= Just (intAttr 42) + HashMap.lookup "messaging.kafka.message.key" attrs + @?= Just (textAttr "hello") + HashMap.lookup "messaging.message.body.size" attrs + @?= Just (intAttr 5), + testCase "omits invalid or absent keys" $ do + let invalidAttrs = + consumerRecordAttributesWith + Old + sampleConsumerProps + (sampleConsumerRecord (Just (BS.pack [0xC3, 0x28]))) + missingAttrs = + consumerRecordAttributesWith Old sampleConsumerProps (sampleConsumerRecord Nothing) + assertAbsent "messaging.kafka.message.key" invalidAttrs + assertAbsent "messaging.kafka.message.key" missingAttrs + ] sampleProducerRecord :: Maybe ByteString -> ProducerRecord sampleProducerRecord key = - ProducerRecord - { prTopic = TopicName "orders" - , prPartition = SpecifiedPartition 42 - , prKey = key - , prValue = Just "value" - , prHeaders = headersFromList [] - } + ProducerRecord + { prTopic = TopicName "orders", + prPartition = SpecifiedPartition 42, + prKey = key, + prValue = Just "value", + prHeaders = headersFromList [] + } sampleConsumerRecord :: - Maybe ByteString -> - ConsumerRecord (Maybe ByteString) (Maybe ByteString) + Maybe ByteString -> + ConsumerRecord (Maybe ByteString) (Maybe ByteString) sampleConsumerRecord key = - ConsumerRecord - { crTopic = TopicName "orders" - , crPartition = PartitionId 7 - , crOffset = Offset 42 - , crTimestamp = NoTimestamp - , crHeaders = headersFromList [] - , crKey = key - , crValue = Just "value" - } + ConsumerRecord + { crTopic = TopicName "orders", + crPartition = PartitionId 7, + crOffset = Offset 42, + crTimestamp = NoTimestamp, + crHeaders = headersFromList [], + crKey = key, + crValue = Just "value" + } sampleConsumerProps :: ConsumerProperties.ConsumerProperties sampleConsumerProps = - ConsumerProperties.groupId (ConsumerGroupId "orders-group") - <> ConsumerProperties.clientId (ClientId "orders-client") + ConsumerProperties.groupId (ConsumerGroupId "orders-group") + <> ConsumerProperties.clientId (ClientId "orders-client") textAttr :: Text -> Attribute textAttr = AttributeValue . TextAttribute @@ -186,11 +186,11 @@ assertAbsent :: Text -> HashMap.HashMap Text Attribute -> IO () assertAbsent key attrs = - case HashMap.lookup key attrs of - Nothing -> pure () - Just attr -> - assertFailure $ - "expected " - <> show key - <> " to be absent, got " - <> show attr + case HashMap.lookup key attrs of + Nothing -> pure () + Just attr -> + assertFailure $ + "expected " + <> show key + <> " to be absent, got " + <> show attr diff --git a/test/Kafka/Effectful/OpenTelemetry/ShibuyaCompatibilityTest.hs b/test/Kafka/Effectful/OpenTelemetry/ShibuyaCompatibilityTest.hs --- a/test/Kafka/Effectful/OpenTelemetry/ShibuyaCompatibilityTest.hs +++ b/test/Kafka/Effectful/OpenTelemetry/ShibuyaCompatibilityTest.hs @@ -3,55 +3,54 @@ import Data.HashMap.Lazy qualified as HashMap import Data.Int (Int64) import Data.Text (Text) -import Kafka.Consumer.Types ( - ConsumerRecord (..), +import Kafka.Consumer.Types + ( ConsumerRecord (..), Offset (..), Timestamp (NoTimestamp), - ) + ) import Kafka.Effectful.OpenTelemetry.Semantic (consumerRecordAttributes) -import Kafka.Types ( - PartitionId (..), +import Kafka.Types + ( PartitionId (..), TopicName (..), headersFromList, - ) + ) import OpenTelemetry.Attributes (Attribute, toAttribute, unkey) -import OpenTelemetry.SemanticConventions ( - messaging_kafka_destination_partition, +import OpenTelemetry.SemanticConventions + ( messaging_kafka_destination_partition, messaging_kafka_message_offset, - ) + ) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertEqual, testCase) -{- | Tests pinning @Kafka.Effectful.OpenTelemetry.Semantic@\'s legacy -'consumerRecordAttributes' helper against the attribute set that -@shibuya-kafka-adapter@\'s -@Shibuya.Adapter.Kafka.Convert.kafkaSpanAttributes@ produces. - -Both libraries depend on @hs-opentelemetry-semantic-conventions@, -so if upstream renames a key in a future release this test fails -together with shibuya for the legacy-mode compatibility pin. Stable -OpenTelemetry messaging keys are covered separately in -@SemanticTest@. --} +-- | Tests pinning @Kafka.Effectful.OpenTelemetry.Semantic@\'s legacy +-- 'consumerRecordAttributes' helper against the attribute set that +-- @shibuya-kafka-adapter@\'s +-- @Shibuya.Adapter.Kafka.Convert.kafkaSpanAttributes@ produces. +-- +-- Both libraries depend on @hs-opentelemetry-semantic-conventions@, +-- so if upstream renames a key in a future release this test fails +-- together with shibuya for the legacy-mode compatibility pin. Stable +-- OpenTelemetry messaging keys are covered separately in +-- @SemanticTest@. tests :: TestTree tests = - testGroup - "ShibuyaCompatibility" - [ testCase "consumerRecordAttributes agrees on messaging.system" $ do - let actual = HashMap.lookup "messaging.system" sampleAttrs - expected = HashMap.lookup "messaging.system" shibuyaAttrs - assertEqual "messaging.system attribute differs" expected actual - , testCase "consumerRecordAttributes agrees on messaging.kafka.destination.partition" $ do - let key = unkey messaging_kafka_destination_partition - actual = HashMap.lookup key sampleAttrs - expected = HashMap.lookup key shibuyaAttrs - assertEqual "partition attribute differs" expected actual - , testCase "consumerRecordAttributes agrees on messaging.kafka.message.offset" $ do - let key = unkey messaging_kafka_message_offset - actual = HashMap.lookup key sampleAttrs - expected = HashMap.lookup key shibuyaAttrs - assertEqual "offset attribute differs" expected actual - ] + testGroup + "ShibuyaCompatibility" + [ testCase "consumerRecordAttributes agrees on messaging.system" $ do + let actual = HashMap.lookup "messaging.system" sampleAttrs + expected = HashMap.lookup "messaging.system" shibuyaAttrs + assertEqual "messaging.system attribute differs" expected actual, + testCase "consumerRecordAttributes agrees on messaging.kafka.destination.partition" $ do + let key = unkey messaging_kafka_destination_partition + actual = HashMap.lookup key sampleAttrs + expected = HashMap.lookup key shibuyaAttrs + assertEqual "partition attribute differs" expected actual, + testCase "consumerRecordAttributes agrees on messaging.kafka.message.offset" $ do + let key = unkey messaging_kafka_message_offset + actual = HashMap.lookup key sampleAttrs + expected = HashMap.lookup key shibuyaAttrs + assertEqual "offset attribute differs" expected actual + ] -- Sample inputs — partition 7, offset 42 — chosen so the resulting -- attribute values are non-zero and easy to spot in failures. @@ -64,42 +63,39 @@ sampleAttrs :: HashMap.HashMap Text Attribute sampleAttrs = - consumerRecordAttributes - ConsumerRecord - { crTopic = TopicName "orders" - , crPartition = samplePid - , crOffset = sampleOffset - , crTimestamp = NoTimestamp - , crHeaders = headersFromList [] - , crKey = Nothing - , crValue = Just "value" - } - -{- | Local replica of @shibuya-kafka-adapter@\'s -@Shibuya.Adapter.Kafka.Convert.kafkaSpanAttributes@. Mirrors the -exact source-level expression at -@shibuya-kafka-adapter\/src\/Shibuya\/Adapter\/Kafka\/Convert.hs:78-89@: + consumerRecordAttributes + ConsumerRecord + { crTopic = TopicName "orders", + crPartition = samplePid, + crOffset = sampleOffset, + crTimestamp = NoTimestamp, + crHeaders = headersFromList [], + crKey = Nothing, + crValue = Just "value" + } -> kafkaSpanAttributes :: PartitionId -> Offset -> HashMap Text Attribute -> kafkaSpanAttributes (PartitionId pid) (Offset off) = -> HashMap.fromList -> [ (\"messaging.system\", toAttribute (\"kafka\" :: Text)) -> , (unkey messaging_kafka_destination_partition, toAttribute (fromIntegral pid :: Int64)) -> , (unkey messaging_kafka_message_offset, toAttribute (off :: Int64)) -> ] --} +-- | Local replica of @shibuya-kafka-adapter@\'s +-- @Shibuya.Adapter.Kafka.Convert.kafkaSpanAttributes@. Mirrors the +-- exact source-level expression at +-- @shibuya-kafka-adapter\/src\/Shibuya\/Adapter\/Kafka\/Convert.hs:78-89@: +-- +-- > kafkaSpanAttributes :: PartitionId -> Offset -> HashMap Text Attribute +-- > kafkaSpanAttributes (PartitionId pid) (Offset off) = +-- > HashMap.fromList +-- > [ (\"messaging.system\", toAttribute (\"kafka\" :: Text)) +-- > , (unkey messaging_kafka_destination_partition, toAttribute (fromIntegral pid :: Int64)) +-- > , (unkey messaging_kafka_message_offset, toAttribute (off :: Int64)) +-- > ] shibuyaAttrs :: HashMap.HashMap Text Attribute shibuyaAttrs = - let PartitionId pid = samplePid - Offset off = sampleOffset - in HashMap.fromList - [ ("messaging.system", toAttribute ("kafka" :: Text)) - , - ( unkey messaging_kafka_destination_partition - , toAttribute (fromIntegral pid :: Int64) - ) - , - ( unkey messaging_kafka_message_offset - , toAttribute (off :: Int64) - ) - ] + let PartitionId pid = samplePid + Offset off = sampleOffset + in HashMap.fromList + [ ("messaging.system", toAttribute ("kafka" :: Text)), + ( unkey messaging_kafka_destination_partition, + toAttribute (fromIntegral pid :: Int64) + ), + ( unkey messaging_kafka_message_offset, + toAttribute (off :: Int64) + ) + ] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,5 +1,8 @@ module Main (main) where +import Kafka.Effectful.Consumer.ClassifyTest qualified as ClassifyTest +import Kafka.Effectful.Consumer.InterpreterTest qualified as InterpreterTest +import Kafka.Effectful.OpenTelemetry.ConsumerSpanTest qualified as ConsumerSpanTest import Kafka.Effectful.OpenTelemetry.PropagationTest qualified as PropagationTest import Kafka.Effectful.OpenTelemetry.SemanticTest qualified as SemanticTest import Kafka.Effectful.OpenTelemetry.ShibuyaCompatibilityTest qualified as ShibuyaCompatibilityTest @@ -10,9 +13,18 @@ tests :: TestTree tests = - testGroup + testGroup + "kafka-effectful" + [ testGroup "Kafka.Effectful.OpenTelemetry" - [ SemanticTest.tests - , PropagationTest.tests - , ShibuyaCompatibilityTest.tests + [ SemanticTest.tests, + PropagationTest.tests, + ShibuyaCompatibilityTest.tests, + ConsumerSpanTest.tests + ], + testGroup + "Kafka.Effectful.Consumer" + [ ClassifyTest.tests, + InterpreterTest.tests ] + ]