packages feed

effectful-tracing (empty) → 0.1.0.0

raw patch · 76 files changed

+14813/−0 lines, 76 filesdep +amqpdep +asyncdep +base

Dependencies added: amqp, async, base, bytestring, case-insensitive, clock, containers, crypton, effectful, effectful-core, effectful-tracing, hashable, hedgehog, hs-opentelemetry-api, http-client, http-types, nothunks, postgresql-simple, random, servant, servant-server, sqlite-simple, stm, tasty, tasty-bench, tasty-golden, tasty-hedgehog, tasty-hunit, temporary, text, time, valiant, valiant-effectful, vault, vector, wai, warp

Files

+ CHANGELOG.md view
@@ -0,0 +1,520 @@+# Changelog++All notable changes to `effectful-tracing` are documented here. The format+follows [Keep a Changelog](https://keepachangelog.com/en/1.1.0/), and the+project aims to be PVP-compliant.++## 0.1.0.0 - 2026-05-26++The first release: the `Tracer` effect; four interpreters (no-op, in-memory,+pretty-print, OpenTelemetry); W3C Trace Context, B3, and Jaeger propagation+(composable, and configurable from `OTEL_` environment variables); sampling;+span limits; async context propagation; baggage; a log-correlation bridge;+in-test assertions; and instrumentation helpers for WAI, http-client, Servant,+databases (postgresql-simple, sqlite-simple, valiant), and message queues+(RabbitMQ via amqp).++### Added++- `Effectful.Tracing.SemConv`, a small module of typed constants for the+  OpenTelemetry semantic-convention attribute keys the library emits+  (`http.request.method`, `url.full`, `http.response.status_code`, and so on).+  The WAI and http-client instrumentation and the exception event now name their+  attributes from this one place, and the keys track the stable HTTP / URL+  conventions rather than the pre-stable `http.method` / `http.url` /+  `http.status_code` names. The WAI middleware now splits the request target into+  `url.path` and `url.query` (the latter only when a query string is present),+  and reports the protocol as `network.protocol.version`.+- Support for GHC 9.6 and 9.8 alongside 9.10. The `base` lower bound is relaxed+  to `>=4.18` (with `bytestring`/`text` lower bounds widened to match), and+  `foldl'` is imported from `Data.List` on bases before 4.20, where it is not yet+  re-exported from `Prelude`. CI now runs the build-and-test job across all three+  compilers, adds a job that builds and tests with every optional cabal flag+  enabled (the set grew as later flags landed; see those entries), and gates+  Haddock on broken doc-links. No `cabal.project.freeze` is committed, so each+  compiler solves its own consistent dependency set.+- Two release-hardening CI jobs. A `publish-readiness` job runs `cabal check`+  (the same gate Hackage applies on upload) and then builds the library and+  tests from a `cabal sdist` tarball rather than the working tree, proving the+  source distribution ships everything needed to compile. A `lower-bounds` job+  builds and tests the default package with `--prefer-oldest` on the oldest+  supported GHC (9.6.7, base 4.18), so the declared lower bounds are exercised+  rather than assumed. The optional-instrumentation flags are excluded from the+  lower-bounds job because their heavy transitive chains (the OTel stack, and a+  Warp server in the http-client tests) have oldest published versions that+  predate the supported GHC range and fail to compile there, so minimizing them+  would test third parties' GHC compatibility rather than our bounds.+- macOS and Windows coverage in CI. The build-and-test job now runs on a+  three-OS matrix: the full GHC range (9.6, 9.8, 9.10) on Linux, and the latest+  supported GHC on macOS and Windows, where a platform-specific break (path+  handling, line endings, the temp-file based interpreter tests) is most likely+  to surface. The cabal store cache path is taken from the setup action's output+  rather than hard-coded, so it resolves correctly on every runner.+- A `bench-gate` CI job that runs the `tasty-bench` suite as a regression gate.+  The realistic-op comparison uses `bcompareWithin` with a 1.20 upper bound, so+  the benchmark process exits non-zero (failing the job) on a gross per-span+  overhead regression. The bound is deliberately loose because CI runners are+  noisy shared VMs: the gate catches order-of-magnitude regressions, while the+  tighter 5% target is tracked on a quiet machine.+- New `secure-ids` cabal flag (off by default). When enabled, trace and span+  identifiers are minted from `crypton`'s cryptographically secure system+  entropy instead of the default fast splitmix PRNG, for callers who need ids+  that are unpredictable to an attacker. The `newTraceId` / `newSpanId` surface+  is unchanged; only the byte source is swapped, and `crypton` is pulled in only+  when the flag is on.+- Expanded unit and property coverage for the pure surface that the interpreter+  tests previously only exercised indirectly: `Effectful.Tracing.TypesSpec`+  (status-transition rules, trace-state dedup/capacity/validation, trace-flags+  bit manipulation), `Effectful.Tracing.AttributeSpec` (one case per+  `ToAttributeValue` instance plus the int/float widening properties),+  `Effectful.Tracing.IdsSpec` (hex parsing, byte construction, and validity+  checks), and `Effectful.Tracing.LifecycleSpec` (remote-parent continuation,+  in-thread linked roots, explicit start times, and the status/exception+  semantics). `Effectful.Tracing.SamplerSpec` also now asserts that a sampler's+  extra attributes and replacement trace state are applied to the opened span.+- Robustness and translation property tests: a fuzz suite+  (`Effectful.Tracing.FuzzSpec`) that feeds uniformly random and+  traceparent-shaped input to `extractContext`, `traceIdFromHex`,+  `spanIdFromHex`, and `traceStateFromHeader` and asserts each is total (always+  terminates, never throws) and well-formed; and a property+  (`toImmutableSpan (property)`) checking the OpenTelemetry translation is+  lossless on trace id, span id, name, kind, status, and distinct attribute+  count for any generated span.+- Thunk-retention regression test (`Effectful.Tracing.ThunkSpec`): runs a nested+  traced computation through the in-memory interpreter and asserts with+  `nothunks` that each completed `Span` carries no unexpected thunk. The check is+  deliberately precise (strict scalar structure deeply, the intentionally+  spine-lazy attribute/event/link lists to WHNF), so it guards the lifecycle's+  WHNF guarantee without false-positiving on the lazy list tails. The+  `nothunks` dependency and its orphan instances are test-only, so the published+  package takes on no new dependency. This test is what surfaced the+  `spanParentContext` retention fixed above.+- Async-exception finalization tests (`Effectful.Tracing.AsyncExceptionSpec`):+  `withSpan` finalizes its span on every exit, not just a clean return, because+  finalization runs inside `generalBracket`. These interrupt a span body three+  ways: a synchronous exception, a `timeout` cancellation, and an asynchronous+  `killThread` of a forked thread, and assert that in each case the span still+  reaches the sink with its end time set, an `Error` status, and an `exception`+  event. The `killThread` case also exercises the active span surviving a+  `forkIO`.+- Space-leak regression guard (`effectful-tracing-space-leak`): a standalone+  test executable, separate from the tasty suite, that opens and closes 100,000+  spans through the in-memory interpreter and forces every captured span with a+  strict fold, run under a deliberately tiny maximum stack (`-K1K`). A+  thunk-accumulation regression in the span lifecycle (a lazy accumulator, a+  non-strict sink write, an un-forced field) would defer that work into an O(n)+  evaluation stack and overflow the 1K limit; the current strict lifecycle runs+  it in O(1) stack. It is kept out of the tasty suite because the property tests+  legitimately need a larger stack and so cannot share these RTS options.+- Pretty-print buffer-drain test (`Effectful.Tracing.PrettyPrintLeakSpec`): the+  pretty-print interpreter buffers each in-flight trace's spans in a+  `TVar (Map TraceId [Span])` and flushes (renders and deletes) a trace the+  moment its root span closes, so a finished trace left behind would grow that+  map without bound over a long-running process. This drives a program through a+  new buffer-observing seam (`runTracerPrettyWith`) and asserts both that+  already-closed children are held while their root is still open (the buffering+  is real) and that the map is empty once every root has closed (nothing is+  retained), while confirming each trace was rendered exactly once.+- Id generator tests (`Effectful.Tracing.IdGenSpec`): the existing id tests+  pinned the codec and validity edges but never exercised the generators+  themselves, so the `secure-ids` byte source went untested. These assert that a+  freshly generated id is valid, round-trips through hex, and that a batch of+  10,000 is collision-free. They run whichever source the library was built+  with, so the all-flags CI job (`+secure-ids`) now covers the `crypton`+  system-entropy path while the default build covers the splitmix PRNG; the test+  label names which source is under test.+- Compile-checked documentation examples: `Effectful.Tracing.CompileTest` now+  mirrors every Haskell code block in `README.md`, `docs/tutorial.md`, and+  `docs/cookbook.md` against the real API, so a renamed export or changed+  signature turns the test suite red and flags the docs as stale. The blocks are+  deliberately illustrative fragments (undefined placeholder names, scattered+  imports, bare expressions), which neither cabal-docspec (it only evaluates+  `>>>` examples, of which the project has none) nor markdown-unlit can compile+  in place; the mirrors reproduce their API usage instead, stubbing the+  placeholder types once. Examples that need a cabal flag (`wai`, `http-client`,+  `otel`) are guarded with CPP so they are checked by the all-flags CI job.+- Documentation and example: a guided [tutorial](docs/tutorial.md)+  from a pretty-printed trace to OpenTelemetry export against a local Jaeger, a+  [cookbook](docs/cookbook.md) of focused recipes (trace an existing function,+  attach structured fields, sample but keep what matters, connect inbound and+  outbound HTTP traces, instrument a long-running worker), and a runnable+  [`examples/servant-app`](examples/servant-app) Servant service whose inbound+  `server` span and outbound `client` span join into one trace in Jaeger.+- Two runnable examples that need no collector ([`examples/local-dev`](examples/local-dev)),+  each built in CI against the in-tree library with default flags: a `worker`+  loop with one span per job, an interpreter chosen at runtime via `ET_TRACER`+  (pretty / no-op / in-memory), an error-recording span, and a linked background+  trace; and a `sampling` program that runs the cookbook's "keep all priority+  spans, ~1% of routine spans" custom sampler through the in-memory interpreter.+  The README's supported-GHC list is also corrected to name all three tested+  compilers (9.6.7 / 9.8.4 / 9.10.3) rather than only 9.10.3.+- http-client tracing wrapper, behind the new `http-client` cabal flag+  (off by default, so the base package does not depend on `http-client`):+  `Effectful.Tracing.Instrumentation.HttpClient` provides `httpLbsTraced`, which+  runs an `http-client` request inside a `client`-kind span. It injects the+  active context as `traceparent` / `tracestate` into the outbound request (so+  the downstream hop continues this trace), records `http.request.method` and+  `url.full` at span start and `http.response.status_code` on the response (a+  status `>= 400` sets the span status to error), and relies on the shared span+  lifecycle to record any thrown exception. The API stays in `Eff es` (no unlift+  needed); the `Manager`-hook approach is intentionally omitted because the hooks+  run in `IO` with no effect context. Attributes follow the stable OpenTelemetry+  HTTP semantic conventions. Tested against a loopback Warp server that confirms+  end-to-end propagation (the server receives a `traceparent` carrying the client+  span's trace id) along with the attributes and status mapping.+- New `http-client` cabal flag gating the wrapper and its `http-client`+  dependency (`>=0.7 && <0.8`) for the library; the test suite additionally uses+  `wai` and `warp` (`>=3.3 && <3.5`) for the loopback server.+- WAI tracing middleware, behind the new `wai` cabal flag (off by+  default, so the base package does not depend on `wai`):+  `Effectful.Tracing.Instrumentation.Wai` provides `traceMiddleware` (and+  `traceMiddlewareWith` for custom span naming), which wraps each request in a+  `server`-kind span. It continues an inbound distributed trace by reading+  `traceparent` / `tracestate`, attaches `http.request.method`, `url.path`,+  `url.scheme`, and `network.protocol.version` at span start (plus `url.query`+  when the request carries one), records `http.response.status_code` on the+  response (a 5xx sets the span status to error; a 4xx does not), and lets the+  shared span lifecycle record any handler exception before it propagates.+  Attributes follow the stable OpenTelemetry HTTP semantic conventions. Because+  WAI runs in `IO`, the middleware takes an unlift function obtained with+  effectful's `withEffToIO`; a real server must use a concurrent unlift strategy.+  Tested through the in-memory interpreter (span shape, attributes, status+  mapping, remote-parent continuation, and exception handling).+- New `wai` cabal flag gating the WAI middleware and its `wai` dependency+  (`>=3.2 && <3.3`), for both the library and the test suite.+- OpenTelemetry export interpreter, behind the new `otel` cabal flag+  (off by default, so the base package carries no OpenTelemetry dependencies):+  `Effectful.Tracing.Interpreter.OpenTelemetry` provides `runTracerOTel`, which+  interprets `Tracer` by running the shared span lifecycle and, as each span+  finishes, translating it into an `hs-opentelemetry` `ImmutableSpan` and handing+  it to the `SpanProcessor`s in its `OtelConfig`. Pair it with an exporter and a+  processor from `hs-opentelemetry-sdk` to reach a real collector. Our trace and+  span ids and our `Sampler` run before OpenTelemetry sees the span and are+  copied verbatim into the exported span, so exported ids match the ids+  `injectContext` puts on the wire. Processors are supplied directly (the SDK+  does not expose a provider's processors) and are force-flushed when the+  interpreter's scope ends. The translation (`toImmutableSpan`) is exposed for+  testing. Note: this interpreter does not thread OpenTelemetry's in-process+  `Context`, so it will not auto-nest spans across a boundary with other+  `hs-opentelemetry`-instrumented libraries.+- New `otel` cabal flag gating the OpenTelemetry interpreter and its+  dependencies: `clock` (`>=0.8 && <0.9`) and `hs-opentelemetry-api`+  (`==0.3.1.0`) for the library, and `async` plus `hs-opentelemetry-api` for the+  test suite.+- W3C Trace Context propagation: `Effectful.Tracing.Propagation`+  carries a trace across a process boundary using the standard `traceparent`+  and `tracestate` headers, with no dependency on an OpenTelemetry SDK.+  `injectContext` serializes the active span's context into a header list for an+  outbound request (and emits nothing when there is no active span, so it+  composes with a base header list unconditionally); `extractContext` parses an+  inbound request's headers into a remote `SpanContext`. `withRemoteParent` (a+  new `Tracer` operation, also re-exported here) then continues that remote+  trace locally: spans opened in its scope inherit the remote trace id and+  sampled flag and record the remote span as their parent. Header lookup is+  case-insensitive, future `traceparent` versions are accepted by reading the+  first four fields, the all-zero ids and the reserved `ff` version are+  rejected, and an unparsable `tracestate` is treated as empty rather than+  failing the whole extraction (per the spec's resilience guidance). Tested with+  the W3C `traceparent` test vectors plus inject/extract round-trips through the+  in-memory interpreter.+- `Effectful.Tracing.Propagation.B3`, an alternative propagator for+  infrastructure that speaks B3 (Zipkin, Envoy, older meshes) rather than W3C+  Trace Context. It supports both wire encodings: the single `b3` header+  (`injectContextB3`) and the legacy `X-B3-*` multi-header form+  (`injectContextB3Multi`). `extractContextB3` reads either, preferring the single+  header when present. A 64-bit B3 trace id is left-padded to the library's+  128-bit width, the sampling field (`1` / `0` / `d`) maps onto the sampled bit+  (debug treated as accept), and a deferred or absent decision defaults to+  unsampled. It is built directly against the library's own `SpanContext` like+  the W3C propagator (no SDK dependency, no new dependency, no cabal flag) and is+  tested with single- and multi-header vectors plus a fuzz totality property.+- `Effectful.Tracing.Propagation.Jaeger`, a third propagator for infrastructure+  still instrumented with native Jaeger clients. `extractContextJaeger` /+  `injectContextJaeger` read and write the single `uber-trace-id` header+  (`{trace-id}:{span-id}:{parent-span-id}:{flags}`), left-padding the+  leading-zero-stripped ids Jaeger emits back to full width, treating the+  deprecated parent field as ignored, and mapping the flags low bit onto the+  sampled decision. `extractBaggageJaeger` / `injectBaggageJaeger` carry Jaeger's+  per-item `uberctx-` baggage headers to and from the `BaggageContext`. Built+  directly against the library's own `SpanContext` like the W3C and B3+  propagators (no SDK dependency, no cabal flag; the only new dependency is+  `case-insensitive`, already in the transitive set), and tested with explicit+  vectors plus a fuzz totality property.+- `Effectful.Tracing.Propagation.Composite`, which combines the single-format+  propagators so a service can speak more than one at once (OpenTelemetry's+  composite-propagator model). Each format becomes a value (`TraceContextPropagator`+  for the span context, `BaggagePropagator` for baggage) with standard instances+  `w3cTraceContext`, `b3Single`, `b3Multi`, `jaegerTraceContext`, `w3cBaggage`, and+  `jaegerBaggage`. `injectContextAll` / `injectBaggageAll` write every configured+  format; `extractContextFirst` takes the first parsing span context (order is the+  priority), while `extractBaggageAll` merges entries from every format (baggage is+  additive). Each propagator carries its `OTEL_PROPAGATORS` token name, and+  `traceContextByToken` / `baggageByToken` resolve a token to its propagator. Pure,+  works under every interpreter, no new dependency, no cabal flag.+- `Effectful.Tracing.EnvConfig`, which reads the `OTEL_`-prefixed SDK environment+  variables that map onto the library's surface and returns a resolved `EnvConfig`+  (service name, resource attributes, the trace-context and baggage propagator+  lists, and a sampler) to wire into your interpreter at startup. It reads+  `OTEL_SERVICE_NAME`, `OTEL_RESOURCE_ATTRIBUTES` (W3C Baggage octet format, decoded+  through the baggage parser), `OTEL_PROPAGATORS` (resolved through the composite+  propagator's token table, with `none` and unknown-token handling), and+  `OTEL_TRACES_SAMPLER` / `OTEL_TRACES_SAMPLER_ARG`. The parse is pure+  (`parseEnvConfig` takes a lookup function); `readEnvConfig` is the `IO` wrapper+  over the real environment. Unset or unrecognised values fall back to the+  OpenTelemetry defaults rather than failing. No new dependency, no cabal flag.+- `Effectful.Tracing.SpanLimits`, the OpenTelemetry span-limit guard: a+  `SpanLimits` record capping the attribute, event, and link counts per span and+  truncating long string attribute values. Each cap is a `Maybe Int` (`Nothing` is+  unlimited); `defaultSpanLimits` matches the SDK defaults (128 attributes / events+  / links, no value-length cap) and `unlimitedSpanLimits` disables every cap. The+  count caps are enforced as a span records (so an in-flight span cannot grow past+  the limit), and the pure `applySpanLimits` applies the value-length truncation+  and link cap at finalization. Every span-opening interpreter now takes limits:+  `runTracerInMemoryWithLimits` is new (with `runTracerInMemoryWith` defaulting to+  `defaultSpanLimits`), and `PrettyPrintConfig` and `OtelConfig` each gain a+  `spanLimits` field. No new dependency, no cabal flag.+- `sqlite-simple` database binding. The new `sqlite-simple` cabal flag (off by+  default) builds `Effectful.Tracing.Instrumentation.SqliteSimple`: drop-in+  `query`, `query_`, `execute`, `execute_`, and `executeMany` that stay in `Eff`+  and wrap each call in `withQuerySpan` (system name `sqlite`), recording the+  parameterized template as `db.query.text` and the leading keyword as+  `db.operation.name`; `executeMany` also records `db.operation.batch.size` (a+  new `Effectful.Tracing.SemConv` constant). The flag pulls in `sqlite-simple`+  (and its bundled SQLite C sources), so it is built in the all-flags CI jobs;+  the binding is covered by a flag-gated compile mirror.+- `valiant` database binding. The new `valiant` cabal flag (off by default)+  builds `Effectful.Tracing.Instrumentation.Valiant`, which wraps the statement+  runners from the `valiant-effectful` adapter for+  [`valiant`](https://hackage.haskell.org/package/valiant), the compile-time+  checked PostgreSQL library: `fetchOneEff`, `fetchAllEff`, `fetchScalarEff`,+  `fetchOneOrThrowEff`, `fetchExistsEff`, `executeEff`, `executeReturningEff`,+  and `executeBatchEff`, each running inside a `client`-kind span (system name+  `postgresql`). The runners need only `Valiant :> es` and `Tracer :> es` (no+  `IOE`); `db.query.text` comes from the statement's validated SQL and+  `db.operation.name` from its leading keyword, and `executeBatchEff` records+  `db.operation.batch.size`. The flag pulls in `valiant` and `valiant-effectful`+  (both pure Haskell, no libpq), so it is built in the all-flags CI jobs; the+  binding is covered by a flag-gated compile mirror.+- `Effectful.Tracing.Instrumentation.Messaging`, a framework-agnostic core for+  tracing message producers and consumers, built unconditionally (no cabal flag,+  no extra dependencies) alongside the database core. You describe a call with a+  `MessagingOperation` (system, operation type, destination, and the optional+  `messaging.*` fields) and run it inside `withMessagingSpan`, which records the+  stable OpenTelemetry messaging conventions and picks the span kind from the+  operation type: `producer` for `Send` / `Create`, `consumer` for `Receive` /+  `Process`, `client` for `Settle`. Context crosses the broker through message+  headers: `injectMessageHeaders` serializes the active span as plain text+  `traceparent` / `tracestate` pairs for the producer to attach, and+  `withConsumerSpan` (or `extractMessageHeaders` on its own) continues that trace+  as a remote parent on the consumer side. The span is named `{operation}+  {destination}` for low cardinality. Adds the `messaging.*` keys to+  `Effectful.Tracing.SemConv`; covered by `MessagingSpec` and a compile mirror.+- `amqp` (RabbitMQ) messaging binding. The new `amqp` cabal flag (off by default)+  builds `Effectful.Tracing.Instrumentation.Amqp`, which layers on the messaging+  core: `publishMsgTraced` opens a `producer` span and writes the trace context+  into the message's AMQP headers, `getMsgTraced` opens a `receive` span around a+  poll, and `withProcessSpan` runs message processing inside a `process` span that+  continues the producer's trace from those headers. `messageHeaders` reads the+  text headers off a message. The flag pulls in `amqp`, so it is built in the+  all-flags CI jobs; the binding is covered by a flag-gated compile mirror.+- `Effectful.Tracing.Testing`, a one-stop module for asserting on traces in your+  own test suite. It re-exports the in-memory capture interpreter+  (`runTracerInMemory`, `newCapturedSpans`, `readCapturedSpans`) and the existing+  finders (`findSpan`, `rootSpans`, `childrenOf`), and adds pure matchers over the+  captured spans: `findSpans` (every span with a name), `descendantsOf` (the whole+  subtree), `isRoot` / `isChildOf`, `lookupAttribute` / `hasAttribute` /+  `hasAttributeValue`, `hasStatus`, `lookupEvent` / `hasEvent`, and `hasKind`. The+  matchers are plain `Bool` / `Maybe` with no test-framework dependency, so they+  compose with `tasty-hunit`, `hspec`, `hedgehog`, or anything else.+- `Effectful.Tracing.Log`, for correlating log lines with the active trace. It+  reads the active span through the `Tracer` effect and exposes its identifiers+  both as a `Correlation` record and as the flat OpenTelemetry log fields+  (`trace_id`, `span_id`, `trace_flags`) via `activeCorrelationFields`, plus+  `activeTraceId` / `activeSpanId` for one id at a time. Framework-agnostic like+  `Effectful.Tracing.Testing`: the accessors return plain `Text` /+  `[(Text, Text)]` with no logging-library dependency and no cabal flag, so they+  drop into `co-log`, `katip`, `fast-logger`, or a bare handle identically, and+  return the empty / `Nothing` case cleanly when no span is in scope.+- `updateName`, a new `Tracer` operation that replaces the active span's name+  after it has opened (OpenTelemetry's `Span.updateName`). It is the building block+  for naming a server span with its matched route template, which is only known+  once routing has run; like the other annotating operations it is a no-op when no+  span is active.+- Servant server instrumentation behind a new `servant` cabal flag (off by+  default). `Effectful.Tracing.Instrumentation.Servant` adds a `WithSpanName`+  type-level combinator to annotate each endpoint with its route template, and a+  `traceServantMiddleware` that does everything the WAI middleware does and, once+  the router has matched an annotated endpoint, renames the open server span to+  `{method} {route}` and records the template as `http.route` (the low-cardinality+  naming the HTTP conventions recommend). The combinator is transparent to+  handlers (it does not change `ServerT`); it communicates the matched route to+  the WAI boundary through a request-vault slot, applied with the new `updateName`+  operation. The flag pulls in `servant`, `servant-server`, and `vault`, and+  builds the WAI middleware it sits on, so it is exercised in the all-flags CI+  jobs. The middleware is tested by serving a small API through the in-memory+  interpreter.+- Database instrumentation. `Effectful.Tracing.Instrumentation.Database` is a+  framework-agnostic core (always built, no new dependency): describe a call with+  a `DatabaseQuery` and run it inside `withQuerySpan`, which opens a `client`-kind+  span named `{operation} {collection}` and records the stable `db.*` semantic+  conventions (`db.system.name`, `db.query.text`, `db.operation.name`,+  `db.collection.name`, `db.namespace`, all new constants in+  `Effectful.Tracing.SemConv`). `inferOperationName` derives the low-cardinality+  operation keyword from a statement without parsing SQL. The new+  `postgresql-simple` cabal flag (off by default) additionally builds+  `Effectful.Tracing.Instrumentation.PostgresqlSimple`: drop-in `query`, `query_`,+  `execute`, and `execute_` that stay in `Eff` and wrap each call in+  `withQuerySpan`, recording the parameterized template (never interpolated+  values) as `db.query.text`. The flag pulls in `postgresql-simple` (and its+  `libpq` C dependency), so it is built in the all-flags CI jobs with `libpq-dev`+  installed; the core is tested through the in-memory interpreter and the binding+  through a flag-gated compile mirror.+- W3C Baggage propagation: `Effectful.Tracing.Baggage` adds ambient, key-value+  context that rides alongside a trace but is independent of span attributes. A+  dynamic `BaggageContext` effect carries it the same way the active span is+  carried (lexically scoped, propagating into forked threads), with `getBaggage`,+  `withBaggageEntry` / `localBaggage`, and the `runBaggage` / `runBaggageWith`+  interpreters; the `Baggage` / `BaggageEntry` value model and its pure operations+  (`insertBaggage`, `lookupBaggageValue`, `baggageFromList`, and friends) are+  usable outside the effect too. `Effectful.Tracing.Propagation.Baggage` is the+  `baggage`-header codec: `injectBaggage` / `extractBaggage` (and the underlying+  `renderBaggage` / `parseBaggage`) percent-encode values, carry member metadata+  verbatim, trim optional whitespace, skip malformed members, and enforce the+  180-entry cap (`maxBaggageEntries`). It is built directly against the effect+  (no SDK dependency, no new dependency, no cabal flag) and the parser is covered+  by a fuzz totality property.+- Async context propagation: `Effectful.Tracing.Concurrent` with+  span-propagating wrappers around effectful's concurrency. `forkInstrumented`,+  `asyncInstrumented`, `concurrentlyInstrumented`, and+  `forConcurrentlyInstrumented` spawn work that inherits the launching span as+  its parent, so a `withSpan` in a forked thread nests under the span that+  started it. Because the active span is a handler-local value (not a shared+  stack), effectful's environment cloning at the fork carries it to the child+  automatically, so these are thin wrappers over `forkIO` / `async` /+  `concurrently` / `forConcurrently`. `forkLinked` instead runs fire-and-forget+  work detached, starting a new root trace with a `Link` back to the caller+  ("caused by" rather than "child of"). This is backed by a new+  `withLinkedRoot` primitive (and `WithLinkedRoot` effect operation) that+  detaches the active span and stages links for the next root span. Tested+  through the in-memory interpreter (parent/sibling nesting, completion-order+  independence, exception recording and propagation, the linked-root shape, and+  a 1000-way concurrent fan-out) under a threaded runtime.+- New library dependency on the full `effectful` package (for+  `Effectful.Concurrent` and `Effectful.Concurrent.Async`), pinned to+  `==2.6.1.0` alongside `effectful-core`.+- Sampling: `Effectful.Tracing.Sampler` with a `Sampler`, the+  `SamplingDecision` (`Drop` / `RecordOnly` / `RecordAndSample`),+  `SamplingResult`, and `SamplerInput` data model, plus the four built-in+  samplers from the OpenTelemetry specification: `alwaysOn`, `alwaysOff`,+  `traceIdRatioBased` (a deterministic fraction keyed on the trace id, so every+  span in a trace shares one decision), and `parentBased` (inherit the parent's+  decision, fall back to a root sampler) configured via `ParentBasedConfig` /+  `defaultParentBasedConfig`. The sampler is consulted once when a span opens:+  `RecordAndSample` sets the sampled trace flag, `RecordOnly` records without+  it, and `Drop` suppresses the interpreter's sink while still running the+  scoped action. `shouldSample` is plain `IO`, so samplers are leaf decision+  functions that are easy to call and test. Both span-opening interpreters gained+  a sampler-aware entry point (`runTracerInMemoryWith`, and a `sampler` field on+  `PrettyPrintConfig`); the existing entry points default to `alwaysOn`, so+  behavior is unchanged unless a sampler is supplied.+- Pretty-print interpreter: `runTracerPretty`, in+  `Effectful.Tracing.Interpreter.PrettyPrint`, writes a human-readable,+  tree-shaped rendering of each finished trace to a `Handle` (usually+  `stderr`) for local development. Configurable via `PrettyPrintConfig`+  (handle, color, whether to show attributes and events, and a `TimeFormat`:+  duration only, offset from trace start, or absolute). Because spans complete+  out of order, each trace is buffered in a `TVar (Map TraceId [Span])` and+  rendered as a unit the moment its root closes. The pure `renderTrace`+  formatter is exposed and is the unit of golden testing. Tests pin the layout+  with golden files (nested server/client trace, colored output, a+  relative-time variant, and a failed span) plus an end-to-end test through the+  live interpreter.+- The shared span lifecycle (lexical active span, finalize-exactly-once under+  `generalBracket`) used by every span-opening interpreter now lives in+  `Effectful.Tracing.Internal.Live`, behind a single `interpretTracer` that is+  parameterized only by a `Span -> IO ()` sink. The in-memory interpreter was+  refactored onto it with no behavior change.+- In-memory interpreter: `runTracerInMemory`, in+  `Effectful.Tracing.Interpreter.InMemory`, captures every completed span into+  a shared `CapturedSpans` buffer (`newCapturedSpans` / `readCapturedSpans`) so+  tests can assert on what a traced computation produced. This is the first+  interpreter that opens and closes spans, so it realizes both span decisions:+  the active span is lexical (carried in the handler's private `Reader`, so+  nested operations see their enclosing span and emits with no active span are+  silent no-ops), and span finalization runs in `generalBracket`, so a span is+  closed and emitted exactly once with an `Error` status even when killed by an+  asynchronous exception. Children inherit their parent's trace id and get a+  fresh span id; roots mint a new trace id. Query helpers `findSpan`,+  `childrenOf`, and `rootSpans` inspect the captured list. Tests cover naming,+  ordered timing, nesting, sibling structure, exception recording, async-kill+  single-close, lexical emit targeting, and a property check that captured+  spans always form a valid forest.+- No-op interpreter: `runTracerNoOp`, re-exported from+  `Effectful.Tracing`, discharges the `Tracer` effect with no observable+  effect: scoped actions run unchanged (exceptions propagate), emit operations+  are silent, and there is never an active span. This is the interpreter for+  components that need `Tracer` when the caller does not want tracing, and the+  baseline for the overhead benchmark. Tests cover nested-span return values,+  exception propagation, and silent emits. The `tasty-bench` benchmark+  (`bench/Main.hs`) reports the fixed per-`withSpan` cost (~15 ns, dynamic+  dispatch plus `localSeqUnlift`); spans wrapping real work stay under the 5%+  overhead target. The README quick-start now runs against `runTracerNoOp`.+- `Tracer` effect: tracing modeled as a dynamic `effectful` effect.+  - The effect with one higher-order operation (`WithSpan`) and first-order+    emit operations (`AddAttribute`, `AddAttributes`, `AddEvent`,+    `RecordException`, `SetStatus`, `GetActiveSpan`), in+    `Effectful.Tracing.Effect`.+  - `SpanArguments` record (`kind`, `attributes`, `links`, `startTime`) and+    `defaultSpanArguments`.+  - Smart constructors (`withSpan`, `withSpan'`, `addAttribute`,+    `addAttributes`, `addEvent`, `recordException`, `setStatus`,+    `getActiveSpan`), each with a Haddock usage example, re-exported from+    `Effectful.Tracing` with `Tracer` kept abstract.+  - `transitionStatus`, the single shared encoding of the OpenTelemetry span+    status transition rules (Ok is final; never downgrade to Unset).+  - A compile-only test proving the public API typechecks.+  - No interpreter yet: user code can be written against `Tracer` but not run.+- Core data model: the effect-system-independent types every+  interpreter shares.+  - `TraceId` (16 bytes) and `SpanId` (8 bytes) with fast-PRNG generation,+    byte and lowercase-hex codecs, and validity checks.+  - `Timestamp` wrapping `UTCTime`, with `getTimestamp`.+  - `AttributeValue` (scalar and homogeneous-array variants), `Attribute`, the+    `(.=)` constructor, and a `ToAttributeValue` class with instances covering+    the common scalar and list types.+  - W3C `TraceFlags` (sampled bit plus preserved reserved bits) and+    `TraceState` (validated key/value entries, capped at 32, with header+    serialization and resilient parsing).+  - `SpanContext`, `SpanKind`, `SpanStatus`, `Event`, `Link`, and the immutable+    completed-`Span` record.+  - Hedgehog generators for every public type and property tests covering hex+    round-trips, generated-id validity, trace-state round-trips and the entry+    cap, attribute coercions, and span time ordering.+- Project scaffolding: cabal package targeting GHC 9.10.3, a tasty+  test suite, a tasty-bench benchmark harness, hlint configuration, and a+  GitHub Actions CI workflow. No automated formatter is used. No library+  functionality yet.++### Changed++- Strictness follow-up: closed four thunk/retention spots a fresh audit+  surfaced (the data model itself was already fully strict). `finalizeSpan`+  now forces the completed `Span` to WHNF before handing it to the sink, so a+  sink that stores it (the in-memory buffer, the pretty-print accumulator) holds+  a finished value rather than a thunk retaining the span's builder `IORef`. A+  child span's `spanParentContext` is now forced past the `Maybe`: the previous+  lazy `activeContext <$> parent` left `Just (activeContext p)` as a thunk that+  retained the parent's entire `ActiveSpan` (builder `IORef` included) inside+  every completed child span. The pretty-print interpreter forces the rebuilt+  per-trace map before `writeTVar`, and the WAI middleware projects and forces+  the response status before stashing it, so the status ref no longer pins the+  whole response (body included) until the span closes. All behavior-preserving;+  the full suite passes unchanged.+- Strict-by-default posture: enabled `StrictData` and `-funbox-strict-fields`+  across the package, so record fields are strict and unboxed unless explicitly+  marked lazy. The data model already annotated its fields strict, so this is+  belt-and-suspenders rather than a behavior change, and it keeps later+  additions strict by default. The `TraceId` / `SpanId` hex encoder now uses+  `bytestring`'s builder-based `byteStringHex` instead of building an+  intermediate `String` per byte, and the OpenTelemetry event collection is+  assembled with a strict `foldl'`.
+ LICENSE view
@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2026, The effectful-tracing contributors+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+   list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+   this list of conditions and the following disclaimer in the documentation+   and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its+   contributors may be used to endorse or promote products derived from+   this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,315 @@+# effectful-tracing++[![CI](https://github.com/joshburgess/effectful-tracing/actions/workflows/ci.yml/badge.svg)](https://github.com/joshburgess/effectful-tracing/actions/workflows/ci.yml)+[![Hackage](https://img.shields.io/hackage/v/effectful-tracing.svg)](https://hackage.haskell.org/package/effectful-tracing)+[![License: BSD-3-Clause](https://img.shields.io/badge/license-BSD--3--Clause-blue.svg)](LICENSE)++Tracing as a scoped effect for Haskell, built natively on+[`effectful`](https://hackage.haskell.org/package/effectful), with+OpenTelemetry interop via+[`hs-opentelemetry`](https://hackage.haskell.org/package/hs-opentelemetry-sdk).++A span is a scoped, higher-order effect. That makes "the current span" lexical+instead of thread-local, which removes a whole class of context-loss bugs and+keeps the API clean. The library does not reimplement the OpenTelemetry wire+format: it compiles down to `hs-opentelemetry` for real export and ships several+other interpreters (no-op, in-memory, pretty-print) for testing and development.++## Why this over hs-opentelemetry directly?++If you are already on `effectful`, this library is the more natural fit. The+differences are about where the seams sit, not about what gets exported:++- **The current span is lexical, not thread-local.** `hs-opentelemetry` tracks+  the active span through an implicit context that you propagate by hand across+  thread and async boundaries. Here a span is a scoped higher-order effect, so+  "the current span" is exactly the lexically enclosing `withSpan` and the+  compiler tracks it for you. That removes the most common source of orphaned or+  mis-parented spans.+- **The backend is an interpreter you choose at the call site.** The same+  `Tracer`-using code runs under the no-op, in-memory, pretty-print, or+  OpenTelemetry interpreter with no change. You get a real trace tree on stderr+  in development and assertable spans in tests without standing up a collector,+  and you swap in `runTracerOTel` for production.+- **It composes as an `effectful` effect.** `Tracer` sits alongside your other+  effects with an ordinary `Tracer :> es` constraint, rather than threading a+  reader of OpenTelemetry context through your stack.++It is not a reimplementation of the wire format: real export still goes through+`hs-opentelemetry-sdk`, and this library's ids and sampler stay the source of+truth. If you are not using `effectful`, depending on `hs-opentelemetry`+directly is the simpler choice.++> Status: first release (`0.1.0.0`) is on Hackage. The interpreters+> (no-op, in-memory, pretty-print, OpenTelemetry); W3C Trace Context, B3, and+> Jaeger propagation (composable, and configurable from `OTEL_` environment+> variables); sampling; span limits; async context propagation; baggage; a+> log-correlation bridge; in-test assertions; and the instrumentation helpers for+> WAI, http-client, Servant, databases (postgresql-simple, sqlite-simple,+> valiant), and message queues (with a RabbitMQ binding over amqp) have all+> landed.++## Install++Add `effectful-tracing` to your project's dependencies. In a `.cabal` file:++```cabal+build-depends:+  , effectful-tracing >=0.1 && <0.2+```++The base package brings in only `effectful` and a small set of core+dependencies. The integrations (OpenTelemetry export, the WAI / http-client /+Servant helpers, the database driver bindings, and the RabbitMQ binding) each+live behind a cabal flag that is off by default, so nothing pulls in a web,+database, or OpenTelemetry stack unless you ask for it. Turn a flag on by naming+it in `cabal.project`:++```cabal+package effectful-tracing+  flags: +otel +wai +http-client+```++The available flags are `otel`, `wai`, `http-client`, `servant`,+`postgresql-simple`, `sqlite-simple`, `valiant`, `amqp`, and `secure-ids`. The+framework-agnostic database and messaging cores+(`Effectful.Tracing.Instrumentation.Database` and `.Messaging`) are always+built and need no flag.++## Quick start++Write a computation against the `Tracer` effect, then discharge it. The no-op+interpreter (`runTracerNoOp`) satisfies the effect with zero tracing and no+external dependencies, so this runs as-is. Swap in the in-memory, pretty-print,+or OpenTelemetry interpreter without touching the computation.++```haskell+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import Data.Text (Text)+import Effectful (Eff, runEff, (:>))+import Effectful.Tracing++-- A computation that uses tracing without committing to a backend.+compute :: Tracer :> es => Eff es Int+compute = withSpan "outer" $ do+  addAttribute "user.id" ("u123" :: Text)+  total <- withSpan "inner" $ do+    addEvent "fetching" []+    pure 42+  setStatus Ok+  pure total++main :: IO ()+main = do+  result <- runEff (runTracerNoOp compute)+  print result+```++## Seeing your traces++During development, swap the no-op interpreter for the pretty-print one to see+the trace as a tree on stderr. The computation does not change, only the+interpreter.++```haskell+import Effectful.Tracing.Interpreter.PrettyPrint+import System.IO (stderr)++main :: IO ()+main = do+  result <- runEff (runTracerPretty (defaultPrettyPrintConfig stderr) compute)+  print result+```++prints:++```+trace 4f1a9c000000000000000000000000aa (1ms)+└─ outer (1ms) status=Ok+   user.id=u123+   └─ inner (0ms) status=Ok+      event: fetching @ +0.0ms+```++(The trace id and durations vary from run to run.) For tests, the in-memory+interpreter (`Effectful.Tracing.Interpreter.InMemory`) captures completed spans+into a buffer you can assert on.++## Instrumenting a web service++A few optional helpers cover the common server seams. Each is behind a cabal flag+(off by default), so the base package never pulls in a web stack:++- `Effectful.Tracing.Instrumentation.Wai` (flag `wai`): a `Middleware` that opens+  a `server` span per request and continues an inbound distributed trace.+- `Effectful.Tracing.Instrumentation.HttpClient` (flag `http-client`): a wrapper+  that opens a `client` span and injects the trace context into outbound+  requests.+- `Effectful.Tracing.Instrumentation.Servant` (flag `servant`): a per-endpoint+  combinator plus middleware that names server spans `"{method} {route}"` with+  the matched route template recorded as `http.route`.++Enable them when depending on the package:++```cabal+build-depends: effectful-tracing+-- in cabal.project, or via --flags on the command line:+--   --flags="wai http-client"+```++On the inbound side, wrap your application with `traceMiddleware`. Because WAI+runs in `IO` but the `Tracer` effect lives in `Eff`, the middleware takes an+unlift function from effectful's `withEffToIO`. A real server handles requests+concurrently, so use a concurrent unlift strategy:++```haskell+import Effectful+import Effectful.Tracing (Tracer)+import Effectful.Tracing.Instrumentation.Wai (traceMiddleware)+import Network.Wai (Application)+import Network.Wai.Handler.Warp qualified as Warp++runServer :: (IOE :> es, Tracer :> es) => Application -> Eff es ()+runServer app =+  withEffToIO (ConcUnlift Persistent Unlimited) $ \runInIO ->+    Warp.run 8080 (traceMiddleware runInIO app)+```++`traceMiddleware` names each server span after the request method (`GET`,+`POST`). When your router knows the matched route template, `traceMiddlewareWith`+lets you name spans `"{method} {route}"` instead. See the cookbook recipe "Name+server spans by route, not just method".++On the outbound side, call downstream services through `httpLbsTraced`. It opens+a `client` span and writes `traceparent` / `tracestate` into the request, so the+next service continues the same trace:++```haskell+import Control.Monad.IO.Class (liftIO)+import Effectful (Eff, IOE, (:>))+import Effectful.Tracing (Tracer, withSpan)+import Effectful.Tracing.Instrumentation.HttpClient (httpLbsTraced)+import Network.HTTP.Client (Manager, Response, parseRequest)+import Data.ByteString.Lazy (ByteString)++fetchWidget :: (IOE :> es, Tracer :> es) => Manager -> Eff es (Response ByteString)+fetchWidget manager = withSpan "load.widgets" $ do+  req <- liftIO (parseRequest "https://widgets.internal/widgets")+  httpLbsTraced req manager+```++Both helpers speak W3C Trace Context (`Effectful.Tracing.Propagation`), so a+`server` span opened by the middleware and a `client` span opened by the wrapper+join into one distributed trace across the hop. To make a downstream call nest+under a specific request, run that request's handler in `Eff` so the server span+is the active span when `httpLbsTraced` runs. For a complete, runnable version of+exactly this wiring, see [`examples/servant-app`](examples/servant-app), a+two-endpoint Servant service whose inbound and outbound spans join into one trace+in Jaeger.++## Instrumenting databases and message queues++The same scoped-span approach covers the database client side and message queues,+through framework-agnostic cores that are always built (no flag, no extra+dependencies):++- `Effectful.Tracing.Instrumentation.Database`: describe a call with a+  `DatabaseQuery` and run it inside `withQuerySpan`, which opens a `client` span+  named `"{operation} {collection}"` with the stable `db.*` attributes. Thin+  driver bindings layer on top behind their own flags: `postgresql-simple`,+  `sqlite-simple`, and [`valiant`](https://hackage.haskell.org/package/valiant)+  (the compile-time checked PostgreSQL library), each a drop-in for the driver's+  own runners.+- `Effectful.Tracing.Instrumentation.Messaging`: describe a publish or consume+  with a `MessagingOperation` and run it inside `withMessagingSpan`, which picks+  the span kind from the operation (`producer` / `consumer` / `client`) and+  records the `messaging.*` conventions. `injectMessageHeaders` and+  `withConsumerSpan` carry the trace across the broker through message headers. A+  RabbitMQ binding layers on top behind the `amqp` flag+  (`Effectful.Tracing.Instrumentation.Amqp`): `publishMsgTraced`, `getMsgTraced`,+  and `withProcessSpan` do the header plumbing over the `amqp` client for you.++See the cookbook recipes "Trace a database query" and "Trace a message producer+and consumer" for the code, and [`examples/order-pipeline`](examples/order-pipeline)+for a runnable version: a producer and consumer that join into one distributed+trace across RabbitMQ, with the consumer writing to PostgreSQL inside the+continued trace, all brought up with `docker compose`.++## Exporting to OpenTelemetry++Build with the `otel` flag and discharge the effect with `runTracerOTel`+(`Effectful.Tracing.Interpreter.OpenTelemetry`). It keeps this library's ids and+sampler as the source of truth and translates each finished span into an+`hs-opentelemetry` span for the `SpanProcessor`s you supply, so you can point it+at any OTLP collector (Jaeger, Tempo, the OpenTelemetry Collector). The+[tutorial](docs/tutorial.md) walks through wiring the OTLP exporter and bringing+up a local Jaeger with `docker compose`.++## Troubleshooting++**My spans come out flat instead of nested.** A span nests under another only+when the outer one is the active span at the point the inner `withSpan` runs,+and "active" is lexical. The usual cause is a boundary where the code drops back+into plain `IO`: for example a WAI `Application` or a callback that runs outside+the `Eff` scope cannot see a `Tracer` span opened in `Eff`. Run the handler in+`Eff` (through the unlift you passed to the middleware) so the server span is+still the active span when the inner work runs. See "Instrumenting a web+service" above.++**An outbound call starts its own trace instead of joining the request's.**+`httpLbsTraced` opens a `client` span as a child of whatever span is active when+it runs. If no span is active (the call happens after the server span's scope+has closed, or in a thread that never entered `Eff`), it has nothing to attach+to and begins a fresh root trace. Make the call inside the request handler's+`Eff` scope, with the server span still open, so the `client` span becomes its+child and the `traceparent` header continues the same trace downstream.++**Nothing shows up in my collector (or in pretty-print output).** Check, in+order: (1) the interpreter. `runTracerNoOp` records nothing by design. Use+`runTracerPretty`, the in-memory interpreter, or `runTracerOTel`. (2) The flag.+`runTracerOTel` only exists when the package is built with `+otel`, and the WAI+/ http-client / Servant helpers need their flags too. A missing flag means the+module is not in scope. (3) The sampler. A low sampling ratio drops most spans+before export. Set the sampler to always-on while you are confirming the+pipeline works, then dial it back. (4) For OpenTelemetry export specifically,+that you actually supplied a `SpanProcessor`/exporter pointed at your collector;+`runTracerOTel` exports through the processors you give it and nowhere else.++**Trace context is not crossing a message broker.** Headers only carry the+context if you inject on publish and extract on consume. Use+`injectMessageHeaders` (or the `amqp` binding's `publishMsgTraced`) when sending+and `withConsumerSpan` / `withProcessSpan` when receiving. A consumer that opens+a plain `withSpan` instead will start a new trace rather than continuing the+producer's.++## Learning more++- [`docs/tutorial.md`](docs/tutorial.md): a guided walkthrough from a trace on+  your terminal to OpenTelemetry export, in about fifteen minutes.+- [`docs/cookbook.md`](docs/cookbook.md): short recipes for everyday tasks+  (trace an existing function, sampling, connecting HTTP traces, database queries,+  message producers and consumers, workers).+- [`docs/design.md`](docs/design.md): how the library is designed, organized by+  concept (the data model, the Tracer effect, the lifecycle, sampling,+  propagation, OTel export). Start here to understand the internals.+- [`examples/servant-app`](examples/servant-app): an end-to-end Servant service+  whose inbound and outbound spans join into one distributed trace in Jaeger.+- [`examples/order-pipeline`](examples/order-pipeline): a two-process order+  pipeline (RabbitMQ producer and consumer, PostgreSQL writes) whose spans join+  into one trace across the broker, brought up with `docker compose`.+- [`examples/local-dev`](examples/local-dev): two small programs that need no+  collector: a worker loop (one span per job, interpreter chosen at runtime,+  error recording, a linked background trace) and a custom-sampler demo.++## Supported GHC++- GHC 9.6.7+- GHC 9.8.4+- GHC 9.10.3++## License++BSD-3-Clause. See [LICENSE](LICENSE).
+ bench/Main.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Main+-- Description : tasty-bench entry point for the effectful-tracing benchmarks.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+--+-- The no-op overhead benchmark: a chain of @n@ trivial operations run+-- plain versus the same chain with each operation wrapped in @withSpan@ under+-- 'runTracerNoOp'. The comparison entries report the traced run as a ratio of the+-- plain baseline within a single run, since absolute timings are not comparable+-- across machines.+--+-- Read the ratio, not the absolute numbers. The target is < 1.05 (5% overhead),+-- measured on a quiet, dedicated machine. CI runners are noisy shared VMs, so a+-- 5% gate would flap; the @realistic-op@ comparison therefore uses+-- 'bcompareWithin' with a deliberately loose upper bound of @1.20@, so the+-- benchmark process exits non-zero (failing the CI gate) only on a gross+-- regression, not on ordinary runner noise. The @trivial-op@ comparison is left+-- as a plain 'bcompare': its baseline is essentially free, so its ratio is the+-- raw per-'withSpan' dispatch cost and is inherently large, which is informative+-- but not a meaningful pass/fail threshold.+module Main (main) where++import Control.Monad (foldM)++-- @foldl'@ moved into Prelude in base-4.20 (GHC 9.10); import it explicitly on+-- older bases so the package still builds on GHC 9.6 / 9.8.+#if !MIN_VERSION_base(4,20,0)+import Data.List (foldl')+#endif++import Effectful (Eff, runEff, (:>))+import Effectful.Tracing (Tracer, runTracerNoOp, withSpan)+import Test.Tasty.Bench (bcompare, bcompareWithin, bench, bgroup, defaultMain, nfIO)++-- | A chain of @n@ accumulating operations, each doing @work@ units of+-- computation, with no tracing involved.+plainChain :: Int -> Int -> Eff es Int+plainChain perOp n = foldM step 0 [1 .. n]+  where+    step acc i = pure (acc + work perOp i)++-- | The same chain, but each operation runs inside its own (no-op) span.+tracedChain :: Tracer :> es => Int -> Int -> Eff es Int+tracedChain perOp n = foldM step 0 [1 .. n]+  where+    step acc i = withSpan "step" (pure (acc + work perOp i))++-- | A pure unit of CPU work whose cost scales with the first argument. @0@ is+-- effectively free, isolating the fixed per-@withSpan@ cost; a larger value+-- stands in for the real work a span normally wraps.+work :: Int -> Int -> Int+work perOp seed = foldl' (+) seed [1 .. perOp]+{-# NOINLINE work #-}++main :: IO ()+main =+  defaultMain+    [ -- Each span wraps an essentially free operation, so the ratio is the raw+      -- per-'withSpan' dispatch/unlift cost, not a realistic overhead figure.+      bgroup+        "trivial-op"+        [ bench "plain" (nfIO (runEff (plainChain 0 n)))+        , bcompare "$NF == \"plain\" && $(NF-1) == \"trivial-op\"" $+            bench "withSpan-noop" (nfIO (runEff (runTracerNoOp (tracedChain 0 n))))+        ]+    , -- Each span wraps a realistic unit of work; the ratio shows the overhead+      -- a caller actually pays. This is the figure the 5% target refers to.+      bgroup+        "realistic-op"+        [ bench "plain" (nfIO (runEff (plainChain perOp n)))+        , -- Fail the run (and so the CI gate) only if the traced chain is more+          -- than 1.20x the plain baseline; a speedup or any ratio at or below+          -- 1.20 passes. The lower bound is 0 because traced is never expected+          -- to be meaningfully faster than plain.+          bcompareWithin 0 1.20 "$NF == \"plain\" && $(NF-1) == \"realistic-op\"" $+            bench "withSpan-noop" (nfIO (runEff (runTracerNoOp (tracedChain perOp n))))+        ]+    ]+  where+    n = 1000+    perOp = 600
+ docs/cookbook.md view
@@ -0,0 +1,732 @@+# Cookbook++Short, focused recipes for everyday tracing tasks. Each one is independent;+skip to the one you need. The [tutorial](tutorial.md) is the place to start if+you want the guided tour instead.++## Trace an existing function++You have a function and you want a span around it. Add the `Tracer` constraint+and wrap the body in `withSpan`. Nothing about what the function returns or how+callers use it changes.++```haskell+-- Before:+loadUser :: (Database :> es) => UserId -> Eff es User+loadUser uid = queryUser uid++-- After:+loadUser :: (Database :> es, Tracer :> es) => UserId -> Eff es User+loadUser uid = withSpan "loadUser" $ queryUser uid+```++If a function cannot take the constraint (it is called from a context with no+`Tracer` in the effect row), trace at the nearest caller that does have it. The+span still covers the work; it just names the caller's view of it.++The span closes when the body returns *or throws*. An exception propagating out+of `withSpan` is recorded as an event on the span and sets the span status to+`Error` automatically, so you do not need a `catch` just to mark failures.++## Attach structured fields to a span++Annotate the active span with typed attributes and timeline events. None of+these take the span as an argument: they apply to whatever span is lexically+current, and are silent no-ops when there is none.++```haskell+{-# LANGUAGE OverloadedStrings #-}++import Effectful.Tracing++handleOrder :: (Tracer :> es) => Order -> Eff es ()+handleOrder order = withSpan "handleOrder" $ do+  -- One attribute at a time.+  addAttribute "order.id" (orderId order)        -- Text+  addAttribute "order.total_cents" (totalCents order)  -- Int+  -- Or several at once with (.=), which infers the attribute type.+  addAttributes+    [ "customer.tier" .= tierName order   -- Text+    , "order.express" .= isExpress order  -- Bool+    , "order.line_count" .= lineCount order  -- Int+    ]+  -- A point on the span's timeline, with its own attributes.+  addEvent "payment.authorized" ["gateway" .= ("stripe" :: Text)]+```++Attribute values are typed: `Text`, `String`, `Bool`, `Int`, `Double`, and+homogeneous lists of those. Prefer stable, low-cardinality keys (`order.id` over+a freeform message) so backends can index and group on them.++## Sample 1% but keep more of what matters++Sampling here is *head sampling*: the decision is made once, when the span+starts, before you know whether the work will fail. So a plain head sampler+cannot literally "keep 100% of errors", because at span-start there is no error+yet. There are two honest ways to get close.++**1. Force-sample work you already know is important.** If the caller knows up+front that an operation is high-value or risky, set an initial attribute and+have a custom `Sampler` honor it, falling back to 1% otherwise. A `Sampler` is+just a record, so you can compose the built-ins:++```haskell+import Effectful.Tracing+import Effectful.Tracing.Sampler+  ( Sampler (..)+  , SamplerInput (initialAttributes)+  , SamplingDecision (RecordAndSample)+  , simpleResult+  , traceIdRatioBased+  )+import Effectful.Tracing.Attribute (Attribute (Attribute), AttributeValue (AttrBool))++-- 1% of traces by default, but always sample a span whose caller flagged it+-- with `sampling.priority = True`.+priorityOr1Percent :: Sampler+priorityOr1Percent =+  Sampler+    { samplerName = "PriorityOr1Percent"+    , shouldSample = \input ->+        if flagged (initialAttributes input)+          then pure (simpleResult RecordAndSample)+          else shouldSample (traceIdRatioBased 0.01) input+    }+  where+    flagged = any (\(Attribute k v) -> k == "sampling.priority" && v == AttrBool True)+```++Callers opt a span in by starting it with that attribute:++```haskell+import Effectful.Tracing (SpanArguments (attributes), defaultSpanArguments, withSpan')++riskyCharge :: (Tracer :> es) => Eff es ()+riskyCharge =+  withSpan' "charge" defaultSpanArguments { attributes = ["sampling.priority" .= True] } $+    doTheCharge+```++**2. Keep everything cheaply, decide later.** For "keep all errors" in the+general case, the right tool is *tail sampling* in your collector, which sees+the whole finished trace. Run this library with a generous head sampler (or+`alwaysOn`) into an OpenTelemetry Collector configured with its+`tail_sampling` processor to drop the boring traces and keep every errored one.+Head sampling and tail sampling compose: head decides what to emit, the+collector decides what to retain.++Wrap your chosen sampler into an interpreter the usual way:++```haskell+import Effectful (runEff)+import Effectful.Tracing.Interpreter.InMemory+  (newCapturedSpans, readCapturedSpans, runTracerInMemoryWith)++runEff $ do+  captured <- newCapturedSpans+  _ <- runTracerInMemoryWith priorityOr1Percent captured action+  readCapturedSpans captured+```++## Connect inbound and outbound HTTP traces++To make one distributed trace span an inbound request and the outbound calls it+triggers, use the two instrumentation helpers together (cabal flags `wai` and+`http-client`). The middleware continues any inbound `traceparent` and opens a+`server` span; the client wrapper opens a `client` span *under* it and injects+`traceparent` into the next hop.++```haskell+import Control.Monad.IO.Class (liftIO)+import Effectful (Eff, IOE, (:>))+import Effectful.Tracing (Tracer)+import Effectful.Tracing.Instrumentation.Wai (traceMiddleware)+import Effectful.Tracing.Instrumentation.HttpClient (httpLbsTraced)+import Network.HTTP.Client (Manager, parseRequest)++-- 'Response' and 'buildResponse' are your application's own response type and+-- builder; 'httpLbsTraced' returns an 'http-client' 'Response' you map into them.+--+-- The request handler runs in Eff, so the server span opened by the middleware+-- is the active span while the handler runs. Any httpLbsTraced call inside it+-- therefore nests under the server span and shares its trace.+handler :: (IOE :> es, Tracer :> es) => Manager -> Eff es Response+handler manager = do+  req <- liftIO (parseRequest "http://users.internal/profile")+  profile <- httpLbsTraced req manager   -- client span, child of the server span+  buildResponse profile+```++The key is that the handler must run *inside* `Eff` (under the same unlift the+middleware used) rather than in plain `IO`, so the active span is still in scope+when the outbound call fires. If you call `httpLbsTraced` from code that has lost+the server span, it starts a fresh root trace instead. To deliberately continue+a trace received out of band (for example from a message queue header), use+`extractContext` and `withRemoteParent`:++```haskell+import Effectful.Tracing (extractContext, withRemoteParent)+import Network.HTTP.Types (Header)++consume :: (Tracer :> es) => [Header] -> Eff es a -> Eff es a+consume headers work =+  maybe id withRemoteParent (extractContext headers) work+```++## Trace a database query++To put a database call on the trace, wrap it in a `client`-kind span recording+the stable OpenTelemetry database conventions (`db.system.name`, `db.query.text`,+and friends). `Effectful.Tracing.Instrumentation.Database` is driver-agnostic:+you describe the call with a `DatabaseQuery` and run it inside `withQuerySpan`,+which names the span `{operation} {collection}` (for example `SELECT users`) and+finalizes it even if the query throws. Record the *parameterized* statement+(placeholders, not interpolated values) so row data never reaches the span.++```haskell+import Control.Monad.IO.Class (liftIO)+import Effectful (Eff, IOE, (:>))+import Effectful.Tracing (Tracer)+import Effectful.Tracing.Instrumentation.Database+  (DatabaseQuery (..), databaseQuery, withQuerySpan)++-- 'rawSelectActiveUsers' stands in for your driver's own query call.+fetchActiveUsers :: (IOE :> es, Tracer :> es) => Eff es [(Int, Text)]+fetchActiveUsers =+  withQuerySpan+    (databaseQuery "postgresql")+      { queryText = Just "SELECT id, name FROM users WHERE active = $1"+      , queryOperation = Just "SELECT"+      , queryCollection = Just "users"+      }+    (liftIO rawSelectActiveUsers)+```++If you use `postgresql-simple`, the `postgresql-simple` cabal flag builds+`Effectful.Tracing.Instrumentation.PostgresqlSimple`: drop-in `query`, `query_`,+`execute`, and `execute_` that do this wrapping for you. Import it qualified so the+traced runners shadow the originals; each derives `db.query.text` from the+statement template and `db.operation.name` from its leading keyword.++```haskell+import Data.Text (Text)+import Database.PostgreSQL.Simple (Connection, Only (..))+import Effectful (Eff, IOE, (:>))+import Effectful.Tracing (Tracer)+import Effectful.Tracing.Instrumentation.PostgresqlSimple qualified as Pg++activeUserNames :: (IOE :> es, Tracer :> es) => Connection -> Eff es [Only Text]+activeUserNames conn =+  Pg.query conn "SELECT name FROM users WHERE active = ?" (Only True)+```++For `sqlite-simple`, the `sqlite-simple` cabal flag builds+`Effectful.Tracing.Instrumentation.SqliteSimple` the same way: drop-in `query`,+`query_`, `execute`, `execute_`, and `executeMany` (the batch runner also records+`db.operation.batch.size`). The system name is `sqlite`.++```haskell+import Data.Text (Text)+import Database.SQLite.Simple (Connection, Only (..))+import Effectful (Eff, IOE, (:>))+import Effectful.Tracing (Tracer)+import Effectful.Tracing.Instrumentation.SqliteSimple qualified as Sqlite++activeUserNames :: (IOE :> es, Tracer :> es) => Connection -> Eff es [Only Text]+activeUserNames conn =+  Sqlite.query conn "SELECT name FROM users WHERE active = ?" (Only True)+```++For [`valiant`](https://hackage.haskell.org/package/valiant) (the compile-time+checked PostgreSQL library), the `valiant` cabal flag builds+`Effectful.Tracing.Instrumentation.Valiant`. It wraps the statement runners from+the [`valiant-effectful`](https://hackage.haskell.org/package/valiant-effectful)+adapter (`fetchOneEff`, `fetchAllEff`, `executeEff`, `executeBatchEff`, and the+rest), so each runs inside a `client`-kind span. The runners require only+`Valiant :> es` and `Tracer :> es`, no `IOE`, because the `Valiant` effect+already carries the connection. `db.query.text` comes from the statement's own+validated SQL (never interpolated values) and `db.operation.name` from its+leading keyword. The system name is `postgresql`.++```haskell+import Valiant (Statement)+import Valiant.Effectful (Valiant)+import Effectful (Eff, (:>))+import Effectful.Tracing (Tracer)+import Effectful.Tracing.Instrumentation.Valiant qualified as V++activeUsers :: (Valiant :> es, Tracer :> es) => Statement () User -> Eff es [User]+activeUsers listUsers = V.fetchAllEff listUsers ()+```++## Trace a message producer and consumer++Message queues split one logical operation across two processes, so the trace+has to travel with the message. `Effectful.Tracing.Instrumentation.Messaging` is+broker-agnostic: you describe the call with a `MessagingOperation` and run it+inside `withMessagingSpan`, which records the stable OpenTelemetry messaging+conventions (`messaging.system`, `messaging.destination.name`, and friends) and+picks the span kind from the operation type, `producer` for `Send` / `Create`+and `consumer` for `Receive` / `Process`.++On the producer side, open a `Send` span and attach the trace context to the+message with `injectMessageHeaders`, which returns plain text `traceparent` /+`tracestate` pairs (the portable shape across Kafka, RabbitMQ, SQS, and the+like).++```haskell+import Control.Monad.IO.Class (liftIO)+import Effectful (Eff, IOE, (:>))+import Effectful.Tracing (Tracer)+import Effectful.Tracing.Instrumentation.Messaging+  (MessagingOperation (..), MessagingOperationType (Send), injectMessageHeaders, messagingOperation, withMessagingSpan)++-- 'produce' stands in for your broker client's publish call.+publishOrder :: (IOE :> es, Tracer :> es) => Order -> Eff es ()+publishOrder order =+  withMessagingSpan+    (messagingOperation "kafka" Send) { messagingDestination = Just "orders" }+    $ do+      headers <- injectMessageHeaders+      liftIO (produce "orders" headers (encode order))+```++On the consumer side, hand the received message's headers to `withConsumerSpan`+along with a `Process` (or `Receive`) operation. When the headers carry a valid+context the consumer span continues the producer's trace as a remote child;+otherwise it opens a fresh root. (`extractMessageHeaders` exposes the parse on its+own if you want to continue the parent around more than one span.)++```haskell+import Effectful (Eff, IOE, (:>))+import Effectful.Tracing (Tracer)+import Effectful.Tracing.Instrumentation.Messaging+  (MessagingOperation (..), MessagingOperationType (Process), messagingOperation, withConsumerSpan)++-- 'message' stands in for your broker client's received message.+handleOrder :: (IOE :> es, Tracer :> es) => Message -> Eff es ()+handleOrder message =+  withConsumerSpan+    (messageHeaders message)+    (messagingOperation "kafka" Process) { messagingDestination = Just "orders" }+    (liftIO (process (messageBody message)))+```++### Using the RabbitMQ binding++If you use the `amqp` package, the `amqp` cabal flag builds+`Effectful.Tracing.Instrumentation.Amqp`, a thin layer over the core that does+the header plumbing for you. `publishMsgTraced` opens the `producer` span and+writes the trace context into the message's AMQP headers; `getMsgTraced` opens a+`receive` span around the poll; and `withProcessSpan` runs your processing inside+a `process` span that continues the producer's trace, reading the headers off the+delivered message.++```haskell+import Data.ByteString.Lazy (ByteString)+import Effectful (Eff, IOE, (:>))+import Effectful.Tracing (Tracer)+import Network.AMQP (Ack (Ack), Channel, msgBody, newMsg)+import Effectful.Tracing.Instrumentation.Amqp qualified as Amqp++-- producer: publish, with the trace context written into the AMQP headers+placeOrder :: (IOE :> es, Tracer :> es) => Channel -> ByteString -> Eff es ()+placeOrder chan body = do+  _ <- Amqp.publishMsgTraced chan "orders" "orders.created" newMsg {msgBody = body}+  pure ()++-- consumer: poll, then process under the producer's trace+handleOrder :: (IOE :> es, Tracer :> es) => Channel -> Eff es ()+handleOrder chan = do+  received <- Amqp.getMsgTraced chan Ack "orders"+  case received of+    Nothing -> pure ()+    Just (msg, env) -> Amqp.withProcessSpan msg env (process (msgBody msg))+```++## Interoperate with B3 (Zipkin) headers++When the other side of a hop speaks B3 rather than W3C Trace Context (Zipkin,+Envoy, older meshes), swap in the B3 propagator from+`Effectful.Tracing.Propagation.B3`. It mirrors the W3C functions: `extractContextB3`+reads either the single `b3` header or the legacy `X-B3-*` multi-header form (the+single header wins when both are present), and `injectContextB3` writes the single+header (`injectContextB3Multi` writes the multi-header form).++```haskell+import Effectful (Eff, (:>))+import Effectful.Tracing (Tracer, withRemoteParent)+import Effectful.Tracing.Propagation.B3 (extractContextB3, injectContextB3)+import Network.HTTP.Types (Header)++-- inbound: continue a B3 caller's trace+b3Consume :: (Tracer :> es) => [Header] -> Eff es a -> Eff es a+b3Consume headers =+  maybe id withRemoteParent (extractContextB3 headers)++-- outbound: forward the active span as a single b3 header+b3Forward :: (Tracer :> es) => Eff es [Header]+b3Forward = injectContextB3+```++## Interoperate with Jaeger (uber-trace-id) headers++When the other side speaks native Jaeger rather than W3C or B3, swap in the+propagator from `Effectful.Tracing.Propagation.Jaeger`. `extractContextJaeger`+reads the `uber-trace-id` header and `injectContextJaeger` writes it; Jaeger's+per-item `uberctx-` baggage headers are handled by `extractBaggageJaeger` and+`injectBaggageJaeger`.++```haskell+import Effectful (Eff, (:>))+import Effectful.Tracing (Tracer, withRemoteParent)+import Effectful.Tracing.Baggage (BaggageContext, runBaggageWith)+import Effectful.Tracing.Propagation.Jaeger+  (extractBaggageJaeger, extractContextJaeger, injectContextJaeger)+import Network.HTTP.Types (Header)++-- inbound: continue a Jaeger caller's trace and seed its baggage+jaegerConsume :: (Tracer :> es) => [Header] -> Eff (BaggageContext : es) a -> Eff es a+jaegerConsume headers =+  runBaggageWith (extractBaggageJaeger headers)+    . maybe id withRemoteParent (extractContextJaeger headers)++-- outbound: forward the active span as an uber-trace-id header+jaegerForward :: (Tracer :> es) => Eff es [Header]+jaegerForward = injectContextJaeger+```++## Combine several propagators++A real deployment rarely speaks exactly one format. A service might emit W3C+`traceparent` for its own backend while still honouring inbound B3 from a mesh,+or run alongside legacy Jaeger clients during a migration. OpenTelemetry models+this with a **composite propagator**: a list of single-format propagators that+all run on inject (every format is written) and are tried in order on extract+(the first that parses wins). `Effectful.Tracing.Propagation.Composite` packages+each format as a value and provides the fan-out and collapse combinators.++```haskell+import Effectful (Eff, (:>))+import Effectful.Tracing (Tracer, withRemoteParent)+import Effectful.Tracing.Propagation.Composite+  (TraceContextPropagator, b3Single, extractContextFirst, injectContextAll, w3cTraceContext)+import Network.HTTP.Types (Header)++-- configure the formats once: emit W3C and B3, accept either inbound+propagators :: [TraceContextPropagator]+propagators = [w3cTraceContext, b3Single]++-- inbound: continue whichever format the caller used (W3C is tried first)+consume :: (Tracer :> es) => [Header] -> Eff es a -> Eff es a+consume headers = maybe id withRemoteParent (extractContextFirst propagators headers)++-- outbound: emit every configured format at once+forward :: (Tracer :> es) => Eff es [Header]+forward = injectContextAll propagators+```++Baggage composes the same way with `injectBaggageAll` / `extractBaggageAll` over+`w3cBaggage` and `jaegerBaggage`. Because baggage is additive (unlike a single+span context), extract merges the entries from every format rather than taking+just the first. Each standard propagator also carries the token name+OpenTelemetry's `OTEL_PROPAGATORS` variable uses for it (`tracecontext`, `b3`,+`b3multi`, `jaeger`, `baggage`), and `traceContextByToken` / `baggageByToken`+resolve a token to its propagator, which is how environment-variable+configuration selects them.++## Configure tracing from OTEL_ environment variables++OpenTelemetry defines a set of `OTEL_`-prefixed environment variables so an+operator can configure a service's tracing without a code change.+`Effectful.Tracing.EnvConfig` reads the subset that maps onto this library's+surface (service name, resource attributes, propagators, sampler) and hands back+an `EnvConfig` you wire into your interpreter at startup.++```haskell+import Effectful.Tracing.EnvConfig (EnvConfig (..), readEnvConfig)++main :: IO ()+main = do+  env <- readEnvConfig+  -- env has resolved fields you feed into your setup:+  --   serviceName env             :: Maybe Text+  --   resourceAttributes env      :: [Attribute]+  --   traceContextPropagators env :: [TraceContextPropagator]+  --   baggagePropagators env      :: [BaggagePropagator]+  --   tracesSampler env           :: Sampler+  -- ... build your OtelConfig with (tracesSampler env), continue/forward with+  -- the propagator lists (see "Combine several propagators"), and seed your+  -- resource with (serviceName env) and (resourceAttributes env).+  pure ()+```++The parse is pure: `parseEnvConfig` takes a variable-lookup function, so every+case is testable without touching the process environment, and `readEnvConfig`+is the thin `IO` wrapper over the real environment. `OTEL_PROPAGATORS` reuses the+token names from the composite propagator (`tracecontext`, `baggage`, `b3`,+`b3multi`, `jaeger`, `none`); `OTEL_TRACES_SAMPLER` understands `always_on`,+`always_off`, `traceidratio` (with `OTEL_TRACES_SAMPLER_ARG`), and the+`parentbased_` variants. Unset variables fall back to the OpenTelemetry defaults+(propagators `tracecontext,baggage`, sampler `parentbased_always_on`), and an+unrecognised token degrades to that default rather than failing at startup.++## Carry application context as baggage++When you want a value to ride along with the trace and be readable by every+downstream service (a tenant id, a request priority, an experiment bucket), use+**baggage** rather than a span attribute. Baggage is ambient: it is in scope for+everything that runs within it, not attached to one span, and it propagates+across hops through the `baggage` header. The `Effectful.Tracing.Baggage` effect+holds it; `Effectful.Tracing.Propagation.Baggage` renders and parses the header.++```haskell+import Data.Text (Text)+import Effectful (Eff, (:>))+import Effectful.Tracing (Tracer, withSpan)+import Effectful.Tracing.Baggage+  (BaggageContext, getBaggage, lookupBaggageValue, runBaggageWith, withBaggageEntry)+import Effectful.Tracing.Propagation.Baggage (extractBaggage, injectBaggage)+import Network.HTTP.Types (Header)++-- inbound: seed the ambient baggage from the request and discharge the effect,+-- so everything in 'work' runs with that baggage in scope+serveWithBaggage :: [Header] -> Eff (BaggageContext : es) a -> Eff es a+serveWithBaggage headers = runBaggageWith (extractBaggage headers)++-- read a baggage value anywhere in scope, with no plumbing through arguments+priorityOf :: (BaggageContext :> es) => Eff es (Maybe Text)+priorityOf = lookupBaggageValue "request.priority" <$> getBaggage++-- add an entry for a sub-scope, and forward all baggage to the next hop+handle :: (BaggageContext :> es, Tracer :> es) => Eff es [Header]+handle = withBaggageEntry "request.priority" "high" $ withSpan "handle" $+  injectBaggage   -- the outbound `baggage` header, carrying "request.priority"+```++Note `runBaggageWith` (or `runBaggage` to start empty) must wrap the computation+to discharge the `BaggageContext` effect, just as an interpreter discharges+`Tracer`. Baggage and span attributes are independent: putting a key in baggage+does not attach it to any span. Copy it onto a span explicitly with+`addAttribute` if you also want it recorded there.++## Name server spans by route, not just method++`traceMiddleware` names each server span after the request method (`GET`,+`POST`), which is deliberately low-cardinality. When your routing layer knows the+matched route template, `traceMiddlewareWith` lets you name spans+`"{method} {route}"`, which is far more useful in a trace list. Pass a route+*template* (`/users/{id}`), not the raw path (`/users/9921`), or you reintroduce+the high cardinality you were avoiding.++```haskell+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8Lenient)+import Effectful.Tracing.Instrumentation.Wai (traceMiddlewareWith)+import Network.Wai (Request, rawPathInfo, requestMethod)++-- Illustrative: this uses the raw path. In a real app, pass the matched route+-- template from your router instead of 'rawPathInfo'.+nameByRoute :: Request -> Text+nameByRoute req =+  decodeUtf8Lenient (requestMethod req) <> " " <> decodeUtf8Lenient (rawPathInfo req)++-- Then wrap your app with `traceMiddlewareWith nameByRoute runInIO app`.+```++With Servant you do not have to extract the route by hand. The+`servant` flag builds `Effectful.Tracing.Instrumentation.Servant`, which gives you+a `WithSpanName` combinator to annotate each endpoint with its route template and+a `traceServantMiddleware` that renames the server span to `"{method} {route}"`+and records `http.route` once routing has run.++```haskell+import Data.Proxy (Proxy (Proxy))+import Data.Text (Text)+import Effectful.Tracing.Instrumentation.Servant (WithSpanName, traceServantMiddleware)+import Servant++type API =+  WithSpanName "/users/{id}" :> "users" :> Capture "id" Int :> Get '[PlainText] Text+    :<|> WithSpanName "/health" :> "health" :> Get '[PlainText] Text++-- The combinator is transparent to handlers, so the server is written as usual.+apiServer :: Server API+apiServer = (\uid -> pure (renderUser uid)) :<|> pure "ok"++-- Then wrap the served app: `traceServantMiddleware runInIO (serve (Proxy :: Proxy API) apiServer)`.+```++## Instrument a long-running worker++A worker that loops forever should not open one giant span for its whole+lifetime; that span never closes and tells you nothing. Open one span per unit+of work instead, so each iteration is its own short trace.++```haskell+import Control.Monad (forever)++worker :: (Tracer :> es, Queue :> es) => Eff es ()+worker = forever $ do+  job <- takeJob+  -- One root span per job: it opens when the job starts and closes when the+  -- iteration ends, so each job is an independent trace you can find and time.+  withSpan "worker.handleJob" $ do+    addAttribute "job.id" (jobId job)+    process job+```++For a job that you want to *spawn* and not wait on, where nesting it under the+launching span would be misleading (the parent has long since returned), use+`forkLinked` from `Effectful.Tracing.Concurrent`. It starts the work as a new+root span with a link back to where it came from, so the causal connection is+preserved without a parent/child relationship that outlives its parent:++```haskell+import Effectful.Tracing.Concurrent (forkLinked)++enqueueBackground :: (Tracer :> es, Concurrent :> es) => Eff es ()+enqueueBackground = withSpan "request" $ do+  _ <- forkLinked (withSpan "background.reindex" doReindex)+  pure ()  -- returns immediately; the background span lives on as its own trace+```++## Assert on traces in your tests++To check that your own instrumentation emits the spans you expect, run the code+under the in-memory interpreter and assert on the captured spans.+`Effectful.Tracing.Testing` bundles the capture interpreter together with pure+matchers (`findSpan`, `childrenOf`, `isChildOf`, `hasStatus`, `lookupAttribute`,+and friends), so you do not have to reach into the internals. The matchers are+plain `Bool` / `Maybe`, so they pair with whatever assertion library you use.++```haskell+import Effectful (runEff)+import Effectful.Tracing (SpanStatus (Ok), addAttribute, setStatus, withSpan)+import Effectful.Tracing.Attribute (AttributeValue (AttrInt))+import Effectful.Tracing.Testing+  ( findSpan+  , hasStatus+  , isChildOf+  , isRoot+  , lookupAttribute+  , newCapturedSpans+  , readCapturedSpans+  , runTracerInMemory+  )+import Test.Tasty.HUnit (assertBool, (@?=))++-- A test that the handler opens a root span with an Ok status and a child+-- "db.query" span carrying the row count.+checkHandlerTrace :: IO ()+checkHandlerTrace = do+  spans <- runEff $ do+    captured <- newCapturedSpans+    runTracerInMemory captured $+      withSpan "handler" $ do+        setStatus Ok+        withSpan "db.query" (addAttribute "db.rows" (1 :: Int))+    readCapturedSpans captured+  case (findSpan "handler" spans, findSpan "db.query" spans) of+    (Just handler, Just db) -> do+      assertBool "handler is a root" (isRoot handler)+      assertBool "db.query is a child of handler" (db `isChildOf` handler)+      hasStatus Ok handler @?= True+      lookupAttribute "db.rows" db @?= Just (AttrInt 1)+    _ -> assertBool "both spans were captured" False+```++## Stamp logs with the active trace and span++To join your logs to your traces, stamp every log line with the trace and span+id that was active when it was written. `Effectful.Tracing.Log` reads the active+span and hands you the OpenTelemetry log-correlation fields (`trace_id`,+`span_id`, `trace_flags`) as plain key-value pairs, so they drop into any logger+(`co-log`, `katip`, `fast-logger`, or a bare handle) without a new dependency.++```haskell+import Data.Text (Text)+import Effectful (Eff, (:>))+import Effectful.Tracing (Tracer, withSpan)+import Effectful.Tracing.Log (activeCorrelationFields)++-- A structured log call that carries trace context when a span is active, and+-- degrades to no extra fields when one is not (a startup line, say).+logEvent :: (Tracer :> es) => (Text -> [(Text, Text)] -> Eff es ()) -> Text -> Eff es ()+logEvent emit message = do+  fields <- activeCorrelationFields+  emit message fields++handleRequest :: (Tracer :> es) => (Text -> [(Text, Text)] -> Eff es ()) -> Eff es ()+handleRequest emit = withSpan "handle" $+  logEvent emit "handling request"   -- log line now carries trace_id and span_id+```++`activeCorrelation` returns the same data as a `Correlation` record if you want+the ids individually (`correlationTraceId`, `correlationSpanId`), and+`activeTraceId` / `activeSpanId` return just one. All of them return the empty /+`Nothing` case when no span is in scope, so callers never have to special-case it.++## Customize the pretty-printed output++`defaultPrettyPrintConfig` shows attributes and events, no color, and durations+only. `PrettyPrintConfig` is a plain record, so override the fields you want.+There is no terminal auto-detection: set `useColor` yourself, for example from+`hIsTerminalDevice`.++```haskell+import Effectful (runEff)+import Effectful.Tracing.Interpreter.PrettyPrint+  (PrettyPrintConfig (..), TimeFormat (RelativeToTraceStart), defaultPrettyPrintConfig, runTracerPretty)+import System.IO (hIsTerminalDevice, stderr)++-- Colorize only when stderr is a terminal, show offsets from the trace start,+-- and hide events to keep the tree compact.+run action = do+  color <- hIsTerminalDevice stderr+  let config =+        (defaultPrettyPrintConfig stderr)+          { useColor = color+          , showEvents = False+          , timeFormat = RelativeToTraceStart+          }+  runEff (runTracerPretty config action)+```++`TimeFormat` is one of `DurationOnly` (the default), `RelativeToTraceStart`+(`+12ms (8ms)`), or `Absolute` (wall-clock start plus duration).++## Bound what a span records++A span with no upper bound on what it records is a memory hazard: a loop that+calls `addEvent` per iteration grows the in-flight span without limit, and a+stray multi-megabyte string value rides all the way to the exporter.+`Effectful.Tracing.SpanLimits` is the same guard the OpenTelemetry SDK applies:+a `SpanLimits` record that caps the attribute, event, and link counts per span+and truncates long string values. The count caps are enforced as the span+records (so an in-flight span cannot grow past the limit), and the value-length+cap truncates on the way out.++```haskell+import Effectful (runEff)+import Effectful.Tracing (alwaysOn)+import Effectful.Tracing.Interpreter.InMemory+  (newCapturedSpans, readCapturedSpans, runTracerInMemoryWithLimits)+import Effectful.Tracing.SpanLimits (SpanLimits (..), defaultSpanLimits)++-- Start from the OpenTelemetry defaults (128 attributes / events / links, no+-- value-length cap) and tighten the two fields you care about.+limits :: SpanLimits+limits = defaultSpanLimits {attributeValueLengthLimit = Just 1024, eventCountLimit = Just 64}++run action = do+  captured <- newCapturedSpans+  _ <- runTracerInMemoryWithLimits limits alwaysOn captured action+  readCapturedSpans captured+```++Each cap is a `Maybe Int`, where `Nothing` means unlimited. `defaultSpanLimits`+matches the OpenTelemetry SDK defaults; `unlimitedSpanLimits` disables every cap,+which is handy in a test that wants to assert on everything a computation+emitted. The same `spanLimits` field is on `PrettyPrintConfig` and `OtelConfig`,+so the pretty-print and OpenTelemetry interpreters take limits the same way.
+ docs/design.md view
@@ -0,0 +1,540 @@+# Design++How `effectful-tracing` is built and why. This is the thematic overview: it+explains the library's structure as it stands, organized by concept rather than+by the order things were built.++## The core idea++A span is a timed, named unit of work. This library models a span as a+**scoped, higher-order effect** on top of [`effectful`](https://hackage.haskell.org/package/effectful):++```haskell+withSpan "checkout" $ do+  addAttribute "cart.items" (3 :: Int)+  total <- withSpan "price.total" computeTotal+  setStatus Ok+  pure total+```++`withSpan` opens a span, runs the action inside it, and closes the span when the+action returns or throws. Because the span is the *scope* of an action rather+than an entry pushed onto a thread-local stack, "the currently active span" is+**lexical**: it follows the structure of your code. A `withSpan` nested inside+another is automatically the inner child of the outer, and that parent/child+relationship survives crossing `effectful`'s concurrency boundary with no manual+context plumbing.++That single decision (lexical, not thread-local) is what removes the class of+context-loss bugs that thread-local tracing APIs are prone to, and it is the+reason the rest of the design falls out as cleanly as it does.++You write instrumentation **once** against the `Tracer` effect, then choose an+*interpreter* to decide what happens to the finished spans: discard them, capture+them for tests, print them, or export them to OpenTelemetry. The traced code does+not change when you switch.++## Layering at a glance++The library is built in three layers, each depending only on the one below it:++```+  instrumentation:  WAI · http-client · Servant · database · messaging+                          │+   interpreters:  no-op · in-memory · pretty-print · OpenTelemetry+                          │+              the Tracer effect + smart constructors+                          │+        effect-system-independent data model (no effectful, no OTel)+```++The bottom layer (`Effectful.Tracing.Internal.{Ids,Types,Clock}` and+`Effectful.Tracing.Attribute`) knows nothing about `effectful` or+`hs-opentelemetry`. It is the vocabulary of tracing: identifiers, attributes,+trace flags and state, span context, and the immutable record of a completed+span. Everything above is expressed in those terms.++## The data model++All of the core types are **strict in every field** (`StrictData` and+`-funbox-strict-fields` are on package-wide). Nothing in the library relies on a+lazy field: there is no tying-the-knot and no infinite structure, so strict is+always the right default here.++### Identifiers++```haskell+newtype TraceId = TraceId ByteString  -- exactly 16 bytes+newtype SpanId  = SpanId  ByteString  -- exactly 8 bytes+```++- **Generation uses a fast PRNG by default, not a CSPRNG.** Bytes come from+  `random`'s splitmix-backed generator. This is the conventional SDK approach and+  keeps per-span allocation cheap. The `secure-ids` cabal flag swaps the byte+  source to `crypton`'s cryptographically secure system entropy for callers who+  need unpredictable ids, without changing the `newTraceId` / `newSpanId` names+  or types.+- **The all-zero id (the spec's "invalid" sentinel) is never minted.** The+  generators redraw on the astronomically unlikely all-zero result.+  `isValidTraceId` / `isValidSpanId` exist for parsed or remote ids.+- The hex codec is lowercase, matching the W3C / OpenTelemetry wire form.+  Encoding runs the input through `bytestring`'s builder-based `byteStringHex`+  (one pass, no intermediate `String`); the result is ASCII, so decoding back+  to `Text` is total.++### Attributes++```haskell+data AttributeValue+  = AttrText !Text | AttrBool !Bool | AttrInt !Int64 | AttrDouble !Double+  | AttrTextArray !(Vector Text) | AttrBoolArray !(Vector Bool)+  | AttrIntArray !(Vector Int64) | AttrDoubleArray !(Vector Double)++data Attribute = Attribute { attributeKey :: !Text, attributeValue :: !AttributeValue }+```++The eight constructors encode the OpenTelemetry rule that an attribute is a+scalar or a *homogeneous* array: a heterogeneous array is simply+unrepresentable. The `ToAttributeValue` class plus the `(.=)` helper keep+construction terse (`"http.response.status_code" .= (200 :: Int)`), and the instances+widen the obvious way (`String`/`Text` to `AttrText`, `Int`/`Int64` to+`AttrInt`, `Float`/`Double` to `AttrDouble`).++### Trace flags and trace state++```haskell+newtype TraceFlags = TraceFlags Word8     -- only bit 0 (sampled) is defined+newtype TraceState = TraceState [(Text, Text)]  -- ordered, most-recent first+```++`TraceFlags` preserves all eight bits on round-trip; only `sampled` (bit 0) has a+defined meaning today and the reserved bits must not be masked off.+`TraceState` enforces the W3C constraints on construction: at most 32 entries,+validated key and value grammars, and most-recently-mutated-first ordering.+`insertTraceState` returns `Nothing` on an invalid entry or when the cap would+be exceeded; the header parser drops malformed members rather than failing the+whole header (per the spec's resilience guidance), so it is total.++### Span context and the completed span++```haskell+data SpanContext = SpanContext+  { spanContextTraceId :: !TraceId, spanContextSpanId :: !SpanId+  , spanContextTraceFlags :: !TraceFlags, spanContextTraceState :: !TraceState+  , spanContextIsRemote :: !Bool }++data SpanKind   = Internal | Server | Client | Producer | Consumer+data SpanStatus = Unset | Ok | Error !Text++data Span = Span+  { spanContext :: !SpanContext, spanParentContext :: !(Maybe SpanContext)+  , spanName :: !Text, spanKind :: !SpanKind+  , spanStartTime :: !Timestamp, spanEndTime :: !Timestamp+  , spanAttributes :: ![Attribute], spanEvents :: ![Event]+  , spanLinks :: ![Link], spanStatus :: !SpanStatus }+```++`Span` is the immutable record of a *completed* span. It is the value that+crosses the boundary into an interpreter for capture or export. The mutable,+during-construction representation never escapes the interpreter layer.++## The `Tracer` effect++Tracing is a **dynamic, higher-order** `effectful` effect:++```haskell+data Tracer :: Effect where+  WithSpan         :: Text -> SpanArguments -> m a -> Tracer m a+  WithLinkedRoot   :: [Link] -> m a -> Tracer m a+  WithRemoteParent :: SpanContext -> m a -> Tracer m a+  AddAttribute     :: Text -> AttributeValue -> Tracer m ()+  AddAttributes    :: [Attribute] -> Tracer m ()+  AddEvent         :: Text -> [Attribute] -> Tracer m ()+  RecordException  :: SomeException -> Tracer m ()+  SetStatus        :: SpanStatus -> Tracer m ()+  GetActiveSpan    :: Tracer m (Maybe SpanContext)+```++Dynamic dispatch (rather than a static effect) is what lets each interpreter+supply completely different behavior for the same program. Higher-order+operations (`WithSpan` and friends take a sub-computation `m a`) are what make+the span a true scope: the interpreter runs the inner action with the new span+installed and tears it down afterward.++Users write against smart constructors (`withSpan`, `addAttribute`, ...), each+re-exported from `Effectful.Tracing` with the `Tracer` type kept abstract so the+constructors cannot be pattern-matched outside the library. `SpanArguments` is a+record (`kind`, `attributes`, `links`, `startTime`) with `defaultSpanArguments`,+so the common `withSpan "name"` stays a two-argument call and the rare cases set+only the field they care about.++### Status transitions, in one place++`setStatus` follows the OpenTelemetry rules, encoded once in a pure function that+every interpreter shares:++```haskell+transitionStatus :: SpanStatus -> SpanStatus -> SpanStatus+```++- `Unset` (the default) may move to `Ok` or `Error`.+- `Error` may be overridden by `Ok`.+- `Ok` is final: any later transition is ignored.+- A status is never downgraded back to `Unset`.++### Emitting with no active span is a silent no-op++`addAttribute`, `addAttributes`, `addEvent`, `recordException`, `setStatus`, and+`updateName` called outside any span are silent no-ops (matching OTel's no-op+span); they+never throw, and `getActiveSpan` returns `Nothing`. This is what lets you put a+`Tracer` constraint on a function and trace it from a caller that may or may not+be inside a span.++## The two load-bearing decisions++Everything that opens spans rests on two decisions. They are the heart of the+design.++### Decision A: the active span is lexical, never a shared mutable stack++The active span is carried in the handler's **private `Reader (Maybe ActiveSpan)`**,+installed with `reinterpret` and set for a child scope with `local` around the+unlifted action. It is emphatically *not* a process- or interpreter-wide+`TVar` / `IORef` "current span" stack.++A shared mutable active-span stack is the thread-local model under another name:+it races on `forkIO` and reintroduces exactly the context-loss bug this library+exists to eliminate. Keeping the active span in the `Reader` means it is part of+the effect environment, so when `effectful` clones that environment at a fork,+the child sees the right parent automatically. The *output sink* (where finished+spans accumulate) is a genuinely separate, write-only concern and may use `STM`;+the two must not be conflated.++`GetActiveSpan` simply reads this handler-local value.++### Decision B: a span closes exactly once, even when killed++`withSpan` must be async-exception safe. Finalization (record the end time, set+`Error` on an in-flight exception, emit the immutable span) has to run even when+the scoped action is killed asynchronously by `timeout`, `cancel`, or RTS+shutdown. The interpreter wraps the inner unlifted action in `generalBracket`+with appropriate masking, so the span is finalized exactly once. "Re-raise,+don't swallow" is necessary but not sufficient: without `bracket` a cancelled+action leaks an unclosed span.++## The shared lifecycle++Three interpreters open and close real spans (in-memory, pretty-print,+OpenTelemetry). They differ in exactly one way: **what to do with a completed+span.** Everything else (Decision A and Decision B, allocating ids, consulting+the sampler, accumulating attributes and events, finalizing under+`generalBracket`) is identical, so it lives once in+`Effectful.Tracing.Internal.Live` behind a single entry point:++```haskell+interpretTracer+  :: IOE :> es+  => Sampler+  -> (Span -> IO ())   -- the sink: what to do with each completed span+  -> Eff (Tracer : es) a+  -> Eff es a+```++A plain `Span -> IO ()` sink is all any interpreter needs (append to a buffer,+render a finished trace, hand to an exporter), so the shared handler never leaks+`Eff` or its private `Reader` into the sink type. The completed `Span` is forced+to WHNF before it reaches the sink, so a sink that *stores* it holds a finished+value rather than a thunk retaining the span's internal builder.++### Buffering until the root closes++Spans complete out of order: a parent's `generalBracket` cleanup runs after all+of its children's, so the full tree of a trace is not known until the root+closes. Interpreters that render or group a whole trace (pretty-print) buffer the+spans of each in-flight trace in a `TVar (Map TraceId [Span])` keyed on trace id,+and flush the trace as a unit the moment its root span closes.++## The interpreters++| Interpreter | Module | Sink behavior |+|-------------|--------|---------------|+| `runTracerNoOp` | `Interpreter.NoOp` | none: discharges `Tracer` with no observable effect |+| `runTracerInMemory` / `runTracerInMemoryWith` | `Interpreter.InMemory` | append to a `CapturedSpans` buffer you can assert on |+| `runTracerPretty` | `Interpreter.PrettyPrint` | render each finished trace as a tree to a `Handle` |+| `runTracerOTel` | `Interpreter.OpenTelemetry` (flag `otel`) | translate to an `hs-opentelemetry` span and hand to `SpanProcessor`s |++The no-op interpreter is special: it does not use the shared lifecycle at all. It+runs scoped actions unchanged (exceptions still propagate), makes emits silent,+and never has an active span. It is the interpreter for code that needs the+`Tracer` constraint when the caller does not want tracing, and the baseline for+the overhead benchmark. The fixed per-`withSpan` cost is roughly 15 ns (dynamic+dispatch plus the `localSeqUnlift`), so spans wrapping real work stay well under+the 5% overhead target.++The in-memory interpreter is the testing workhorse: `newCapturedSpans` /+`readCapturedSpans` plus `findSpan`, `childrenOf`, and `rootSpans` let a test+assert on exactly what a traced computation produced.++The pretty-print interpreter renders a finished trace as a tree on a `Handle`+(usually `stderr`) for local development. Its layout is produced by a *pure*+`renderTrace`, which is the unit of golden testing; the live interpreter is a+thin wrapper that buffers and calls it.++## Sampling++A `Sampler` decides, once per span at the moment it opens, whether to drop it,+record it without marking it sampled, or record and mark it sampled.++```haskell+data Sampler = Sampler { samplerName :: !Text, shouldSample :: SamplerInput -> IO SamplingResult }+data SamplingDecision = Drop | RecordOnly | RecordAndSample+```++- **`shouldSample` is plain `IO`, not `Eff`.** A sampler is a leaf decision+  function: easy to call, easy to test, with no effect-row plumbing. The+  interpreter calls it once when a span opens.+- **The decision drives the sink, not the user's code.** `Drop` still runs the+  scoped action and still establishes a lexical span for nested operations; it+  only suppresses the sink call, so user code behaves identically whether or not+  it was sampled. `RecordOnly` and `RecordAndSample` both reach the sink; they+  differ only in whether the `sampled` trace-flag bit is set. That bit is the+  single source of truth for "this trace is being sampled," and it propagates to+  children and across process boundaries. The OpenTelemetry interpreter is the+  one place the two recorded decisions diverge: it records locally and exports+  only `RecordAndSample`.+- **Built-ins:** `alwaysOn`, `alwaysOff`, `traceIdRatioBased fraction` (a+  deterministic fraction keyed on the trace id, so every span in a trace shares+  one decision), and `parentBased` (inherit the parent's decision, fall back to+  a root sampler) configured via `ParentBasedConfig` / `defaultParentBasedConfig`.+- **Decisions are uniform across a trace,** which avoids the "dangling parent"+  problem (a recorded child whose parent was dropped) that would produce a broken+  tree at the collector.++The default entry points (`runTracerInMemory`, `defaultPrettyPrintConfig`)+default to `alwaysOn`, so behavior is unchanged until you supply a sampler.++## Concurrency++Because the active span is a handler-local `Reader` value (Decision A) rather+than a thread-local, it travels across `effectful`'s concurrency boundary+automatically: `effectful` clones the environment at a fork, so the child thread+sees the launching span as its parent with no extra work. That makes the+concurrency helpers in `Effectful.Tracing.Concurrent` thin wrappers over+`forkIO` / `async` / `concurrently` / `forConcurrently`:++- `forkInstrumented`, `asyncInstrumented`, `concurrentlyInstrumented`,+  `forConcurrentlyInstrumented` spawn work that inherits the launching span as+  its parent (the "child of" relationship).+- `forkLinked` is different: it runs fire-and-forget work *detached*, starting a+  new root trace with a `Link` back to the caller (the "caused by" relationship).+  This is the right shape for work whose parent has long since returned, where+  nesting under the parent would be misleading. It is backed by the+  `withLinkedRoot` primitive, which detaches the active span and stages the+  links so the next root span picks them up.++## Context propagation across processes++`Effectful.Tracing.Propagation` carries a trace across a process boundary using+the standard W3C `traceparent` and `tracestate` headers, **with no dependency on+an OpenTelemetry SDK**:++- `injectContext` serializes the active span's context into a header list for an+  outbound request, and emits nothing when there is no active span (so it+  composes with a base header list unconditionally).+- `extractContext` parses an inbound request's headers into a remote+  `SpanContext`.+- `withRemoteParent` continues that remote trace locally: spans opened in its+  scope inherit the remote trace id and sampled flag and record the remote span+  as their parent. The remote context is marked `isRemote = True`, and the+  synthetic active span standing in for it is never finalized or emitted (it is+  not ours to emit).++Parsing is **strict where it matters and lenient where the spec says to be**:+header lookup is case-insensitive, future `traceparent` versions are accepted by+reading the first four fields, the all-zero ids and the reserved `ff` version are+rejected, and an unparsable `tracestate` is treated as empty rather than failing+the whole extraction.++## OpenTelemetry export++`runTracerOTel` (behind the `otel` flag) interprets `Tracer` by running the+shared lifecycle and, as each span finishes, translating it into an+`hs-opentelemetry` `ImmutableSpan` and handing it to the `SpanProcessor`s in its+`OtelConfig`.++The defining choice is that **identity stays ours.** Our trace and span ids and+our `Sampler` run *before* OpenTelemetry sees the span, and are copied verbatim+into the exported span. The benefit is that the ids `injectContext` puts on the+wire are exactly the ids that reach the collector, so propagation and export+never disagree. The cost is that the library reimplements a small translation+layer (`toImmutableSpan :: OTel.Tracer -> Span -> Either String OTel.ImmutableSpan`)+rather than getting it free from the SDK; the `Either` is total (it only fails on+a malformed id, which our own minting never produces) and exists mainly to give+the round-trip tests something to assert on.++Two consequences worth knowing:++- **Processors are passed in directly, not pulled from a provider**, because the+  SDK does not expose a provider's processors. They are force-flushed when the+  interpreter's scope ends.+- **The interpreter does not thread OpenTelemetry's in-process `Context`,** so it+  will not auto-nest spans across a boundary with *other*+  `hs-opentelemetry`-instrumented libraries. Within this library's own spans,+  nesting is exact; mixing span trees with a second OTel-instrumented library in+  the same process is out of scope by design.++## Instrumentation helpers++A set of helpers cover the common seams where work crosses a boundary: the two+HTTP edges (a WAI server, an http-client caller), the database client side, and+message queues. The web and SQL-driver bindings each sit behind a cabal flag (off+by default) so the base package never pulls in a web stack or a driver's C+dependency; the framework-agnostic database and messaging cores are always built,+because they add no dependencies of their own.++### WAI middleware (`wai` flag)++`traceMiddleware` (and `traceMiddlewareWith` for custom span names) wraps each+request in a `server`-kind span. It continues an inbound distributed trace by+reading `traceparent` / `tracestate`, attaches the request attributes at span+start (`http.request.method`, `url.path`, `url.scheme`, `network.protocol.version`,+and `url.query` when there is one), records `http.response.status_code` on the+response (a 5xx sets the span status to error; a 4xx does not, because a client+error is not the server's fault), and lets the shared lifecycle record any handler+exception before it propagates.++The interesting seam is that **WAI runs in `IO` but the `Tracer` effect lives in+`Eff`.** The middleware takes an unlift function obtained from `effectful`'s+`withEffToIO`; a real server handles requests concurrently, so it must use a+concurrent unlift strategy (`ConcUnlift Persistent Unlimited`). The response+status is captured by wrapping the responder, and the projected `Status` is+forced before it is stashed so the status ref does not pin the whole response+until the span closes.++On span naming: `traceMiddleware` names each span after the request *method*+(`GET`, `POST`), which is deliberately low-cardinality.+`traceMiddlewareWith` lets you name spans `"{method} {route}"` when your router+knows the matched route *template* (not the raw path, which would reintroduce the+high cardinality).++### http-client wrapper (`http-client` flag)++`httpLbsTraced` runs an `http-client` request inside a `client`-kind span. It is+a **request wrapper, not a `Manager` hook**, because the hooks run in `IO` with+no effect context, whereas the wrapper stays in `Eff es` (no unlift needed). It+injects the active context as `traceparent` / `tracestate` into the outbound+request *inside* the span (so the downstream hop continues this trace), records+`http.request.method` / `url.full` at start and `http.response.status_code` on the+response (a status `>= 400` sets the span status to error), and relies on the+shared lifecycle to record any thrown exception.++Both helpers speak W3C Trace Context, so a `server` span opened by the middleware+and a `client` span opened by the wrapper join into one distributed trace across+the hop, provided the handler runs *inside* `Eff` so the server span is active+when the outbound call fires. The attribute sets follow the stable OpenTelemetry+HTTP semantic conventions, with the keys collected in `Effectful.Tracing.SemConv`.++### Servant server instrumentation (`servant` flag)++`Effectful.Tracing.Instrumentation.Servant` layers route awareness on top of the+WAI middleware. A `WithSpanName` combinator annotates each endpoint with its route+*template* (`/users/{id}`), transparent to the handler, and `traceServantMiddleware`+renames the server span to `"{method} {route}"` and records `http.route` once+routing has matched. This is the structured form of `traceMiddlewareWith`: the+route template comes from the API type rather than from a hand-written extractor.++### Database and messaging (framework-agnostic cores plus driver bindings)++The database and message-queue client seams follow a different split from the+HTTP helpers: a **dependency-free core that is always built**, plus thin+**driver bindings behind their own flags**. The core carries the convention+mapping (which is reusable across every driver); a binding only adapts one+client's runners to it.++- `Effectful.Tracing.Instrumentation.Database` describes a call with a+  `DatabaseQuery` and runs it inside `withQuerySpan`, a `client`-kind span named+  `"{operation} {collection}"` carrying the stable `db.*` attributes.+  `inferOperationName` takes the operation from the statement's leading keyword+  (it does not parse SQL). Driver bindings layer on top:+  `Effectful.Tracing.Instrumentation.PostgresqlSimple` (flag `postgresql-simple`),+  `Effectful.Tracing.Instrumentation.SqliteSimple` (flag `sqlite-simple`), and+  `Effectful.Tracing.Instrumentation.Valiant` (flag `valiant`), each a drop-in for+  the driver's own runners that fills the `DatabaseQuery` from the statement.+- `Effectful.Tracing.Instrumentation.Messaging` describes a publish or consume+  with a `MessagingOperation` and runs it inside `withMessagingSpan`, which picks+  the span kind from the operation type (`producer` for `Send` / `Create`,+  `consumer` for `Receive` / `Process`, `client` for `Settle`) and records the+  `messaging.*` conventions. The trace crosses the broker through text message+  headers: `injectMessageHeaders` on the producer, `withConsumerSpan` (or+  `extractMessageHeaders`) on the consumer.+  `Effectful.Tracing.Instrumentation.Amqp` (flag `amqp`) is the concrete RabbitMQ+  binding over the `amqp` client, doing that header plumbing for you with+  `publishMsgTraced`, `getMsgTraced`, and `withProcessSpan`.++Because the bindings all need a live server, they are tested through the+always-built core (in-memory) plus a compile-only mirror; only their broker-free+pure helpers (such as the AMQP header decoder) are exercised at runtime.++## Strictness posture++The library is strict by default: `StrictData` and `-funbox-strict-fields` are on+package-wide, every data field is strict, and there are no `foldl`, lazy+`WriterT`, `Data.Map.Lazy`, or unprimed `modifyIORef` patterns. The accumulating+state (per-span attribute and event lists, the trace buffers) is held in strict+records mutated with `modifyIORef'` / `modifyTVar'`.++Three completed-value handoffs are forced explicitly so a thunk does not retain+more than the value it represents:++1. `finalizeSpan` returns the completed span via `pure $!`, so a storing sink+   holds a finished `Span` rather than a thunk retaining the span's builder+   `IORef` and active-span record.+2. The pretty-print interpreter forces the rebuilt per-trace map before+   `writeTVar`.+3. The WAI middleware projects and forces the response `Status` before stashing+   it, so the ref does not pin the whole response body until the span closes.++The wire-format parsers (`extractContext`, `traceIdFromHex`, `spanIdFromHex`,+`traceStateFromHeader`) consume untrusted bytes, so their most important contract+is **totality**: on any input they terminate and return a value, never loop and+never throw. A fuzz suite asserts this directly against both uniformly random and+`traceparent`-shaped input.++## Module surface and stability++`Effectful.Tracing` is the public entry point. It re-exports the data model, the+`Tracer` effect and smart constructors (with `Tracer` kept abstract), the+sampling and propagation surface, and the no-op interpreter. The span-opening+interpreters live in their own modules:++- `Effectful.Tracing.Interpreter.InMemory`+- `Effectful.Tracing.Interpreter.PrettyPrint`+- `Effectful.Tracing.Interpreter.OpenTelemetry` (flag `otel`)+- `Effectful.Tracing.Instrumentation.Wai` (flag `wai`)+- `Effectful.Tracing.Instrumentation.HttpClient` (flag `http-client`)+- `Effectful.Tracing.Instrumentation.Servant` (flag `servant`)+- `Effectful.Tracing.Instrumentation.Database` (always built) plus its driver+  bindings `PostgresqlSimple` (flag `postgresql-simple`), `SqliteSimple` (flag+  `sqlite-simple`), and `Valiant` (flag `valiant`)+- `Effectful.Tracing.Instrumentation.Messaging` (always built) plus its RabbitMQ+  binding `Amqp` (flag `amqp`)++Several capability modules round out the public surface, all always built:+`Effectful.Tracing.Sampler`, `Effectful.Tracing.SpanLimits`,+`Effectful.Tracing.Propagation` (with the `.B3`, `.Jaeger`, `.Baggage`, and+`.Composite` formats), `Effectful.Tracing.Baggage`, `Effectful.Tracing.EnvConfig`,+`Effectful.Tracing.Concurrent`, `Effectful.Tracing.Log`, and+`Effectful.Tracing.Testing`.++`Effectful.Tracing.Internal.*` modules are exposed so power users and the bridge+can reach them, but they are not re-exported and carry no stability promise. The+heavier dependencies (OpenTelemetry, WAI, http-client, Servant, the SQL drivers,+and amqp) sit behind the manual cabal flags above, all off by default, so the+base package stays light.++## See also++- [`tutorial.md`](tutorial.md): a guided walkthrough from a terminal trace to+  OpenTelemetry export.+- [`cookbook.md`](cookbook.md): focused recipes for everyday tasks.
+ docs/tutorial.md view
@@ -0,0 +1,243 @@+# Tutorial: from zero to OpenTelemetry export++This walks you from a first trace printed on your terminal to spans exported to a+local Jaeger, then through the features you reach for in real services: span+metadata, sampling, concurrency, and automatic HTTP instrumentation. Section 1+is a complete module; each later section adds to its imports rather than+repeating the scaffolding. Read it top to bottom and you should be productive in+about fifteen minutes.++The only prerequisite is a working GHC (9.10) and `cabal`. Docker is needed only+for the final Jaeger section.++## The mental model++A span is a timed, named unit of work. `effectful-tracing` models spans as a+scoped effect: `withSpan "name" action` opens a span, runs `action` inside it,+and closes the span when the action returns or throws. The "currently active+span" is **lexical**, it follows the structure of your code rather than a+thread-local variable, so a span opened inside another span is automatically its+child.++You write your code once against the `Tracer` effect, then choose an+*interpreter* to decide what happens to the spans: discard them (`runTracerNoOp`),+print them (`runTracerPretty`), capture them for tests (`runTracerInMemory`), or+export them to OpenTelemetry (`runTracerOTel`). The traced code never changes.++## 1. Your first trace++Start with the pretty-print interpreter. It needs no infrastructure and renders a+finished trace as a tree, which is the fastest way to see what your+instrumentation is doing.++```haskell+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import Data.Text (Text)+import Effectful (Eff, runEff, (:>))+import Effectful.Tracing+import Effectful.Tracing.Interpreter.PrettyPrint (defaultPrettyPrintConfig, runTracerPretty)+import System.IO (stderr)++checkout :: Tracer :> es => Eff es Int+checkout = withSpan "checkout" $ do+  addAttribute "cart.items" (3 :: Int)+  total <- withSpan "price.total" (pure 4200)+  setStatus Ok+  pure total++main :: IO ()+main = do+  total <- runEff (runTracerPretty (defaultPrettyPrintConfig stderr) checkout)+  print total+```++Running this prints a tree like:++```+trace 4f1a9c… (0ms)+└─ checkout (0ms) status=Ok+   cart.items=3+   └─ price.total (0ms)+```++Swap `runTracerPretty (defaultPrettyPrintConfig stderr)` for `runTracerNoOp` and+the same code runs with tracing fully disabled and no dependencies. That swap,+and only that swap, is how you move between backends.++## 2. Describing what happened++Inside any span you can attach metadata to the active span. None of these+require passing the span around: they annotate whatever span is lexically+current (and are silent no-ops when there is none).++```haskell+import Control.Exception (toException, ErrorCall (ErrorCall))++annotated :: Tracer :> es => Eff es ()+annotated = withSpan "handle.order" $ do+  -- A single typed attribute.+  addAttribute "order.id" ("o-9921" :: Text)+  -- Several at once, using (.=) to build them.+  addAttributes ["http.request.method" .= ("POST" :: Text), "http.response.status_code" .= (200 :: Int)]+  -- A point-in-time event on the span's timeline.+  addEvent "inventory.reserved" ["sku" .= ("widget-1" :: Text)]+  -- Record an error (does not itself end the span).+  recordException (toException (ErrorCall "downstream slow"))+  setStatus (Error "downstream slow")+```++Attribute values are typed: `Text`, `String`, `Bool`, `Int`, `Double`, and+homogeneous lists of those. The status follows the OpenTelemetry rules (`Ok` is+final, `Error` can be set over `Unset`, and a status is never downgraded).++## 3. Sampling++In production you rarely keep every trace. A `Sampler` decides, once per span at+the moment it opens, whether to drop it, record it without marking it sampled, or+record and mark it sampled. The interpreters that open spans take a sampler.++```haskell+import Effectful.Tracing.Interpreter.InMemory (newCapturedSpans, readCapturedSpans, runTracerInMemoryWith)++-- Keep a deterministic 10% of traces.+sampledRun :: Eff '[Tracer, IOE] a -> IO [Span]+sampledRun action = runEff $ do+  captured <- newCapturedSpans+  _ <- runTracerInMemoryWith (traceIdRatioBased 0.1) captured action+  readCapturedSpans captured+```++The built-in samplers are `alwaysOn`, `alwaysOff`, `traceIdRatioBased fraction`+(a deterministic fraction keyed on the trace id, so every span in a trace shares+one decision), and `parentBased` (inherit the parent's decision, fall back to a+root sampler). `parentBased` takes a `ParentBasedConfig`; the usual one is+`defaultParentBasedConfig rootSampler`, so you write+`parentBased (defaultParentBasedConfig alwaysOn)` as in section 6. See the+cookbook for "sample 1% but keep 100% of errors".++## 4. Concurrency++Because the active span is a handler-local value rather than a thread-local, it+travels across effectful's concurrency boundary automatically. The helpers in+`Effectful.Tracing.Concurrent` make spawned work nest correctly.++```haskell+import Effectful.Concurrent (Concurrent)+import Effectful.Tracing.Concurrent (concurrentlyInstrumented)++fanOut :: (Tracer :> es, Concurrent :> es) => Eff es (Int, Int)+fanOut = withSpan "fan.out" $+  -- Both branches are children of "fan.out".+  concurrentlyInstrumented+    (withSpan "left" (pure 1))+    (withSpan "right" (pure 2))+```++`asyncInstrumented` and `forConcurrentlyInstrumented` work the same way. For+fire-and-forget work that should start its *own* trace but still record where it+came from, use `forkLinked`, which detaches into a new root span with a link back+to the launching span.++## 5. Instrumenting HTTP automatically++Two optional helpers (behind the `wai` and `http-client` cabal flags) cover the+common server seams so you do not hand-write spans for every request. Enable them+with `--flags="wai http-client"`.++On the way in, wrap your WAI application; on the way out, call downstream+services through the traced wrapper. Both speak W3C Trace Context, so a request+that arrives with a `traceparent` continues the same distributed trace, and an+outbound call propagates it to the next hop.++```haskell+import Control.Monad.IO.Class (liftIO)+import Effectful+  (IOE, Limit (Unlimited), Persistence (Persistent), UnliftStrategy (ConcUnlift), withEffToIO)+import Effectful.Tracing.Instrumentation.Wai (traceMiddleware)+import Effectful.Tracing.Instrumentation.HttpClient (httpLbsTraced)+import Network.HTTP.Client (Manager, parseRequest)+import qualified Network.Wai.Handler.Warp as Warp++-- 'myApp :: Application' is your own WAI application; the middleware wraps it.+-- Inbound: a server span per request (use a concurrent unlift for a real server).+serve :: (IOE :> es, Tracer :> es) => Eff es ()+serve =+  withEffToIO (ConcUnlift Persistent Unlimited) $ \runInIO ->+    Warp.run 8080 (traceMiddleware runInIO myApp)++-- Outbound: a client span that injects traceparent into the request.+callDownstream :: (IOE :> es, Tracer :> es) => Manager -> Eff es ()+callDownstream manager = withSpan "load.profile" $ do+  req <- liftIO (parseRequest "http://users.internal/profile")+  _ <- httpLbsTraced req manager+  pure ()+```++See the "Instrumenting a web service" section of the README for the full picture.++## 6. Exporting to Jaeger++Finally, send real spans to a collector. Build with the `otel` flag and use+`runTracerOTel`, which keeps this library's ids and sampler as the source of+truth and translates each finished span into an `hs-opentelemetry` span for the+processors you supply.++Bring up a local Jaeger with an OTLP endpoint:++```yaml+# docker-compose.yml+services:+  jaeger:+    image: jaegertracing/all-in-one:1.57+    environment:+      COLLECTOR_OTLP_ENABLED: "true"+    ports:+      - "16686:16686"   # Jaeger UI+      - "4318:4318"     # OTLP HTTP+```++```+docker compose up -d+```++Then wire the exporter and processor from `hs-opentelemetry-sdk` /+`hs-opentelemetry-exporter-otlp` into `OtelConfig`:++```haskell+import Effectful.Tracing.Interpreter.OpenTelemetry (OtelConfig (..), runTracerOTel)+import Effectful.Tracing.SpanLimits (defaultSpanLimits)+import OpenTelemetry.Exporter.OTLP.Span (otlpExporter, loadExporterEnvironmentVariables)+import OpenTelemetry.Processor.Batch.Span (batchProcessor, batchTimeoutConfig)++main :: IO ()+main = do+  exporter  <- loadExporterEnvironmentVariables >>= otlpExporter+  processor <- batchProcessor batchTimeoutConfig exporter+  let config = OtelConfig+        { spanProcessors      = [processor]+        , instrumentationScope = "checkout-service"+        , sampler             = parentBased (defaultParentBasedConfig alwaysOn)+        , spanLimits          = defaultSpanLimits+        }+  total <- runEff (runTracerOTel config checkout)+  print total+```++Point the OTLP exporter at `http://localhost:4318` (its default, or set+`OTEL_EXPORTER_OTLP_ENDPOINT`), run your program, then open the Jaeger UI at+<http://localhost:16686> and find the `checkout-service` trace. The `checkout`+span and its `price.total` child appear as a tree, with the attributes and status+you set.++That is the whole arc: the `checkout` function you wrote in section 1 never+changed. You moved it from your terminal to a real distributed-tracing backend+purely by changing the interpreter.++## Where to go next++- [`cookbook.md`](cookbook.md): focused recipes for everyday tasks.+- [`design.md`](design.md): how the library is designed, organized by concept.+- The README's "Instrumenting a web service" section for the full HTTP wiring.
+ effectful-tracing.cabal view
@@ -0,0 +1,358 @@+cabal-version:      3.0+name:               effectful-tracing+version:            0.1.0.0+synopsis:           Tracing as a scoped effect, built on effectful, with OpenTelemetry interop.+description:+  A Haskell tracing library built natively on the @effectful@ effect system.+  Spans are modeled as scoped, higher-order effects, so the current span is+  lexical rather than thread-local. Real export is provided by an+  OpenTelemetry interpreter that compiles down to @hs-opentelemetry@; other+  interpreters (no-op, in-memory, pretty-print) cover testing and development.+  .+  This is an early release: the API is experimental and may change between+  versions. See the README and the @docs@ directory for a tutorial, cookbook,+  and design overview.+homepage:           https://github.com/joshburgess/effectful-tracing+bug-reports:        https://github.com/joshburgess/effectful-tracing/issues+license:            BSD-3-Clause+license-file:       LICENSE+author:             The effectful-tracing contributors+maintainer:         joshualoganburgess@gmail.com+copyright:          (c) The effectful-tracing contributors+category:           Tracing, Observability, Effect+build-type:         Simple+tested-with:        GHC == 9.6.7 || == 9.8.4 || == 9.10.3+extra-doc-files:+  README.md+  CHANGELOG.md+  docs/tutorial.md+  docs/cookbook.md+  docs/design.md++source-repository head+  type:     git+  location: https://github.com/joshburgess/effectful-tracing.git++flag otel+  description:+    Build the OpenTelemetry export interpreter+    (@Effectful.Tracing.Interpreter.OpenTelemetry@), which bridges to+    @hs-opentelemetry@. Off by default so the base package stays free of the+    OpenTelemetry dependency tree.+  default:     False+  manual:      True++flag wai+  description:+    Build the WAI tracing middleware+    (@Effectful.Tracing.Instrumentation.Wai@). Off by default so the base+    package does not depend on @wai@.+  default:     False+  manual:      True++flag http-client+  description:+    Build the http-client tracing wrappers+    (@Effectful.Tracing.Instrumentation.HttpClient@). Off by default so the base+    package does not depend on @http-client@.+  default:     False+  manual:      True++flag postgresql-simple+  description:+    Build the @postgresql-simple@ tracing wrappers+    (@Effectful.Tracing.Instrumentation.PostgresqlSimple@). Off by default so the+    base package does not depend on @postgresql-simple@ (and its @libpq@ C+    dependency).+  default:     False+  manual:      True++flag sqlite-simple+  description:+    Build the @sqlite-simple@ tracing wrappers+    (@Effectful.Tracing.Instrumentation.SqliteSimple@). Off by default so the+    base package does not depend on @sqlite-simple@ (and its bundled SQLite C+    sources).+  default:     False+  manual:      True++flag valiant+  description:+    Build the @valiant@ tracing wrappers+    (@Effectful.Tracing.Instrumentation.Valiant@) over the @valiant-effectful@+    adapter. Off by default so the base package does not depend on @valiant@ /+    @valiant-effectful@.+  default:     False+  manual:      True++flag amqp+  description:+    Build the @amqp@ (RabbitMQ) tracing wrappers+    (@Effectful.Tracing.Instrumentation.Amqp@). Off by default so the base+    package does not depend on @amqp@.+  default:     False+  manual:      True++flag servant+  description:+    Build the Servant route-aware tracing middleware+    (@Effectful.Tracing.Instrumentation.Servant@). Off by default so the base+    package does not depend on @servant-server@. Implies the WAI middleware, which+    it builds on, so it also pulls in @wai@.+  default:     False+  manual:      True++flag secure-ids+  description:+    Mint trace and span identifiers from a cryptographically secure source+    (@crypton@'s system entropy) instead of the default fast splitmix PRNG. Off+    by default: the fast PRNG is the conventional SDK choice and keeps per-span+    cost low. Turn this on when identifiers must be unpredictable to an+    attacker. The @newTraceId@ \/ @newSpanId@ surface is identical either way.+  default:     False+  manual:      True++common warnings+  ghc-options:+    -Wall+    -Wcompat+    -Widentities+    -Wincomplete-record-updates+    -Wincomplete-uni-patterns+    -Wmissing-export-lists+    -Wpartial-fields+    -Wredundant-constraints+    -funbox-strict-fields++common language+  default-language:   GHC2021+  default-extensions: StrictData++library+  import:          warnings, language+  hs-source-dirs:  src+  exposed-modules:+    Effectful.Tracing+    Effectful.Tracing.Attribute+    Effectful.Tracing.Baggage+    Effectful.Tracing.Concurrent+    Effectful.Tracing.Effect+    Effectful.Tracing.EnvConfig+    Effectful.Tracing.Instrumentation.Database+    Effectful.Tracing.Instrumentation.Messaging+    Effectful.Tracing.Log+    Effectful.Tracing.Interpreter.InMemory+    Effectful.Tracing.Interpreter.NoOp+    Effectful.Tracing.Interpreter.PrettyPrint+    Effectful.Tracing.Propagation+    Effectful.Tracing.Propagation.B3+    Effectful.Tracing.Propagation.Baggage+    Effectful.Tracing.Propagation.Composite+    Effectful.Tracing.Propagation.Jaeger+    Effectful.Tracing.Sampler+    Effectful.Tracing.SemConv+    Effectful.Tracing.SpanLimits+    Effectful.Tracing.Testing+    Effectful.Tracing.Internal.Clock+    Effectful.Tracing.Internal.Ids+    Effectful.Tracing.Internal.Live+    Effectful.Tracing.Internal.Types++  build-depends:+    , base             >=4.18  && <4.21+    , bytestring       >=0.11  && <0.13+    , case-insensitive >=1.2   && <1.3+    , containers       >=0.6   && <0.8+    , effectful        ==2.6.1.0+    , effectful-core   ==2.6.1.0+    , hashable         >=1.4   && <1.6+    , http-types       >=0.12  && <0.13+    , random           >=1.2.1 && <1.4+    , stm              >=2.5   && <2.6+    , text             >=2.0   && <2.2+    , time             >=1.12  && <1.15+    , vector           >=0.13  && <0.14++  if flag(otel)+    exposed-modules: Effectful.Tracing.Interpreter.OpenTelemetry+    build-depends:+      , clock                >=0.8   && <0.9+      , hs-opentelemetry-api ==0.3.1.0++  -- The Wai middleware backs the Servant integration, so it is built whenever+  -- either flag is on.+  if flag(wai) || flag(servant)+    exposed-modules: Effectful.Tracing.Instrumentation.Wai+    build-depends:   wai >=3.2 && <3.3++  if flag(servant)+    exposed-modules: Effectful.Tracing.Instrumentation.Servant+    build-depends:+      , servant        >=0.19 && <0.21+      , servant-server  >=0.19 && <0.21+      , vault           >=0.3  && <0.4++  if flag(http-client)+    exposed-modules: Effectful.Tracing.Instrumentation.HttpClient+    build-depends:   http-client >=0.7 && <0.8++  if flag(postgresql-simple)+    exposed-modules: Effectful.Tracing.Instrumentation.PostgresqlSimple+    build-depends:   postgresql-simple >=0.6 && <0.8++  if flag(sqlite-simple)+    exposed-modules: Effectful.Tracing.Instrumentation.SqliteSimple+    build-depends:   sqlite-simple >=0.4 && <0.5++  if flag(valiant)+    exposed-modules: Effectful.Tracing.Instrumentation.Valiant+    build-depends:+      , valiant           >=0.1 && <0.2+      , valiant-effectful >=0.1 && <0.2++  if flag(amqp)+    exposed-modules: Effectful.Tracing.Instrumentation.Amqp+    build-depends:   amqp >=0.22 && <0.25++  if flag(secure-ids)+    cpp-options:   -DSECURE_IDS+    build-depends: crypton >=1.0 && <1.2++test-suite effectful-tracing-test+  import:         warnings, language+  type:           exitcode-stdio-1.0+  hs-source-dirs: test+  main-is:        Main.hs+  ghc-options:    -threaded -rtsopts "-with-rtsopts=-N"+  other-modules:+    Effectful.Tracing.AsyncExceptionSpec+    Effectful.Tracing.AttributeSpec+    Effectful.Tracing.BaggageSpec+    Effectful.Tracing.CompileTest+    Effectful.Tracing.ConcurrentSpec+    Effectful.Tracing.EnvConfigSpec+    Effectful.Tracing.FuzzSpec+    Effectful.Tracing.Gen+    Effectful.Tracing.IdGenSpec+    Effectful.Tracing.IdsSpec+    Effectful.Tracing.InMemorySpec+    Effectful.Tracing.Instrumentation.DatabaseSpec+    Effectful.Tracing.Instrumentation.MessagingSpec+    Effectful.Tracing.LifecycleSpec+    Effectful.Tracing.LogSpec+    Effectful.Tracing.NoOpSpec+    Effectful.Tracing.PrettyPrintLeakSpec+    Effectful.Tracing.PrettyPrintSpec+    Effectful.Tracing.Propagation.B3Spec+    Effectful.Tracing.Propagation.CompositeSpec+    Effectful.Tracing.Propagation.JaegerSpec+    Effectful.Tracing.PropagationSpec+    Effectful.Tracing.PropertySpec+    Effectful.Tracing.SamplerSpec+    Effectful.Tracing.SpanLimitsSpec+    Effectful.Tracing.TestingSpec+    Effectful.Tracing.ThunkSpec+    Effectful.Tracing.TypesSpec++  build-depends:+    , base              >=4.18  && <4.21+    , bytestring        >=0.11  && <0.13+    , containers        >=0.6   && <0.8+    , effectful         ==2.6.1.0+    , effectful-core    ==2.6.1.0+    , effectful-tracing+    , hedgehog          >=1.4   && <1.6+    , http-types        >=0.12  && <0.13+    , nothunks          >=0.2   && <0.4+    , stm               >=2.5   && <2.6+    , tasty             >=1.4   && <1.6+    , tasty-golden      >=2.3   && <2.4+    , tasty-hedgehog    >=1.4   && <1.5+    , tasty-hunit       >=0.10  && <0.11+    , temporary         >=1.3   && <1.4+    , text              >=2.0   && <2.2+    , time              >=1.12  && <1.15+    , vector            >=0.13  && <0.14++  if flag(otel)+    cpp-options:     -DOTEL+    other-modules:   Effectful.Tracing.OpenTelemetrySpec+    build-depends:+      , async                >=2.2 && <2.3+      , hs-opentelemetry-api ==0.3.1.0++  if flag(wai) || flag(servant)+    build-depends: wai >=3.2 && <3.3++  if flag(wai)+    cpp-options:     -DWAI+    other-modules:   Effectful.Tracing.Instrumentation.WaiSpec++  if flag(servant)+    cpp-options:     -DSERVANT+    other-modules:   Effectful.Tracing.Instrumentation.ServantSpec+    build-depends:+      , servant        >=0.19 && <0.21+      , servant-server  >=0.19 && <0.21++  if flag(http-client)+    cpp-options:     -DHTTP_CLIENT+    other-modules:   Effectful.Tracing.Instrumentation.HttpClientSpec+    build-depends:+      , http-client >=0.7 && <0.8+      , wai         >=3.2 && <3.3+      , warp        >=3.3 && <3.5++  if flag(postgresql-simple)+    cpp-options:   -DPOSTGRESQL_SIMPLE+    build-depends: postgresql-simple >=0.6 && <0.8++  if flag(sqlite-simple)+    cpp-options:   -DSQLITE_SIMPLE+    build-depends: sqlite-simple >=0.4 && <0.5++  if flag(valiant)+    cpp-options:   -DVALIANT+    build-depends:+      , valiant           >=0.1 && <0.2+      , valiant-effectful >=0.1 && <0.2++  if flag(amqp)+    -- Named AMQP_BINDING, not AMQP: a bare -DAMQP would expand the AMQP token+    -- inside the Network.AMQP import path and break the parse.+    cpp-options:   -DAMQP_BINDING+    other-modules: Effectful.Tracing.Instrumentation.AmqpSpec+    build-depends: amqp >=0.22 && <0.25++  -- The id generator tests (Effectful.Tracing.IdGenSpec) run in both modes; this+  -- only flips the source label so the test output names which byte source was+  -- exercised. The crypton path itself is exercised because the linked library+  -- was built with +secure-ids.+  if flag(secure-ids)+    cpp-options:     -DSECURE_IDS++-- A standalone space-leak regression guard, run under a deliberately tiny+-- maximum stack (-K1K) so a thunk-accumulation regression in the span lifecycle+-- overflows and fails. Kept separate from the tasty suite, whose property tests+-- legitimately need a larger stack and so cannot share these RTS options.+test-suite effectful-tracing-space-leak+  import:         warnings, language+  type:           exitcode-stdio-1.0+  hs-source-dirs: test-space-leak+  main-is:        Main.hs+  ghc-options:    -rtsopts "-with-rtsopts=-K1K"+  build-depends:+    , base              >=4.18 && <4.21+    , effectful-core    ==2.6.1.0+    , effectful-tracing++benchmark effectful-tracing-bench+  import:         warnings, language+  type:           exitcode-stdio-1.0+  hs-source-dirs: bench+  main-is:        Main.hs+  build-depends:+    , base              >=4.18  && <4.21+    , effectful-core    ==2.6.1.0+    , effectful-tracing+    , tasty-bench       >=0.3.1 && <0.5
+ src/Effectful/Tracing.hs view
@@ -0,0 +1,150 @@+-- |+-- Module      : Effectful.Tracing+-- Description : Public entry point for the effectful-tracing library.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+-- Maintainer  : joshualoganburgess@gmail.com+-- Stability   : experimental+--+-- The public surface of @effectful-tracing@. This re-exports the core,+-- effect-system-independent data model (identifiers, attributes, trace flags+-- and state, the immutable 't:Span' record) together with the 'Tracer' effect and+-- its smart-constructor API, the sampling and context-propagation surface, and+-- the no-op interpreter. The span-opening interpreters live in their own+-- modules: @Effectful.Tracing.Interpreter.InMemory@,+-- @Effectful.Tracing.Interpreter.PrettyPrint@, and (behind the @otel@ flag)+-- @Effectful.Tracing.Interpreter.OpenTelemetry@.+module Effectful.Tracing+  ( -- * The tracing effect+    Tracer+  , withSpan+  , withSpan'+  , withLinkedRoot+  , withRemoteParent+  , addAttribute+  , addAttributes+  , addEvent+  , recordException+  , setStatus+  , updateName+  , getActiveSpan+  , SpanArguments (..)+  , defaultSpanArguments+  , transitionStatus++    -- * Interpreters+  , runTracerNoOp++    -- * Context propagation+  , traceparentHeader+  , tracestateHeader+  , injectContext+  , extractContext++    -- * Sampling+  , SamplingDecision (..)+  , SamplingResult (..)+  , Sampler (..)+  , SamplerInput+  , alwaysOn+  , alwaysOff+  , traceIdRatioBased+  , parentBased+  , ParentBasedConfig (..)+  , defaultParentBasedConfig++    -- * Attributes+  , module Effectful.Tracing.Attribute++    -- * Identifiers+  , TraceId+  , SpanId+  , newTraceId+  , newSpanId+  , traceIdToHex+  , spanIdToHex+  , traceIdFromHex+  , spanIdFromHex+  , isValidTraceId+  , isValidSpanId++    -- * Timestamps+  , Timestamp (..)+  , getTimestamp++    -- * Trace flags+  , TraceFlags+  , defaultTraceFlags+  , isSampled+  , setSampled++    -- * Trace state+  , TraceState+  , emptyTraceState+  , insertTraceState+  , lookupTraceState+  , traceStateEntries+  , traceStateToHeader+  , traceStateFromHeader+  , maxTraceStateEntries++    -- * Spans+  , SpanContext (..)+  , SpanKind (..)+  , SpanStatus (..)+  , Event (..)+  , Link (..)+  , Span (..)+  ) where++import Effectful.Tracing.Attribute+import Effectful.Tracing.Effect+  ( SpanArguments (..)+  , Tracer+  , addAttribute+  , addAttributes+  , addEvent+  , defaultSpanArguments+  , getActiveSpan+  , recordException+  , setStatus+  , transitionStatus+  , updateName+  , withLinkedRoot+  , withRemoteParent+  , withSpan+  , withSpan'+  )+import Effectful.Tracing.Interpreter.NoOp (runTracerNoOp)+import Effectful.Tracing.Propagation+  ( extractContext+  , injectContext+  , traceparentHeader+  , tracestateHeader+  )+import Effectful.Tracing.Sampler+  ( ParentBasedConfig (..)+  , Sampler (..)+  , SamplerInput+  , SamplingDecision (..)+  , SamplingResult (..)+  , alwaysOff+  , alwaysOn+  , defaultParentBasedConfig+  , parentBased+  , traceIdRatioBased+  )+import Effectful.Tracing.Internal.Clock (Timestamp (..), getTimestamp)+import Effectful.Tracing.Internal.Ids+  ( SpanId+  , TraceId+  , isValidSpanId+  , isValidTraceId+  , newSpanId+  , newTraceId+  , spanIdFromHex+  , spanIdToHex+  , traceIdFromHex+  , traceIdToHex+  )+import Effectful.Tracing.Internal.Types
+ src/Effectful/Tracing/Attribute.hs view
@@ -0,0 +1,124 @@+-- |+-- Module      : Effectful.Tracing.Attribute+-- Description : Attribute values and conversions.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+-- Stability   : experimental+--+-- Span attributes are typed key/value pairs. Following the OpenTelemetry data+-- model, a value is a scalar ('AttrText', 'AttrBool', 'AttrInt', 'AttrDouble')+-- or a /homogeneous/ array of one of those scalar types. Heterogeneous arrays+-- are unrepresentable by construction.+--+-- Use '(.=)' with the 'ToAttributeValue' class to build attributes ergonomically:+--+-- @+-- import Effectful.Tracing.Attribute+--+-- attrs :: [Attribute]+-- attrs =+--   [ \"http.method\" '.=' (\"GET\" :: Text)+--   , \"http.status_code\" '.=' (200 :: Int)+--   , \"http.request.header.accept\" '.=' ([\"application\/json\"] :: [Text])+--   ]+-- @+module Effectful.Tracing.Attribute+  ( AttributeValue (..)+  , Attribute (..)+  , (.=)+  , ToAttributeValue (..)+  ) where++import Data.Int (Int64)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Vector (Vector)+import Data.Vector qualified as V++-- | A typed attribute value: a scalar or a homogeneous array of scalars.+data AttributeValue+  = AttrText !Text+  | AttrBool !Bool+  | AttrInt !Int64+  | AttrDouble !Double+  | AttrTextArray !(Vector Text)+  | AttrBoolArray !(Vector Bool)+  | AttrIntArray !(Vector Int64)+  | AttrDoubleArray !(Vector Double)+  deriving (Eq, Show)++-- | A key/value attribute attached to a span, event, or link.+data Attribute = Attribute+  { attributeKey :: !Text+  , attributeValue :: !AttributeValue+  }+  deriving (Eq, Show)++-- | Build an 't:Attribute' from a key and any 'ToAttributeValue'.+(.=) :: (ToAttributeValue v) => Text -> v -> Attribute+key .= value = Attribute key (toAttributeValue value)++infixr 8 .=++-- | Types that can be used directly as an 'AttributeValue'.+--+-- Scalar instances cover 'Text', 'String', 'Bool', 'Int', 'Int64', 'Double',+-- and 'Float'. List and 'Vector' instances of those scalar types map to the+-- corresponding homogeneous array variants. @Int@ widens to @Int64@ and @Float@+-- widens to @Double@ to match the underlying representation.+class ToAttributeValue a where+  toAttributeValue :: a -> AttributeValue++instance ToAttributeValue AttributeValue where+  toAttributeValue = id++instance ToAttributeValue Text where+  toAttributeValue = AttrText++instance ToAttributeValue String where+  toAttributeValue = AttrText . T.pack++instance ToAttributeValue Bool where+  toAttributeValue = AttrBool++instance ToAttributeValue Int where+  toAttributeValue = AttrInt . fromIntegral++instance ToAttributeValue Int64 where+  toAttributeValue = AttrInt++instance ToAttributeValue Double where+  toAttributeValue = AttrDouble++instance ToAttributeValue Float where+  toAttributeValue = AttrDouble . realToFrac++instance ToAttributeValue (Vector Text) where+  toAttributeValue = AttrTextArray++instance ToAttributeValue (Vector Bool) where+  toAttributeValue = AttrBoolArray++instance ToAttributeValue (Vector Int64) where+  toAttributeValue = AttrIntArray++instance ToAttributeValue (Vector Double) where+  toAttributeValue = AttrDoubleArray++instance ToAttributeValue [Text] where+  toAttributeValue = AttrTextArray . V.fromList++instance ToAttributeValue [Bool] where+  toAttributeValue = AttrBoolArray . V.fromList++instance ToAttributeValue [Int64] where+  toAttributeValue = AttrIntArray . V.fromList++instance ToAttributeValue [Int] where+  toAttributeValue = AttrIntArray . V.fromList . map fromIntegral++instance ToAttributeValue [Double] where+  toAttributeValue = AttrDoubleArray . V.fromList++instance ToAttributeValue [Float] where+  toAttributeValue = AttrDoubleArray . V.fromList . map realToFrac
+ src/Effectful/Tracing/Baggage.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module      : Effectful.Tracing.Baggage+-- Description : Ambient key-value context (W3C Baggage) as a scoped effect.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+-- Stability   : experimental+--+-- <https://www.w3.org/TR/baggage/ W3C Baggage> is a set of key-value pairs that+-- travels alongside a trace across service boundaries, carrying application+-- context (a tenant id, a feature flag, a request priority) that any downstream+-- service can read. Unlike span attributes, baggage is not tied to a single+-- span: it is __ambient__, in scope for everything that runs within it.+--+-- This module models that ambient context the same way the 'Tracer' interpreters+-- model the active span: __lexically__, carried in a private @effectful@+-- @Reader@ and scoped with a @local@-style combinator+-- rather than thread-local mutable state. 'runBaggage' installs the context,+-- 'getBaggage' reads it, and 'localBaggage' \/ 'withBaggageEntry' set entries for+-- a nested scope only. Because the carrier is a handler-local value, baggage+-- propagates into forked work through @effectful@'s environment cloning, the same+-- as the active span (see "Effectful.Tracing.Concurrent").+--+-- The 't:Baggage' value, its pure operations, and this effect are all backend+-- independent. To carry baggage across a network hop, render and parse the+-- @baggage@ header with "Effectful.Tracing.Propagation.Baggage".+--+-- > import Effectful (runEff)+-- > import Effectful.Tracing.Baggage+-- >+-- > example = runEff . runBaggage $ do+-- >   withBaggageEntry "tenant.id" "acme" $ do+-- >     tenant <- lookupBaggageValue "tenant.id" <$> getBaggage+-- >     ...                                  -- tenant == Just "acme" in this scope+module Effectful.Tracing.Baggage+  ( -- * Baggage values+    Baggage+  , BaggageEntry (..)+  , emptyBaggage+  , insertBaggage+  , insertBaggageEntry+  , deleteBaggage+  , lookupBaggage+  , lookupBaggageValue+  , baggageToList+  , baggageFromList+  , nullBaggage+  , baggageSize++    -- * The ambient effect+  , BaggageContext+  , runBaggage+  , runBaggageWith+  , getBaggage+  , localBaggage+  , withBaggageEntry+  ) where++import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Text (Text)++import Effectful (Dispatch (Dynamic), DispatchOf, Eff, Effect, (:>))+import Effectful.Dispatch.Dynamic (localSeqUnlift, reinterpret, send)+import Effectful.Reader.Static (ask, local, runReader)++-- | One baggage entry: a value plus optional metadata. The metadata is the+-- verbatim @;@-separated property string the W3C format allows after a value+-- (for example @;ttl=30@); most entries have none. It is preserved on a+-- round-trip but otherwise opaque to this library.+data BaggageEntry = BaggageEntry+  { baggageValue :: !Text+  -- ^ The entry's value (already percent-decoded when parsed from a header).+  , baggageMetadata :: !(Maybe Text)+  -- ^ The verbatim property string, if any.+  }+  deriving (Eq, Show)++-- | An immutable set of baggage entries keyed by name. Construct it with+-- 'emptyBaggage' and the @insert@ \/ @delete@ operations, or parse it from a+-- header with "Effectful.Tracing.Propagation.Baggage".+newtype Baggage = Baggage (Map Text BaggageEntry)+  deriving (Eq, Show)++-- | The empty baggage set.+emptyBaggage :: Baggage+emptyBaggage = Baggage Map.empty++-- | Set a key to a bare value (no metadata), replacing any existing entry.+insertBaggage :: Text -> Text -> Baggage -> Baggage+insertBaggage key value = insertBaggageEntry key (BaggageEntry value Nothing)++-- | Set a key to a full 't:BaggageEntry' (value plus metadata), replacing any+-- existing entry.+insertBaggageEntry :: Text -> BaggageEntry -> Baggage -> Baggage+insertBaggageEntry key entry (Baggage m) = Baggage (Map.insert key entry m)++-- | Remove a key. A no-op if it is absent.+deleteBaggage :: Text -> Baggage -> Baggage+deleteBaggage key (Baggage m) = Baggage (Map.delete key m)++-- | Look up an entry (value and metadata) by key.+lookupBaggage :: Text -> Baggage -> Maybe BaggageEntry+lookupBaggage key (Baggage m) = Map.lookup key m++-- | Look up just the value for a key, ignoring any metadata.+lookupBaggageValue :: Text -> Baggage -> Maybe Text+lookupBaggageValue key = fmap baggageValue . lookupBaggage key++-- | All entries, ordered by key.+baggageToList :: Baggage -> [(Text, BaggageEntry)]+baggageToList (Baggage m) = Map.toList m++-- | Build baggage from a list of entries. On a duplicate key the last entry+-- wins.+baggageFromList :: [(Text, BaggageEntry)] -> Baggage+baggageFromList = Baggage . Map.fromList++-- | Whether the baggage set is empty.+nullBaggage :: Baggage -> Bool+nullBaggage (Baggage m) = Map.null m++-- | The number of entries.+baggageSize :: Baggage -> Int+baggageSize (Baggage m) = Map.size m++-- | The ambient-baggage capability. @GetBaggage@ reads the in-scope baggage;+-- @LocalBaggage@ runs a sub-action with the baggage transformed for that scope+-- only. The constructors are private: program against 'getBaggage',+-- 'localBaggage', and 'withBaggageEntry', and discharge the effect with+-- 'runBaggage' \/ 'runBaggageWith'.+data BaggageContext :: Effect where+  GetBaggage :: BaggageContext m Baggage+  LocalBaggage :: (Baggage -> Baggage) -> m a -> BaggageContext m a++type instance DispatchOf BaggageContext = Dynamic++-- | Discharge the effect starting from 'emptyBaggage'. Use this when a process+-- originates baggage itself.+runBaggage :: Eff (BaggageContext : es) a -> Eff es a+runBaggage = runBaggageWith emptyBaggage++-- | Discharge the effect starting from the given baggage. Use this to seed the+-- context from an inbound request, pairing it with+-- 'Effectful.Tracing.Propagation.Baggage.extractBaggage'.+--+-- The baggage is carried in a private @Reader@ and scoped with @local@, so it is+-- lexical: 'localBaggage' and 'withBaggageEntry' affect only their nested action.+runBaggageWith :: Baggage -> Eff (BaggageContext : es) a -> Eff es a+runBaggageWith initial =+  reinterpret (runReader initial) $ \env -> \case+    GetBaggage -> ask+    LocalBaggage f action ->+      localSeqUnlift env $ \unlift -> local f (unlift action)++-- | The baggage currently in scope.+getBaggage :: BaggageContext :> es => Eff es Baggage+getBaggage = send GetBaggage++-- | Run a sub-action with the baggage transformed by the given function. The+-- change is visible only inside the action (and anything it forks); the+-- surrounding scope is unchanged.+--+-- > localBaggage (insertBaggage "request.priority" "high") $ ...+localBaggage :: BaggageContext :> es => (Baggage -> Baggage) -> Eff es a -> Eff es a+localBaggage f action = send (LocalBaggage f action)++-- | Run a sub-action with one extra entry (a bare value) in scope. A+-- convenience for the common @'localBaggage' . 'insertBaggage'@.+--+-- > withBaggageEntry "tenant.id" "acme" $ ...+withBaggageEntry :: BaggageContext :> es => Text -> Text -> Eff es a -> Eff es a+withBaggageEntry key value = localBaggage (insertBaggage key value)
+ src/Effectful/Tracing/Concurrent.hs view
@@ -0,0 +1,127 @@+-- The instrumented wrappers carry a @Tracer :> es@ constraint as part of their+-- contract (they are meant for traced code and guarantee a tracer is in scope),+-- even though propagation is automatic and does not call any Tracer operation.+-- That makes the constraint redundant to GHC, so silence the warning here; the+-- constraint is intentional API, not an oversight. (forkLinked does use Tracer.)+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- |+-- Module      : Effectful.Tracing.Concurrent+-- Description : Span-propagating wrappers around effectful's concurrency.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+-- Stability   : experimental+--+-- Helpers that spawn concurrent work while propagating the current span, so a+-- @withSpan@ in a forked thread nests under the span that launched it. This is+-- the Haskell answer to the part of Rust's @tracing@ that @Instrument@ solves.+--+-- == Why these are thin wrappers+--+-- The active span is __lexical__: the live interpreter keeps it in a private+-- handler-local value, not a shared mutable stack (see+-- "Effectful.Tracing.Internal.Live"). @effectful@'s concurrency combinators+-- ("Effectful.Concurrent", "Effectful.Concurrent.Async") clone the effect+-- environment at the point of the fork, so the child thread starts with exactly+-- the active span that was in scope when it was spawned. Propagation is+-- therefore automatic, and these functions are 'Effectful.Concurrent.forkIO',+-- 'Effectful.Concurrent.Async.async', and friends with a @'Tracer' ':>' es@+-- constraint that documents intent and pins the relationship at the point of+-- the fork. Had the active span been a shared stack, the child would race the+-- parent for the stack top and this would be a swamp of races; it is not,+-- because the representation was chosen to avoid exactly that.+--+-- == Parent versus link+--+-- The default ('forkInstrumented', 'asyncInstrumented', and the rest) is+-- __inherit as parent__: forked spans are children of the launching span, which+-- is what you want for concurrent work that is logically part of the same unit+-- (a fan-out of requests whose results you wait on). For fire-and-forget+-- background work whose lifetime is unrelated to the caller, that parent/child+-- nesting is misleading. 'forkLinked' instead starts the work as a new root+-- trace with a __link__ back to the launching span: a "caused by" reference+-- rather than "child of".+--+-- == Gotchas+--+-- Only the helpers in this module propagate. A bare+-- @'Control.Monad.IO.Class.liftIO' ('Control.Concurrent.forkIO' ...)@ escapes+-- the effect system entirely and carries no span, and so does anything that+-- runs an action through a raw 'IO' callback (for example a third-party library+-- that takes an @IO ()@ worker). Spawn through these wrappers, or re-establish+-- context inside the thread, to keep the trace connected.+module Effectful.Tracing.Concurrent+  ( -- * Inherit the launching span as parent+    forkInstrumented+  , asyncInstrumented+  , concurrentlyInstrumented+  , forConcurrentlyInstrumented++    -- * Link instead of nest+  , forkLinked+  ) where++import Control.Concurrent (ThreadId)++import Effectful (Eff, (:>))+import Effectful.Concurrent (Concurrent, forkIO)+import Effectful.Concurrent.Async (Async, async, concurrently, forConcurrently)++import Effectful.Tracing.Effect (Tracer, getActiveSpan, withLinkedRoot)+import Effectful.Tracing.Internal.Types (Link (Link))++-- | Fork a thread whose work nests under the current span. A 'Effectful.Tracing.Effect.withSpan' inside+-- the forked action opens a child of the span that was active at the fork; with+-- no active span it opens a root, exactly as it would in the launching thread.+forkInstrumented+  :: (Tracer :> es, Concurrent :> es)+  => Eff es ()+  -> Eff es ThreadId+forkInstrumented = forkIO++-- | Spawn an 'Async' whose span is a child of the launching span. The result is+-- awaited with the usual "Effectful.Concurrent.Async" combinators+-- (@wait@, @waitCatch@, and so on).+asyncInstrumented+  :: (Tracer :> es, Concurrent :> es)+  => Eff es a+  -> Eff es (Async a)+asyncInstrumented = async++-- | Run two actions concurrently, each as a child of the launching span, and+-- return both results once both finish. If either throws, the other is+-- cancelled and the exception is re-raised (standard @concurrently@ semantics);+-- the throwing branch's span is closed with an 'Effectful.Tracing.Error' status.+concurrentlyInstrumented+  :: (Tracer :> es, Concurrent :> es)+  => Eff es a+  -> Eff es b+  -> Eff es (a, b)+concurrentlyInstrumented = concurrently++-- | Map a tracing action over a list concurrently, each call a child of the+-- launching span.+forConcurrentlyInstrumented+  :: (Tracer :> es, Concurrent :> es)+  => [a]+  -> (a -> Eff es b)+  -> Eff es [b]+forConcurrentlyInstrumented = forConcurrently++-- | Fork fire-and-forget work that is __linked__ to, rather than nested under,+-- the current span. The forked action runs detached, so its first 'Effectful.Tracing.Effect.withSpan'+-- starts a new root trace; that root carries a 't:Link' back to the span that was+-- active at the fork, recording the "caused by" relationship. With no active+-- span this is just 'forkInstrumented' (there is nothing to link to).+--+-- Use this for background work whose lifetime outlives the caller (a cache+-- warm, a deferred index rebuild), where threading the caller's trace through+-- would distort the parent's duration and tree.+forkLinked+  :: (Tracer :> es, Concurrent :> es)+  => Eff es ()+  -> Eff es ThreadId+forkLinked body = do+  caller <- getActiveSpan+  let links = maybe [] (\context -> [Link context []]) caller+  forkInstrumented (withLinkedRoot links body)
+ src/Effectful/Tracing/Effect.hs view
@@ -0,0 +1,262 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module      : Effectful.Tracing.Effect+-- Description : The @Tracer@ effect and its smart-constructor API.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+-- Stability   : experimental+--+-- The 'Tracer' effect, modeled as a dynamic @effectful@ effect because tracing+-- has many valid interpretations (no-op, in-memory, OpenTelemetry export). The+-- only higher-order operation is 'WithSpan', which runs a scoped action inside+-- a fresh child span; the rest are first-order emit operations against the+-- currently-active span.+--+-- This module exposes the raw effect constructors so interpreters can pattern+-- match on them. End users should program against the smart constructors+-- ('withSpan', 'addAttribute', and friends), which hide @send@ and the+-- constructor types. The public "Effectful.Tracing" module re-exports the smart+-- constructors and 'Tracer' as an abstract type.+module Effectful.Tracing.Effect+  ( -- * The effect+    Tracer (..)++    -- * Span arguments+  , SpanArguments (..)+  , defaultSpanArguments++    -- * Scoping a span+  , withSpan+  , withSpan'+  , withLinkedRoot+  , withRemoteParent++    -- * Annotating the active span+  , addAttribute+  , addAttributes+  , addEvent+  , recordException+  , setStatus+  , updateName+  , getActiveSpan++    -- * Status transitions+  , transitionStatus+  ) where++import Control.Exception (SomeException)+import Data.Text (Text)+import Data.Time.Clock (UTCTime)+import GHC.Stack (HasCallStack)++import Effectful (Dispatch (Dynamic), DispatchOf, Eff, Effect, (:>))+import Effectful.Dispatch.Dynamic (send)++import Effectful.Tracing.Attribute (Attribute, AttributeValue, ToAttributeValue, toAttributeValue)+import Effectful.Tracing.Internal.Types+  ( Link+  , SpanContext+  , SpanKind (Internal)+  , SpanStatus (..)+  )++-- | Tracing as a scoped effect. 'WithSpan' is higher-order: it runs the scoped+-- action @m a@ inside a child span whose parent is the lexically-current active+-- span. 'WithLinkedRoot' is also higher-order: it detaches the active span for+-- its scope (so a nested 'WithSpan' starts a new root trace) while recording+-- links to the spans that caused the work. 'WithRemoteParent' is the inbound+-- counterpart: it makes a remote span context the active parent for its scope,+-- so a nested 'WithSpan' continues that remote trace. The remaining operations+-- annotate the active span and are no-ops when there is none (see+-- "Effectful.Tracing.Effect#no-active-span").+data Tracer :: Effect where+  WithSpan :: Text -> SpanArguments -> m a -> Tracer m a+  WithLinkedRoot :: [Link] -> m a -> Tracer m a+  WithRemoteParent :: SpanContext -> m a -> Tracer m a+  AddAttribute :: Text -> AttributeValue -> Tracer m ()+  AddAttributes :: [Attribute] -> Tracer m ()+  AddEvent :: Text -> [Attribute] -> Tracer m ()+  RecordException :: SomeException -> Tracer m ()+  SetStatus :: SpanStatus -> Tracer m ()+  UpdateName :: Text -> Tracer m ()+  GetActiveSpan :: Tracer m (Maybe SpanContext)++type instance DispatchOf Tracer = Dynamic++-- | Optional parameters for a new span. A record (rather than positional+-- arguments) so new fields can be added without breaking callers, who build it+-- from 'defaultSpanArguments' with record updates.+data SpanArguments = SpanArguments+  { kind :: !SpanKind+  -- ^ The span's role in the trace. Defaults to 'Internal'.+  , attributes :: ![Attribute]+  -- ^ Attributes to attach at span start.+  , links :: ![Link]+  -- ^ Links to other spans (causal references outside the parent/child tree).+  , startTime :: !(Maybe UTCTime)+  -- ^ An explicit start time; 'Nothing' means "now" at the moment the span+  -- opens.+  }++-- | The default arguments: an 'Internal' span with no initial attributes or+-- links and an implicit "now" start time.+--+-- > withSpan' "db.query" defaultSpanArguments { kind = Client } $ do+-- >   ...+defaultSpanArguments :: SpanArguments+defaultSpanArguments =+  SpanArguments+    { kind = Internal+    , attributes = []+    , links = []+    , startTime = Nothing+    }++-- | Run an action inside a new child span with the given name and default+-- arguments. The span opens before the action runs and is closed (with its end+-- time, and 'Error' status if the action throws) when it returns or unwinds.+--+-- > total :: Tracer :> es => Eff es Int+-- > total = withSpan "compute.total" $ do+-- >   addAttribute "items" (3 :: Int)+-- >   pure 6+withSpan+  :: (HasCallStack, Tracer :> es)+  => Text+  -> Eff es a+  -> Eff es a+withSpan name = withSpan' name defaultSpanArguments++-- | 'withSpan' with explicit 't:SpanArguments'.+--+-- > fetch :: Tracer :> es => Eff es Response+-- > fetch = withSpan' "http.get" defaultSpanArguments { kind = Client } $ do+-- >   ...+withSpan'+  :: (HasCallStack, Tracer :> es)+  => Text+  -> SpanArguments+  -> Eff es a+  -> Eff es a+withSpan' name args action = send (WithSpan name args action)++-- | Run an action detached from the current trace, recording the given links as+-- "caused by" references. Inside the scope there is no active span, so the+-- first 'withSpan' opens a new __root__ span (a new trace) rather than a child+-- of the enclosing span; the links are attached to that root. This expresses a+-- causal relationship for work that is triggered by, but does not belong to,+-- the current trace, such as fire-and-forget background tasks.+--+-- "Effectful.Tracing.Concurrent" builds @forkLinked@ on this: it captures the+-- current span context as a link and forks the body inside a linked root scope.+--+-- > withLinkedRoot [Link callerContext []] $+-- >   withSpan "background.reindex" $ ...+withLinkedRoot+  :: (HasCallStack, Tracer :> es)+  => [Link]+  -> Eff es a+  -> Eff es a+withLinkedRoot links action = send (WithLinkedRoot links action)++-- | Run an action as if it were a child of the given remote span. Inside the+-- scope the active span is the remote context, so the first 'withSpan'+-- continues that trace: it inherits the remote trace id and sampled flag and+-- records the remote span as its parent. This is how an inbound request rejoins+-- a distributed trace; pair it with 'Effectful.Tracing.Propagation.extractContext'+-- to turn @traceparent@ / @tracestate@ headers into the 't:SpanContext'.+--+-- The remote span is not local and is never emitted: this only sets the parent+-- for spans opened within the scope. Emit operations issued directly in the+-- scope (outside any 'withSpan') have no local span to annotate and are+-- dropped.+--+-- > withRemoteParent inbound $+-- >   withSpan' "handle.request" defaultSpanArguments { kind = Server } $ ...+withRemoteParent+  :: (HasCallStack, Tracer :> es)+  => SpanContext+  -> Eff es a+  -> Eff es a+withRemoteParent context action = send (WithRemoteParent context action)++-- | Attach a single attribute to the active span. No-op if there is no active+-- span.+--+-- > addAttribute "user.id" ("u123" :: Text)+addAttribute+  :: (HasCallStack, Tracer :> es, ToAttributeValue v)+  => Text+  -> v+  -> Eff es ()+addAttribute key value = send (AddAttribute key (toAttributeValue value))++-- | Attach several attributes to the active span. No-op if there is no active+-- span.+--+-- > addAttributes ["http.method" .= ("GET" :: Text), "http.status" .= (200 :: Int)]+addAttributes :: (HasCallStack, Tracer :> es) => [Attribute] -> Eff es ()+addAttributes = send . AddAttributes++-- | Record a timestamped event on the active span. No-op if there is no active+-- span.+--+-- > addEvent "cache.miss" ["key" .= ("session:42" :: Text)]+addEvent :: (HasCallStack, Tracer :> es) => Text -> [Attribute] -> Eff es ()+addEvent name attrs = send (AddEvent name attrs)++-- | Record an exception as an event on the active span. This does not set the+-- span's status; pair it with 'setStatus' if the exception is fatal. No-op if+-- there is no active span.+--+-- > recordException (toException err)+recordException :: (HasCallStack, Tracer :> es) => SomeException -> Eff es ()+recordException = send . RecordException++-- | Set the active span's status, following the OpenTelemetry transition rules+-- (see 'transitionStatus'). No-op if there is no active span.+--+-- > setStatus (Error "upstream timeout")+setStatus :: (HasCallStack, Tracer :> es) => SpanStatus -> Eff es ()+setStatus = send . SetStatus++-- | Replace the active span's name. This is OpenTelemetry's @Span.updateName@:+-- useful when the final, low-cardinality name is only known after the span has+-- opened, such as a server span that learns its matched route template once the+-- routing layer has run. No-op if there is no active span.+--+-- > updateName "GET /users/{id}"+updateName :: (HasCallStack, Tracer :> es) => Text -> Eff es ()+updateName = send . UpdateName++-- | The active span's context, or 'Nothing' if there is no active span.+--+-- > parent <- getActiveSpan+getActiveSpan :: (HasCallStack, Tracer :> es) => Eff es (Maybe SpanContext)+getActiveSpan = send GetActiveSpan++-- | Combine the current span status with a proposed one, per the OpenTelemetry+-- rules:+--+-- * 'Unset' is the default and may move to either 'Ok' or 'Error'.+-- * 'Error' may be overridden by 'Ok'.+-- * 'Ok' is final: any later transition is ignored.+-- * A status is never downgraded back to 'Unset'.+--+-- Every interpreter routes @setStatus@ through this single function so the+-- semantics stay consistent.+transitionStatus+  :: SpanStatus+  -- ^ current+  -> SpanStatus+  -- ^ proposed+  -> SpanStatus+transitionStatus current proposed =+  case current of+    Ok -> Ok+    _ -> case proposed of+      Unset -> current+      _ -> proposed
+ src/Effectful/Tracing/EnvConfig.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.EnvConfig+-- Description : Read OpenTelemetry configuration from environment variables.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+-- Stability   : experimental+--+-- OpenTelemetry defines a set of @OTEL_@-prefixed+-- <https://opentelemetry.io/docs/specs/otel/configuration/sdk-environment-variables/ environment variables>+-- so an operator can configure a service's tracing without touching code. This+-- module reads the subset that maps onto the library's own surface and packages+-- it as an 'EnvConfig' you wire into your interpreter at startup:+--+-- * @OTEL_SERVICE_NAME@: the service name (falling back to a @service.name@+--   entry in @OTEL_RESOURCE_ATTRIBUTES@).+-- * @OTEL_RESOURCE_ATTRIBUTES@: extra resource attributes, in the W3C Baggage+--   octet format (comma-separated @key=value@, percent-decoded).+-- * @OTEL_PROPAGATORS@: the propagators to install, as a comma-separated list of+--   tokens (@tracecontext@, @baggage@, @b3@, @b3multi@, @jaeger@, or @none@),+--   resolved through "Effectful.Tracing.Propagation.Composite".+-- * @OTEL_TRACES_SAMPLER@ / @OTEL_TRACES_SAMPLER_ARG@: the sampler+--   (@always_on@, @always_off@, @traceidratio@, and the @parentbased_@ variants),+--   built from "Effectful.Tracing.Sampler".+--+-- > import Effectful.Tracing.EnvConfig (EnvConfig (..), readEnvConfig)+-- >+-- > main :: IO ()+-- > main = do+-- >   env <- readEnvConfig+-- >   let propagators = traceContextPropagators env+-- >   -- ... build your OtelConfig with (tracesSampler env), seed resource+-- >   -- attributes with (resourceAttributes env), and so on.+--+-- The parse is pure ('parseEnvConfig' takes a lookup function), so it is fully+-- testable without touching the process environment; 'readEnvConfig' is the thin+-- 'IO' wrapper that reads the real environment. Unset variables fall back to the+-- OpenTelemetry defaults (propagators @tracecontext,baggage@; sampler+-- @parentbased_always_on@), and an unrecognised sampler or propagator token+-- degrades to that default rather than failing.+module Effectful.Tracing.EnvConfig+  ( -- * Configuration+    EnvConfig (..)+  , defaultEnvConfig++    -- * Reading the environment+  , readEnvConfig+  , parseEnvConfig++    -- * Individual readers (pure)+  , parseServiceName+  , parseResourceAttributes+  , parsePropagators+  , parseSampler+  ) where++import Data.Maybe (fromMaybe, mapMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import System.Environment (getEnvironment)+import Text.Read (readMaybe)++import Effectful.Tracing.Attribute (Attribute, (.=))+import Effectful.Tracing.Baggage (BaggageEntry (baggageValue), baggageToList)+import Effectful.Tracing.Propagation.Baggage (parseBaggage)+import Effectful.Tracing.Propagation.Composite+  ( BaggagePropagator+  , TraceContextPropagator+  , baggageByToken+  , traceContextByToken+  , w3cBaggage+  , w3cTraceContext+  )+import Effectful.Tracing.Sampler+  ( Sampler+  , alwaysOff+  , alwaysOn+  , defaultParentBasedConfig+  , parentBased+  , traceIdRatioBased+  )++-- | The tracing configuration read from the @OTEL_@ environment variables.+-- Every field has a resolved value: lists are empty when nothing is configured,+-- and 'tracesSampler' is always a concrete sampler (the OpenTelemetry default+-- when unset). 'serviceName' is the one optional field, 'Nothing' when neither+-- @OTEL_SERVICE_NAME@ nor a @service.name@ resource attribute is present.+data EnvConfig = EnvConfig+  { serviceName :: !(Maybe Text)+  -- ^ @OTEL_SERVICE_NAME@, or the @service.name@ entry from+  -- @OTEL_RESOURCE_ATTRIBUTES@, whichever is present (the former wins).+  , resourceAttributes :: ![Attribute]+  -- ^ The @OTEL_RESOURCE_ATTRIBUTES@ entries as typed attributes. Does not+  -- include 'serviceName'; copy that on separately if you want it as a resource+  -- attribute too.+  , traceContextPropagators :: ![TraceContextPropagator]+  -- ^ The span-context propagators named in @OTEL_PROPAGATORS@, in order.+  , baggagePropagators :: ![BaggagePropagator]+  -- ^ The baggage propagators named in @OTEL_PROPAGATORS@, in order.+  , tracesSampler :: !Sampler+  -- ^ The sampler from @OTEL_TRACES_SAMPLER@ / @OTEL_TRACES_SAMPLER_ARG@,+  -- defaulting to @parentbased_always_on@.+  }++-- | The configuration an empty environment yields: no service name, no resource+-- attributes, the default @tracecontext,baggage@ propagators, and the+-- @parentbased_always_on@ sampler.+defaultEnvConfig :: EnvConfig+defaultEnvConfig = parseEnvConfig (const Nothing)++-- | Read the configuration from the real process environment. A thin wrapper+-- over 'parseEnvConfig': it snapshots the environment once and looks each+-- variable up in it.+readEnvConfig :: IO EnvConfig+readEnvConfig = do+  entries <- getEnvironment+  let look name = T.pack <$> lookup (T.unpack name) entries+  pure (parseEnvConfig look)++-- | Build an 'EnvConfig' from a variable-lookup function. The function returns+-- the raw value for a variable name, or 'Nothing' when it is unset. Pure, so the+-- whole parse is testable by passing a stub lookup.+parseEnvConfig :: (Text -> Maybe Text) -> EnvConfig+parseEnvConfig look =+  EnvConfig+    { serviceName = parseServiceName look+    , resourceAttributes = parseResourceAttributes look+    , traceContextPropagators = traceContexts+    , baggagePropagators = baggages+    , tracesSampler = parseSampler look+    }+  where+    (traceContexts, baggages) = parsePropagators look++-- | Resolve the service name: @OTEL_SERVICE_NAME@ if set and non-empty,+-- otherwise the @service.name@ entry from @OTEL_RESOURCE_ATTRIBUTES@, otherwise+-- 'Nothing'.+parseServiceName :: (Text -> Maybe Text) -> Maybe Text+parseServiceName look =+  case nonEmpty =<< look "OTEL_SERVICE_NAME" of+    Just name -> Just name+    Nothing -> lookup "service.name" (resourcePairs look)+  where+    nonEmpty t = let s = T.strip t in if T.null s then Nothing else Just s++-- | Parse @OTEL_RESOURCE_ATTRIBUTES@ into typed attributes (string-valued, as+-- the wire format carries only strings). Absent or empty yields @[]@.+parseResourceAttributes :: (Text -> Maybe Text) -> [Attribute]+parseResourceAttributes look = [key .= value | (key, value) <- resourcePairs look]++-- | The raw @OTEL_RESOURCE_ATTRIBUTES@ key-value pairs. The variable uses the+-- W3C Baggage octet format (comma-separated @key=value@ with percent-encoded+-- values), so the resilient baggage parser reads it: malformed entries are+-- skipped and values are percent-decoded.+resourcePairs :: (Text -> Maybe Text) -> [(Text, Text)]+resourcePairs look =+  case look "OTEL_RESOURCE_ATTRIBUTES" of+    Nothing -> []+    Just raw -> [(key, baggageValue entry) | (key, entry) <- baggageToList (parseBaggage raw)]++-- | Parse @OTEL_PROPAGATORS@ into the trace-context and baggage propagator lists,+-- preserving order (which sets inject-and-extract priority). Unset defaults to+-- @tracecontext,baggage@; the special token @none@ disables all propagators;+-- unrecognised tokens are ignored. A token may contribute to both lists (e.g.+-- @jaeger@ has a trace-context and a baggage side).+parsePropagators+  :: (Text -> Maybe Text)+  -> ([TraceContextPropagator], [BaggagePropagator])+parsePropagators look =+  case fmap tokenize (look "OTEL_PROPAGATORS") of+    Nothing -> ([w3cTraceContext], [w3cBaggage])+    Just tokens+      | "none" `elem` tokens -> ([], [])+      | otherwise -> (mapMaybe traceContextByToken tokens, mapMaybe baggageByToken tokens)+  where+    tokenize = filter (not . T.null) . map (T.toLower . T.strip) . T.splitOn ","++-- | Parse @OTEL_TRACES_SAMPLER@ (and its @OTEL_TRACES_SAMPLER_ARG@ ratio for the+-- @traceidratio@ variants) into a 'Sampler'. An unset or unrecognised sampler+-- name degrades to the default, @parentbased_always_on@. The ratio defaults to+-- @1.0@ when the argument is absent or unparsable.+parseSampler :: (Text -> Maybe Text) -> Sampler+parseSampler look =+  case fmap (T.toLower . T.strip) (look "OTEL_TRACES_SAMPLER") of+    Just "always_on" -> alwaysOn+    Just "always_off" -> alwaysOff+    Just "traceidratio" -> traceIdRatioBased ratio+    Just "parentbased_always_on" -> parentBased (defaultParentBasedConfig alwaysOn)+    Just "parentbased_always_off" -> parentBased (defaultParentBasedConfig alwaysOff)+    Just "parentbased_traceidratio" -> parentBased (defaultParentBasedConfig (traceIdRatioBased ratio))+    _ -> parentBased (defaultParentBasedConfig alwaysOn)+  where+    ratio = maybe 1.0 (fromMaybe 1.0 . readMaybe . T.unpack . T.strip) (look "OTEL_TRACES_SAMPLER_ARG")
+ src/Effectful/Tracing/Instrumentation/Amqp.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.Instrumentation.Amqp+-- Description : Tracing wrappers for the amqp (RabbitMQ) client.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+-- Stability   : experimental+--+-- Drop-in replacements for the core @amqp@ publish and consume calls that run+-- each inside a span recording the stable OpenTelemetry messaging semantic+-- conventions (see "Effectful.Tracing.SemConv"). The wrappers live in @'Eff' es@+-- and delegate to "Effectful.Tracing.Instrumentation.Messaging", so the span is+-- named after the operation and destination and is finalized even if the call+-- throws.+--+-- The producer side ('publishMsgTraced') writes the active span's+-- <https://www.w3.org/TR/trace-context/ W3C Trace Context> into the message's+-- AMQP headers, and the consumer side ('withProcessSpan') reads it back, so a+-- trace continues across the broker without any manual header plumbing.+--+-- Import this module qualified alongside @Network.AMQP@:+--+-- > import Network.AMQP (Channel, Ack (Ack), newMsg, msgBody)+-- > import Effectful.Tracing.Instrumentation.Amqp qualified as Amqp+-- >+-- > -- producer: publish a message, attaching the trace context to its headers+-- > placeOrder :: (IOE :> es, Tracer :> es) => Channel -> Eff es ()+-- > placeOrder chan = do+-- >   _ <- Amqp.publishMsgTraced chan "orders" "orders.created" newMsg {msgBody = body}+-- >   pure ()+-- >+-- > -- consumer: poll for a message, then process it under the producer's trace+-- > handleOrder :: (IOE :> es, Tracer :> es) => Channel -> Eff es ()+-- > handleOrder chan = do+-- >   received <- Amqp.getMsgTraced chan Ack "orders"+-- >   case received of+-- >     Nothing -> pure ()+-- >     Just (msg, env) -> Amqp.withProcessSpan msg env (process (msgBody msg))+--+-- The @messaging.destination.name@ is the exchange the call targets, falling+-- back to the routing key for the default (empty) exchange, since that is the+-- queue name. RabbitMQ does not expose a portable message size before send, so+-- @messaging.message.body.size@ is taken from the body you hand it.+module Effectful.Tracing.Instrumentation.Amqp+  ( -- * Producing+    publishMsgTraced++    -- * Consuming+  , getMsgTraced+  , withProcessSpan++    -- * Reading headers+  , messageHeaders+  ) where++import Control.Monad.IO.Class (liftIO)+import Data.ByteString.Lazy qualified as BL+import Data.Map.Strict qualified as Map+import Data.Maybe (mapMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding (decodeUtf8Lenient, encodeUtf8)+import GHC.Stack (HasCallStack)++import Network.AMQP+  ( Ack+  , Channel+  , Envelope (envExchangeName, envRoutingKey)+  , Message (msgBody, msgCorrelationID, msgHeaders, msgID)+  , getMsg+  , publishMsg+  )+import Network.AMQP.Types (FieldTable (FieldTable), FieldValue (FVString))++import Effectful (Eff, IOE, (:>))+import Effectful.Tracing (Tracer)+import Effectful.Tracing.Instrumentation.Messaging+  ( MessagingOperation+      ( messagingBodySize+      , messagingConversationId+      , messagingDestination+      , messagingMessageId+      )+  , MessagingOperationType (Process, Receive, Send)+  , injectMessageHeaders+  , messagingOperation+  , withConsumerSpan+  , withMessagingSpan+  )++-- | 'Network.AMQP.publishMsg' wrapped in a traced @producer@-kind span. The+-- active span's trace context is merged into the message's headers before it is+-- sent, so a consumer using 'withProcessSpan' continues this trace.+publishMsgTraced+  :: (HasCallStack, IOE :> es, Tracer :> es)+  => Channel+  -> Text+  -- ^ Exchange.+  -> Text+  -- ^ Routing key.+  -> Message+  -> Eff es (Maybe Int)+publishMsgTraced chan exchange routingKey msg =+  withMessagingSpan (describePublish exchange routingKey msg) $ do+    headers <- injectMessageHeaders+    liftIO (publishMsg chan exchange routingKey (setTraceHeaders headers msg))++-- | 'Network.AMQP.getMsg' wrapped in a traced @consumer@-kind span for the+-- @receive@ operation. This traces the act of fetching from the queue; to also+-- trace processing under the producer's trace, pass the result to+-- 'withProcessSpan'.+getMsgTraced+  :: (HasCallStack, IOE :> es, Tracer :> es)+  => Channel+  -> Ack+  -> Text+  -- ^ Queue.+  -> Eff es (Maybe (Message, Envelope))+getMsgTraced chan ack queue =+  withMessagingSpan (describeReceive queue) (liftIO (getMsg chan ack queue))++-- | Process a received message inside a traced @consumer@-kind span for the+-- @process@ operation. The message's trace-context headers are read with+-- 'messageHeaders', so the span continues the producer's trace when they are+-- present and opens a new local root otherwise. Use this around the body of a+-- 'Network.AMQP.consumeMsgs' callback or a 'getMsgTraced' result.+withProcessSpan+  :: (HasCallStack, Tracer :> es)+  => Message+  -> Envelope+  -> Eff es a+  -> Eff es a+withProcessSpan msg env =+  withConsumerSpan (messageHeaders msg) (describeProcess msg env)++-- | The text headers carried on a message, as @key\/value@ pairs. Only+-- string-valued AMQP headers are returned (trace-context headers are always+-- strings); other field types are dropped. This is the input+-- 'withProcessSpan' uses to continue the producer's trace.+messageHeaders :: Message -> [(Text, Text)]+messageHeaders msg =+  case msgHeaders msg of+    Nothing -> []+    Just (FieldTable table) -> mapMaybe textHeader (Map.toList table)+  where+    textHeader (name, FVString bytes) = Just (name, decodeUtf8Lenient bytes)+    textHeader _ = Nothing++-- | Merge trace-context headers into a message, overwriting any existing+-- entries with the same keys and preserving the rest.+setTraceHeaders :: [(Text, Text)] -> Message -> Message+setTraceHeaders [] msg = msg+setTraceHeaders headers msg =+  msg {msgHeaders = Just (FieldTable (foldr insertHeader existing headers))}+  where+    existing = case msgHeaders msg of+      Just (FieldTable table) -> table+      Nothing -> Map.empty+    insertHeader (name, value) = Map.insert name (FVString (encodeUtf8 value))++-- | Describe a publish: system @\"rabbitmq\"@, a @send@ operation, the+-- destination, and the message id, correlation id, and body size when present.+describePublish :: Text -> Text -> Message -> MessagingOperation+describePublish exchange routingKey msg =+  (messagingOperation "rabbitmq" Send)+    { messagingDestination = Just (publishDestination exchange routingKey)+    , messagingMessageId = msgID msg+    , messagingConversationId = msgCorrelationID msg+    , messagingBodySize = Just (bodySize msg)+    }++-- | Describe a poll: system @\"rabbitmq\"@, a @receive@ operation, and the queue+-- as the destination.+describeReceive :: Text -> MessagingOperation+describeReceive queue =+  (messagingOperation "rabbitmq" Receive) {messagingDestination = Just queue}++-- | Describe processing a delivered message: system @\"rabbitmq\"@, a @process@+-- operation, the destination from the delivery envelope, and the message id,+-- correlation id, and body size when present.+describeProcess :: Message -> Envelope -> MessagingOperation+describeProcess msg env =+  (messagingOperation "rabbitmq" Process)+    { messagingDestination = Just (envDestination env)+    , messagingMessageId = msgID msg+    , messagingConversationId = msgCorrelationID msg+    , messagingBodySize = Just (bodySize msg)+    }++-- | The destination name for a publish: the exchange, or the routing key when+-- the exchange is empty (the default exchange routes directly to the queue).+publishDestination :: Text -> Text -> Text+publishDestination exchange routingKey+  | T.null exchange = routingKey+  | otherwise = exchange++-- | The destination name from a delivery envelope, by the same rule as+-- 'publishDestination'.+envDestination :: Envelope -> Text+envDestination env+  | T.null (envExchangeName env) = envRoutingKey env+  | otherwise = envExchangeName env++-- | The message body size in bytes.+bodySize :: Message -> Int+bodySize = fromIntegral . BL.length . msgBody
+ src/Effectful/Tracing/Instrumentation/Database.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.Instrumentation.Database+-- Description : Framework-agnostic helpers for tracing database client calls.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+-- Stability   : experimental+--+-- A small, dependency-free core for wrapping a database call in a @client@-kind+-- span that records the stable OpenTelemetry database semantic conventions (see+-- "Effectful.Tracing.SemConv"). It knows nothing about any particular driver:+-- you describe the call with a 'DatabaseQuery' and run the action inside+-- 'withQuerySpan'. The driver-specific module+-- "Effectful.Tracing.Instrumentation.PostgresqlSimple" (built with the+-- @postgresql-simple@ flag) is a thin layer on top of this.+--+-- > runUsers :: (IOE :> es, Tracer :> es) => Connection -> Eff es [User]+-- > runUsers conn =+-- >   withQuerySpan+-- >     (databaseQuery "postgresql")+-- >       { queryText = Just "SELECT id, name FROM users WHERE active = $1"+-- >       , queryOperation = Just "SELECT"+-- >       , queryCollection = Just "users"+-- >       }+-- >     (liftIO (query conn "SELECT id, name FROM users WHERE active = ?" (Only True)))+--+-- The span is named following the convention @{operation} {collection}@ (for+-- example @\"SELECT users\"@), falling back to the operation alone, then to the+-- system name, so the name stays low cardinality. Record the /parameterized/+-- statement in 'queryText' (placeholders, not interpolated values) to avoid+-- leaking row data; 'inferOperationName' can pull the leading command keyword+-- out of such a statement when the driver does not give you one directly.+module Effectful.Tracing.Instrumentation.Database+  ( -- * Describing a query+    DatabaseQuery (..)+  , databaseQuery++    -- * Tracing a query+  , withQuerySpan++    -- * Helpers+  , inferOperationName+  , querySpanName+  , queryAttributes+  ) where++import Data.Char (isSpace)+import Data.Maybe (mapMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import GHC.Stack (HasCallStack)++import Effectful (Eff, (:>))++import Effectful.Tracing+  ( SpanArguments (attributes, kind)+  , SpanKind (Client)+  , Tracer+  , defaultSpanArguments+  , withSpan'+  , (.=)+  )+import Effectful.Tracing.Attribute (Attribute)+import Effectful.Tracing.SemConv qualified as SemConv++-- | A driver-agnostic description of a database call, used to populate the+-- @db.*@ attributes (see "Effectful.Tracing.SemConv") and the span name. Build+-- it with 'databaseQuery' and fill in the fields you know; every optional field+-- left as 'Nothing' is simply not recorded.+data DatabaseQuery = DatabaseQuery+  { querySystem :: !Text+  -- ^ @db.system.name@: the DBMS, for example @\"postgresql\"@. Required.+  , queryText :: !(Maybe Text)+  -- ^ @db.query.text@: the /parameterized/ statement (placeholders, not+  -- interpolated values), for example @\"SELECT * FROM users WHERE id = $1\"@.+  , queryOperation :: !(Maybe Text)+  -- ^ @db.operation.name@: the low-cardinality command keyword, for example+  -- @\"SELECT\"@. 'inferOperationName' can derive this from 'queryText'.+  , queryCollection :: !(Maybe Text)+  -- ^ @db.collection.name@: the primary table the call acts on, for example+  -- @\"users\"@.+  , queryNamespace :: !(Maybe Text)+  -- ^ @db.namespace@: the logical database the connection is scoped to.+  }+  deriving (Eq, Show)++-- | A 'DatabaseQuery' for the given @db.system.name@ with every optional field+-- unset, ready for record-update syntax to fill in what you know.+--+-- > (databaseQuery "postgresql") { queryOperation = Just "INSERT", queryCollection = Just "orders" }+databaseQuery :: Text -> DatabaseQuery+databaseQuery system =+  DatabaseQuery+    { querySystem = system+    , queryText = Nothing+    , queryOperation = Nothing+    , queryCollection = Nothing+    , queryNamespace = Nothing+    }++-- | Run a database action inside a @client@-kind span named by 'querySpanName'+-- and annotated with 'queryAttributes'. The span is finalized (with its end+-- time, and 'Effectful.Tracing.Error' status if the action throws) by the+-- shared span lifecycle when the action returns or unwinds.+withQuerySpan+  :: (HasCallStack, Tracer :> es)+  => DatabaseQuery+  -> Eff es a+  -> Eff es a+withQuerySpan q =+  withSpan'+    (querySpanName q)+    defaultSpanArguments+      { kind = Client+      , attributes = queryAttributes q+      }++-- | The span name for a query, following the OpenTelemetry convention: prefer+-- @{operation} {collection}@ (for example @\"SELECT users\"@), fall back to the+-- operation alone, then to the @db.system.name@ when neither is known. This+-- keeps the name low cardinality (never the full statement).+querySpanName :: DatabaseQuery -> Text+querySpanName q =+  case (queryOperation q, queryCollection q) of+    (Just op, Just coll) -> op <> " " <> coll+    (Just op, Nothing) -> op+    (Nothing, _) -> querySystem q++-- | The @db.*@ attributes for a query: @db.system.name@ always, plus+-- @db.query.text@, @db.operation.name@, @db.collection.name@, and+-- @db.namespace@ for whichever optional fields are set.+queryAttributes :: DatabaseQuery -> [Attribute]+queryAttributes q =+  (SemConv.dbSystemName .= querySystem q)+    : mapMaybe+      optional+      [ (SemConv.dbQueryText, queryText q)+      , (SemConv.dbOperationName, queryOperation q)+      , (SemConv.dbCollectionName, queryCollection q)+      , (SemConv.dbNamespace, queryNamespace q)+      ]+  where+    optional (key, value) = (key .=) <$> value++-- | Pull the low-cardinality operation name out of a statement: the leading+-- word, upper-cased, for example @\"SELECT\"@ from+-- @\"select * from users\"@. Returns 'Nothing' for a blank statement. This is a+-- best-effort heuristic for drivers that do not hand you the operation+-- directly; it does not parse SQL.+inferOperationName :: Text -> Maybe Text+inferOperationName statement =+  case T.words (T.dropWhile isSpace statement) of+    [] -> Nothing+    (w : _) -> Just (T.toUpper w)
+ src/Effectful/Tracing/Instrumentation/HttpClient.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.Instrumentation.HttpClient+-- Description : Tracing wrappers for http-client requests.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+-- Stability   : experimental+--+-- Wrap an @http-client@ request so it runs inside a @client@-kind span that+-- injects @traceparent@ \/ @tracestate@ into the outbound request (so the next+-- hop continues the trace), records the request and response following the+-- stable OpenTelemetry HTTP semantic conventions (see+-- "Effectful.Tracing.SemConv"), and is finalized even if the request throws.+--+-- > fetch :: (IOE :> es, Tracer :> es) => Manager -> Eff es (Response ByteString)+-- > fetch manager = do+-- >   req <- liftIO (parseRequest "https://example.com/widgets")+-- >   httpLbsTraced req manager+--+-- The API stays in @'Eff' es@ (unlike the WAI middleware, which must take an+-- unlift because WAI is an 'IO' type) because span management needs the effect+-- context and the request is driven from inside it. The optional manager-hook+-- approach is intentionally not provided: @'Manager'@'s @managerModifyRequest@+-- runs in 'IO' with no effect context, so it cannot carry the active span+-- without capturing an unlift at manager-construction time, and the request+-- wrapper here covers the need without that complication.+module Effectful.Tracing.Instrumentation.HttpClient+  ( httpLbsTraced+  ) where++import Control.Monad (when)+import Control.Monad.IO.Class (liftIO)+import Data.ByteString (ByteString)+import Data.ByteString.Lazy qualified as LBS+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding (decodeUtf8Lenient)++import Network.HTTP.Client+  ( Manager+  , Request (requestHeaders)+  , Response (responseStatus)+  , getUri+  , httpLbs+  , method+  )+import Network.HTTP.Types (statusCode)+import Network.HTTP.Types.Header (HeaderName)++import Effectful (Eff, IOE, (:>))++import Effectful.Tracing+  ( SpanArguments (attributes, kind)+  , SpanKind (Client)+  , SpanStatus (Error)+  , Tracer+  , addAttribute+  , defaultSpanArguments+  , injectContext+  , setStatus+  , traceparentHeader+  , tracestateHeader+  , withSpan'+  , (.=)+  )+import Effectful.Tracing.Attribute (Attribute)+import Effectful.Tracing.SemConv qualified as SemConv++-- | Perform an @http-client@ request (via 'httpLbs') inside a @client@-kind+-- span. The span is named after the HTTP method (low cardinality), the active+-- context is injected into the outbound request as @traceparent@ \/ @tracestate@+-- so the downstream service continues this trace, and the request and response+-- are recorded following the stable OpenTelemetry HTTP semantic conventions (see+-- "Effectful.Tracing.SemConv"). A response status @>= 400@ sets the span status to+-- 'Error' (from the client's view the call failed); a thrown exception is+-- recorded by the shared span lifecycle and re-raised.+httpLbsTraced+  :: (IOE :> es, Tracer :> es)+  => Request+  -> Manager+  -> Eff es (Response LBS.ByteString)+httpLbsTraced req manager =+  withSpan' (decodeUtf8Lenient (method req)) clientArgs $ do+    -- Inside the span, inject the active (client) span's context, then send.+    headers <- injectContext+    response <- liftIO (httpLbs (injectHeaders headers req) manager)+    let status = statusCode (responseStatus response)+    addAttribute SemConv.httpResponseStatusCode status+    when (status >= 400) $+      setStatus (Error ("HTTP " <> T.pack (show status)))+    pure response+  where+    clientArgs =+      defaultSpanArguments+        { kind = Client+        , attributes = requestAttributes req+        }++-- | The request attributes recorded at span start, following the stable HTTP+-- and URL semantic conventions (see "Effectful.Tracing.SemConv").+requestAttributes :: Request -> [Attribute]+requestAttributes req =+  [ SemConv.httpRequestMethod .= decodeUtf8Lenient (method req)+  , SemConv.urlFull .= urlText req+  ]++-- | The full request URL, as the @url.full@ attribute.+urlText :: Request -> Text+urlText = T.pack . show . getUri++-- | Replace any existing @traceparent@ \/ @tracestate@ on the request with the+-- freshly-injected ones, leaving all other headers untouched.+injectHeaders :: [(HeaderName, ByteString)] -> Request -> Request+injectHeaders injected req =+  req {requestHeaders = injected <> filter (not . isTraceHeader . fst) (requestHeaders req)}+  where+    isTraceHeader h = h == traceparentHeader || h == tracestateHeader
+ src/Effectful/Tracing/Instrumentation/Messaging.hs view
@@ -0,0 +1,285 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.Instrumentation.Messaging+-- Description : Framework-agnostic helpers for tracing message producers and consumers.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+-- Stability   : experimental+--+-- A small, dependency-free core for wrapping a publish or consume in a span that+-- records the stable OpenTelemetry messaging semantic conventions (see+-- "Effectful.Tracing.SemConv"). It knows nothing about any particular broker:+-- you describe the call with a 'MessagingOperation' and run the action inside+-- 'withMessagingSpan'. The operation type ('MessagingOperationType') selects the+-- span kind, so @send@ \/ @create@ become @producer@ spans and @receive@ \/+-- @process@ become @consumer@ spans, matching the OpenTelemetry model.+--+-- Distributed traces cross a broker by carrying the+-- <https://www.w3.org/TR/trace-context/ W3C Trace Context> in message headers:+-- the producer attaches the headers from 'injectMessageHeaders', and the+-- consumer hands the received headers to 'withConsumerSpan' (or extracts them+-- with 'extractMessageHeaders') so its span continues the producer's trace. The+-- headers are plain text key\/value pairs, the portable shape across Kafka,+-- RabbitMQ, SQS, and the like.+--+-- > -- producer: open a send span and attach the trace context to the message+-- > publishOrder :: (IOE :> es, Tracer :> es) => Order -> Eff es ()+-- > publishOrder order =+-- >   withMessagingSpan (messagingOperation "kafka" Send) { messagingDestination = Just "orders" } $ do+-- >     headers <- injectMessageHeaders+-- >     liftIO (produce "orders" headers (encode order))+-- >+-- > -- consumer: continue the producer's trace under a process span+-- > handleOrder :: (IOE :> es, Tracer :> es) => Message -> Eff es ()+-- > handleOrder msg =+-- >   withConsumerSpan+-- >     (messageHeaders msg)+-- >     (messagingOperation "kafka" Process) { messagingDestination = Just "orders" }+-- >     (liftIO (process (messageBody msg)))+--+-- The span is named following the convention @{operation} {destination}@ (for+-- example @\"send orders\"@), preferring 'messagingOperationName' then the+-- operation type for the leading word, and 'messagingDestinationTemplate' then+-- 'messagingDestination' for the trailing word, so the name stays low+-- cardinality.+module Effectful.Tracing.Instrumentation.Messaging+  ( -- * Describing an operation+    MessagingOperation (..)+  , MessagingOperationType (..)+  , messagingOperation++    -- * Tracing an operation+  , withMessagingSpan+  , withConsumerSpan++    -- * Propagating context through message headers+  , injectMessageHeaders+  , extractMessageHeaders++    -- * Helpers+  , messagingSpanName+  , messagingSpanKind+  , messagingAttributes+  , operationTypeText+  ) where++import Control.Applicative ((<|>))+import Data.CaseInsensitive qualified as CI+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8Lenient, encodeUtf8)+import GHC.Stack (HasCallStack)++import Effectful (Eff, (:>))++import Effectful.Tracing+  ( SpanArguments (attributes, kind)+  , SpanContext+  , SpanKind (Client, Consumer, Producer)+  , Tracer+  , defaultSpanArguments+  , extractContext+  , injectContext+  , withRemoteParent+  , withSpan'+  , (.=)+  )+import Effectful.Tracing.Attribute (Attribute)+import Effectful.Tracing.SemConv qualified as SemConv++-- | The kind of messaging operation, following the OpenTelemetry+-- @messaging.operation.type@ values. The constructor both fills that attribute+-- (see 'operationTypeText') and selects the span kind (see 'messagingSpanKind').+data MessagingOperationType+  = -- | A message is created but not yet sent (a @producer@ span).+    Create+  | -- | One or more messages are handed to the broker (a @producer@ span). This+    -- covers what some systems call \"publish\".+    Send+  | -- | One or more messages are requested from the broker (a @consumer@ span).+    Receive+  | -- | One or more received messages are processed (a @consumer@ span).+    Process+  | -- | One or more messages are settled, for example acknowledged or rejected+    -- (a @client@ span).+    Settle+  deriving (Eq, Show)++-- | A broker-agnostic description of a messaging call, used to populate the+-- @messaging.*@ attributes (see "Effectful.Tracing.SemConv") and the span name.+-- Build it with 'messagingOperation' and fill in the fields you know; every+-- optional field left as 'Nothing' is simply not recorded.+data MessagingOperation = MessagingOperation+  { messagingSystem :: !Text+  -- ^ @messaging.system@: the messaging system, for example @\"kafka\"@.+  -- Required.+  , messagingOperationType :: !MessagingOperationType+  -- ^ @messaging.operation.type@: the operation category, which also selects the+  -- span kind. Required.+  , messagingOperationName :: !(Maybe Text)+  -- ^ @messaging.operation.name@: the system-specific operation name, for+  -- example @\"publish\"@ or @\"ack\"@. Used as the leading word of the span+  -- name; falls back to the operation type when unset.+  , messagingDestination :: !(Maybe Text)+  -- ^ @messaging.destination.name@: the destination the call acts on, for+  -- example a topic or queue name.+  , messagingDestinationTemplate :: !(Maybe Text)+  -- ^ @messaging.destination.template@: a low-cardinality template the+  -- destination is derived from. Preferred over 'messagingDestination' in the+  -- span name when destinations are dynamic.+  , messagingMessageId :: !(Maybe Text)+  -- ^ @messaging.message.id@: the broker-assigned identifier of a single+  -- message.+  , messagingConversationId :: !(Maybe Text)+  -- ^ @messaging.message.conversation_id@: the conversation \/ correlation+  -- identifier tying related messages together.+  , messagingBodySize :: !(Maybe Int)+  -- ^ @messaging.message.body.size@: the size of the message body in bytes.+  , messagingBatchCount :: !(Maybe Int)+  -- ^ @messaging.batch.message_count@: the number of messages in a batch+  -- operation.+  }+  deriving (Eq, Show)++-- | A 't:MessagingOperation' for the given @messaging.system@ and operation+-- type with every optional field unset, ready for record-update syntax to fill+-- in what you know.+--+-- > (messagingOperation "rabbitmq" Send) { messagingDestination = Just "orders" }+messagingOperation :: Text -> MessagingOperationType -> MessagingOperation+messagingOperation system operationType =+  MessagingOperation+    { messagingSystem = system+    , messagingOperationType = operationType+    , messagingOperationName = Nothing+    , messagingDestination = Nothing+    , messagingDestinationTemplate = Nothing+    , messagingMessageId = Nothing+    , messagingConversationId = Nothing+    , messagingBodySize = Nothing+    , messagingBatchCount = Nothing+    }++-- | Run a messaging action inside a span named by 'messagingSpanName', of the+-- kind 'messagingSpanKind' picks for the operation type, and annotated with+-- 'messagingAttributes'. The span is finalized (with its end time, and+-- 'Effectful.Tracing.Error' status if the action throws) by the shared span+-- lifecycle when the action returns or unwinds.+--+-- This opens a fresh span as a child of the current one. On the consumer side,+-- use 'withConsumerSpan' instead to continue the producer's remote trace.+withMessagingSpan+  :: (HasCallStack, Tracer :> es)+  => MessagingOperation+  -> Eff es a+  -> Eff es a+withMessagingSpan op =+  withSpan'+    (messagingSpanName op)+    defaultSpanArguments+      { kind = messagingSpanKind (messagingOperationType op)+      , attributes = messagingAttributes op+      }++-- | Run a consumer action inside a 'withMessagingSpan' that continues the+-- producer's trace. The given message headers are parsed with+-- 'extractMessageHeaders'; when they carry a valid context the span becomes a+-- child of that remote parent (via 'Effectful.Tracing.withRemoteParent'),+-- otherwise it opens a new local root. Pass a @receive@ or @process@ operation.+withConsumerSpan+  :: (HasCallStack, Tracer :> es)+  => [(Text, Text)]+  -- ^ Headers from the received message.+  -> MessagingOperation+  -> Eff es a+  -> Eff es a+withConsumerSpan headers op action =+  case extractMessageHeaders headers of+    Just parent -> withRemoteParent parent (withMessagingSpan op action)+    Nothing -> withMessagingSpan op action++-- | Serialize the active span's context as message headers for an outbound+-- message, as plain text @traceparent@ (and @tracestate@, if non-empty)+-- key\/value pairs. Attach these to the message you publish so the consumer can+-- continue the trace. Returns @[]@ when there is no active span, so it composes+-- with a base header list unconditionally.+injectMessageHeaders :: (Tracer :> es) => Eff es [(Text, Text)]+injectMessageHeaders = map toTextHeader <$> injectContext+  where+    toTextHeader (name, value) =+      (decodeUtf8Lenient (CI.original name), decodeUtf8Lenient value)++-- | Parse the trace context out of a received message's headers into a remote+-- 't:SpanContext', the consumer-side counterpart of 'injectMessageHeaders'.+-- Returns 'Nothing' when no valid @traceparent@ is present. Pair with+-- 'Effectful.Tracing.withRemoteParent', or use 'withConsumerSpan', which does+-- both. Header lookup is case-insensitive.+extractMessageHeaders :: [(Text, Text)] -> Maybe SpanContext+extractMessageHeaders = extractContext . map fromTextHeader+  where+    fromTextHeader (name, value) = (CI.mk (encodeUtf8 name), encodeUtf8 value)++-- | The span name for a messaging operation, following the OpenTelemetry+-- convention: @{operation} {destination}@ (for example @\"send orders\"@). The+-- leading word prefers 'messagingOperationName', falling back to the operation+-- type; the trailing word prefers 'messagingDestinationTemplate', then+-- 'messagingDestination', and is omitted when neither is set. This keeps the+-- name low cardinality.+messagingSpanName :: MessagingOperation -> Text+messagingSpanName op =+  case messagingDestinationTemplate op <|> messagingDestination op of+    Just destination -> label <> " " <> destination+    Nothing -> label+  where+    label = fromMaybe (operationTypeText (messagingOperationType op)) (messagingOperationName op)++-- | The span kind for an operation type: @producer@ for 'Create' and 'Send',+-- @consumer@ for 'Receive' and 'Process', and @client@ for 'Settle'.+messagingSpanKind :: MessagingOperationType -> SpanKind+messagingSpanKind = \case+  Create -> Producer+  Send -> Producer+  Receive -> Consumer+  Process -> Consumer+  Settle -> Client++-- | The @messaging.operation.type@ value for an operation type: the lowercase+-- name, for example @\"send\"@ for 'Send'.+operationTypeText :: MessagingOperationType -> Text+operationTypeText = \case+  Create -> "create"+  Send -> "send"+  Receive -> "receive"+  Process -> "process"+  Settle -> "settle"++-- | The @messaging.*@ attributes for an operation: @messaging.system@ and+-- @messaging.operation.type@ always, plus @messaging.operation.name@,+-- @messaging.destination.name@, @messaging.destination.template@,+-- @messaging.message.id@, @messaging.message.conversation_id@,+-- @messaging.message.body.size@, and @messaging.batch.message_count@ for+-- whichever optional fields are set.+messagingAttributes :: MessagingOperation -> [Attribute]+messagingAttributes op =+  [ SemConv.messagingSystem .= messagingSystem op+  , SemConv.messagingOperationType .= operationTypeText (messagingOperationType op)+  ]+    <> mapMaybe+      optionalText+      [ (SemConv.messagingOperationName, messagingOperationName op)+      , (SemConv.messagingDestinationName, messagingDestination op)+      , (SemConv.messagingDestinationTemplate, messagingDestinationTemplate op)+      , (SemConv.messagingMessageId, messagingMessageId op)+      , (SemConv.messagingMessageConversationId, messagingConversationId op)+      ]+    <> mapMaybe+      optionalInt+      [ (SemConv.messagingMessageBodySize, messagingBodySize op)+      , (SemConv.messagingBatchMessageCount, messagingBatchCount op)+      ]+  where+    optionalText (key, value) = (key .=) <$> value+    optionalInt (key, value) = (key .=) <$> value
+ src/Effectful/Tracing/Instrumentation/PostgresqlSimple.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.Instrumentation.PostgresqlSimple+-- Description : Tracing wrappers for postgresql-simple queries.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+-- Stability   : experimental+--+-- Drop-in replacements for the four core @postgresql-simple@ statement runners+-- (@query@, @query_@, @execute@, @execute_@) that run each call inside a+-- @client@-kind span recording the stable OpenTelemetry database semantic+-- conventions (see "Effectful.Tracing.SemConv"). The wrappers live in @'Eff' es@+-- and delegate to "Effectful.Tracing.Instrumentation.Database", so the span is+-- named after the statement's operation and finalized even if the query throws.+--+-- Import this module qualified alongside @postgresql-simple@ so the traced+-- runners shadow the originals at the call site:+--+-- > import Database.PostgreSQL.Simple (Connection, Only (..))+-- > import Effectful.Tracing.Instrumentation.PostgresqlSimple qualified as Pg+-- >+-- > activeUsers :: (IOE :> es, Tracer :> es) => Connection -> Eff es [(Int, Text)]+-- > activeUsers conn =+-- >   Pg.query conn "SELECT id, name FROM users WHERE active = ?" (Only True)+--+-- The recorded @db.query.text@ is the statement /template/ (with @?@+-- placeholders), not the interpolated SQL, so parameter values never reach the+-- span. The @db.operation.name@ is inferred from the leading keyword of that+-- template (see 'inferOperationName'); set @db.collection.name@ \/+-- @db.namespace@ yourself with "Effectful.Tracing.addAttribute" inside the call+-- if you want them, since they cannot be derived reliably without parsing SQL.+module Effectful.Tracing.Instrumentation.PostgresqlSimple+  ( query+  , query_+  , execute+  , execute_+  ) where++import Control.Monad.IO.Class (liftIO)+import Data.Int (Int64)+import Data.Text.Encoding (decodeUtf8Lenient)+import GHC.Stack (HasCallStack)++import Database.PostgreSQL.Simple (Connection, FromRow, Query, ToRow)+import Database.PostgreSQL.Simple qualified as Pg+import Database.PostgreSQL.Simple.Types (fromQuery)++import Effectful (Eff, IOE, (:>))+import Effectful.Tracing (Tracer)+import Effectful.Tracing.Instrumentation.Database+  ( DatabaseQuery (queryOperation, queryText)+  , databaseQuery+  , inferOperationName+  , withQuerySpan+  )++-- | 'Database.PostgreSQL.Simple.query' wrapped in a traced @client@-kind span.+query+  :: (HasCallStack, IOE :> es, Tracer :> es, ToRow q, FromRow r)+  => Connection+  -> Query+  -> q+  -> Eff es [r]+query conn template params =+  withQuerySpan (describe template) (liftIO (Pg.query conn template params))++-- | 'Database.PostgreSQL.Simple.query_' wrapped in a traced @client@-kind span.+query_+  :: (HasCallStack, IOE :> es, Tracer :> es, FromRow r)+  => Connection+  -> Query+  -> Eff es [r]+query_ conn template =+  withQuerySpan (describe template) (liftIO (Pg.query_ conn template))++-- | 'Database.PostgreSQL.Simple.execute' wrapped in a traced @client@-kind span.+execute+  :: (HasCallStack, IOE :> es, Tracer :> es, ToRow q)+  => Connection+  -> Query+  -> q+  -> Eff es Int64+execute conn template params =+  withQuerySpan (describe template) (liftIO (Pg.execute conn template params))++-- | 'Database.PostgreSQL.Simple.execute_' wrapped in a traced @client@-kind span.+execute_+  :: (HasCallStack, IOE :> es, Tracer :> es)+  => Connection+  -> Query+  -> Eff es Int64+execute_ conn template =+  withQuerySpan (describe template) (liftIO (Pg.execute_ conn template))++-- | Build the query description from a @postgresql-simple@ 'Query' template:+-- system @\"postgresql\"@, @db.query.text@ from the template, and+-- @db.operation.name@ inferred from its leading keyword.+describe :: Query -> DatabaseQuery+describe template =+  (databaseQuery "postgresql")+    { queryText = Just statement+    , queryOperation = inferOperationName statement+    }+  where+    statement = decodeUtf8Lenient (fromQuery template)
+ src/Effectful/Tracing/Instrumentation/Servant.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- |+-- Module      : Effectful.Tracing.Instrumentation.Servant+-- Description : Route-aware tracing for Servant servers.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+-- Stability   : experimental+--+-- The WAI middleware in "Effectful.Tracing.Instrumentation.Wai" opens a+-- @server@-kind span /before/ the application runs, so it cannot name the span+-- after the matched route, which Servant only knows once routing has run. The+-- OpenTelemetry HTTP conventions ask for a low-cardinality server span named+-- @\"{method} {route}\"@ with the route template also recorded as+-- @http.route@. This module closes that gap.+--+-- Annotate each endpoint with the 'WithSpanName' combinator, giving the route+-- template (without the method) as a type-level string:+--+-- > type API =+-- >        WithSpanName "/users/{id}" :> "users" :> Capture "id" Int :> Get '[JSON] User+-- >   :<|> WithSpanName "/users"      :> "users" :> ReqBody '[JSON] NewUser :> Post '[JSON] User+--+-- The combinator is transparent to handlers (it does not change @ServerT@), so+-- the server value is written exactly as it would be without it. When the router+-- selects an endpoint, the combinator records its template; 'traceServantMiddleware'+-- then renames the open server span to @\"{method} {route}\"@ and sets+-- @http.route@ once the application returns.+--+-- Use 'traceServantMiddleware' in place of+-- 'Effectful.Tracing.Instrumentation.Wai.traceMiddleware'; it does everything that+-- middleware does (continues an inbound trace, records the request and response+-- following the stable HTTP semantic conventions, marks 5xx as an error) and adds+-- the route naming. Like the WAI middleware it takes an unlift @forall a. 'Eff' es a -> 'IO' a@+-- that must tolerate concurrent calls:+--+-- > import Effectful+-- > import Servant (serve)+-- >+-- > server :: (IOE :> es, Tracer :> es) => Eff es ()+-- > server = withEffToIO (ConcUnlift Persistent Unlimited) $ \runInIO ->+-- >   Warp.run 8080 (traceServantMiddleware runInIO (serve (Proxy @API) handlers))+--+-- An endpoint with no 'WithSpanName' is still traced; its span keeps the default+-- name (the request method) and carries no @http.route@.+module Effectful.Tracing.Instrumentation.Servant+  ( -- * Route-naming combinator+    WithSpanName++    -- * Middleware+  , traceServantMiddleware+  ) where++import Control.Monad (when)+import Control.Monad.IO.Class (liftIO)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Proxy (Proxy (Proxy))+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding (decodeUtf8Lenient)+import Data.Vault.Lazy qualified as Vault+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)+import System.IO.Unsafe (unsafePerformIO)++import Network.HTTP.Types (Status (statusCode, statusMessage))+import Network.Wai (Middleware, requestHeaders, requestMethod, responseStatus, vault)++import Servant.API (type (:>))+import Servant.Server (HasServer (hoistServerWithContext, route), ServerT)+import Servant.Server.Internal.Delayed (addMethodCheck)+import Servant.Server.Internal.DelayedIO (withRequest)++import Effectful (Eff, IOE)+import Effectful qualified as E++import Effectful.Tracing+  ( SpanArguments (attributes, kind)+  , SpanKind (Server)+  , SpanStatus (Error)+  , Tracer+  , addAttribute+  , defaultSpanArguments+  , extractContext+  , setStatus+  , updateName+  , withRemoteParent+  , withSpan'+  )+import Effectful.Tracing.Instrumentation.Wai (requestAttributes)+import Effectful.Tracing.SemConv qualified as SemConv++-- | A phantom combinator that names the server span for the endpoint it+-- precedes. @name@ is the route template (without the HTTP method, which+-- 'traceServantMiddleware' prepends), and should be low-cardinality: use the+-- parameterized form @\"/users/{id}\"@, never the concrete path @\"/users/9921\"@.+-- It is transparent to the handler: @'ServerT' ('WithSpanName' name ':>' api) m@ is+-- just @'ServerT' api m@.+data WithSpanName (name :: Symbol)++-- | A request-scoped slot carrying the matched route template from the+-- 'WithSpanName' instance to 'traceServantMiddleware'. A 'Vault.Key' is the only+-- channel between them: the @'HasServer'@ instance cannot be handed an+-- 'IORef' directly, and the middleware seeds a fresh ref per request. Allocating+-- the key once at the top level is the established Servant\/WAI idiom for this.+routeKey :: Vault.Key (IORef (Maybe Text))+routeKey = unsafePerformIO Vault.newKey+{-# NOINLINE routeKey #-}++-- | The matched route is recorded during the method-check phase: by then the+-- path captures and HTTP method have matched, so the router has committed to this+-- endpoint, and a later failure (a 401, 406, or 400) still leaves the span named+-- after the route it was handling.+instance (HasServer api ctx, KnownSymbol name) => HasServer (WithSpanName name :> api) ctx where+  type ServerT (WithSpanName name :> api) m = ServerT api m++  route _ ctx delayed = route (Proxy :: Proxy api) ctx (addMethodCheck delayed recordRoute)+    where+      recordRoute = withRequest $ \req ->+        liftIO $ case Vault.lookup routeKey (vault req) of+          Just ref -> writeIORef ref (Just routeName)+          Nothing -> pure ()+      routeName = T.pack (symbolVal (Proxy :: Proxy name))++  hoistServerWithContext _ = hoistServerWithContext (Proxy :: Proxy api)++-- | Trace a Servant 'Network.Wai.Application', naming each server span after the+-- matched route. It opens a @server@-kind span (continuing an inbound trace when+-- the headers carry one), records the stable HTTP request and response+-- attributes, marks 5xx responses as an error, and, once the application has+-- routed to an endpoint annotated with 'WithSpanName', renames the span to+-- @\"{method} {route}\"@ and sets @http.route@.+--+-- The span starts named after the request method, so an unannotated endpoint (or+-- a request that never matches one) still produces a well-formed span; the route+-- naming only refines it.+traceServantMiddleware+  :: (IOE E.:> es, Tracer E.:> es)+  => (forall a. Eff es a -> IO a)+  -- ^ Run an @'Eff' es@ action in 'IO'. Must tolerate concurrent calls; see the+  -- module header.+  -> Middleware+traceServantMiddleware runInIO app req respond =+  runInIO (continueRemote (withSpan' method serverArgs body))+  where+    method = decodeUtf8Lenient (requestMethod req)++    continueRemote =+      maybe id withRemoteParent (extractContext (requestHeaders req))++    serverArgs =+      defaultSpanArguments+        { kind = Server+        , attributes = requestAttributes req+        }++    body = do+      routeRef <- liftIO (newIORef Nothing)+      statusRef <- liftIO (newIORef Nothing)+      let req' = req {vault = Vault.insert routeKey routeRef (vault req)}+          respond' response = do+            -- Project and force the status before storing it, so the ref does+            -- not retain the whole response (body included) until the span+            -- closes.+            let !status = responseStatus response+            writeIORef statusRef (Just status)+            respond response+      received <- liftIO (app req' respond')+      mRoute <- liftIO (readIORef routeRef)+      case mRoute of+        Nothing -> pure ()+        Just route' -> do+          updateName (method <> " " <> route')+          addAttribute SemConv.httpRoute route'+      mStatus <- liftIO (readIORef statusRef)+      case mStatus of+        Nothing -> pure ()+        Just status -> do+          addAttribute SemConv.httpResponseStatusCode (statusCode status)+          when (statusCode status >= 500) $+            setStatus (Error (decodeUtf8Lenient (statusMessage status)))+      pure received
+ src/Effectful/Tracing/Instrumentation/SqliteSimple.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.Instrumentation.SqliteSimple+-- Description : Tracing wrappers for sqlite-simple queries.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+-- Stability   : experimental+--+-- Drop-in replacements for the @sqlite-simple@ statement runners (@query@,+-- @query_@, @execute@, @execute_@, @executeMany@) that run each call inside a+-- @client@-kind span recording the stable OpenTelemetry database semantic+-- conventions (see "Effectful.Tracing.SemConv"). The wrappers live in @'Eff' es@+-- and delegate to "Effectful.Tracing.Instrumentation.Database", so the span is+-- named after the statement's operation and finalized even if the query throws.+--+-- Import this module qualified alongside @sqlite-simple@ so the traced runners+-- shadow the originals at the call site:+--+-- > import Database.SQLite.Simple (Connection, Only (..))+-- > import Effectful.Tracing.Instrumentation.SqliteSimple qualified as Sqlite+-- >+-- > activeUsers :: (IOE :> es, Tracer :> es) => Connection -> Eff es [(Int, Text)]+-- > activeUsers conn =+-- >   Sqlite.query conn "SELECT id, name FROM users WHERE active = ?" (Only True)+--+-- The recorded @db.query.text@ is the statement /template/ (with @?@+-- placeholders), not the interpolated SQL, so parameter values never reach the+-- span. The @db.operation.name@ is inferred from the leading keyword of that+-- template (see 'inferOperationName'); set @db.collection.name@ \/+-- @db.namespace@ yourself with "Effectful.Tracing.addAttribute" inside the call+-- if you want them, since they cannot be derived reliably without parsing SQL.+module Effectful.Tracing.Instrumentation.SqliteSimple+  ( query+  , query_+  , execute+  , execute_+  , executeMany+  ) where++import Control.Monad.IO.Class (liftIO)+import GHC.Stack (HasCallStack)++import Database.SQLite.Simple (Connection, FromRow, Query, ToRow)+import Database.SQLite.Simple qualified as Sqlite+import Database.SQLite.Simple.Types (fromQuery)++import Effectful (Eff, IOE, (:>))+import Effectful.Tracing (Tracer, addAttribute)+import Effectful.Tracing.Instrumentation.Database+  ( DatabaseQuery (queryOperation, queryText)+  , databaseQuery+  , inferOperationName+  , withQuerySpan+  )+import Effectful.Tracing.SemConv qualified as SemConv++-- | 'Database.SQLite.Simple.query' wrapped in a traced @client@-kind span.+query+  :: (HasCallStack, IOE :> es, Tracer :> es, ToRow q, FromRow r)+  => Connection+  -> Query+  -> q+  -> Eff es [r]+query conn template params =+  withQuerySpan (describe template) (liftIO (Sqlite.query conn template params))++-- | 'Database.SQLite.Simple.query_' wrapped in a traced @client@-kind span.+query_+  :: (HasCallStack, IOE :> es, Tracer :> es, FromRow r)+  => Connection+  -> Query+  -> Eff es [r]+query_ conn template =+  withQuerySpan (describe template) (liftIO (Sqlite.query_ conn template))++-- | 'Database.SQLite.Simple.execute' wrapped in a traced @client@-kind span.+execute+  :: (HasCallStack, IOE :> es, Tracer :> es, ToRow q)+  => Connection+  -> Query+  -> q+  -> Eff es ()+execute conn template params =+  withQuerySpan (describe template) (liftIO (Sqlite.execute conn template params))++-- | 'Database.SQLite.Simple.execute_' wrapped in a traced @client@-kind span.+execute_+  :: (HasCallStack, IOE :> es, Tracer :> es)+  => Connection+  -> Query+  -> Eff es ()+execute_ conn template =+  withQuerySpan (describe template) (liftIO (Sqlite.execute_ conn template))++-- | 'Database.SQLite.Simple.executeMany' wrapped in a traced @client@-kind+-- span. The number of parameter rows is recorded as @db.operation.batch.size@.+executeMany+  :: (HasCallStack, IOE :> es, Tracer :> es, ToRow q)+  => Connection+  -> Query+  -> [q]+  -> Eff es ()+executeMany conn template paramsList =+  withQuerySpan (describe template) $ do+    addAttribute SemConv.dbOperationBatchSize (length paramsList)+    liftIO (Sqlite.executeMany conn template paramsList)++-- | Build the query description from a @sqlite-simple@ 'Query' template: system+-- @\"sqlite\"@, @db.query.text@ from the template, and @db.operation.name@+-- inferred from its leading keyword.+describe :: Query -> DatabaseQuery+describe template =+  (databaseQuery "sqlite")+    { queryText = Just statement+    , queryOperation = inferOperationName statement+    }+  where+    statement = fromQuery template
+ src/Effectful/Tracing/Instrumentation/Valiant.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.Instrumentation.Valiant+-- Description : Tracing wrappers for valiant's Effectful adapter.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+-- Stability   : experimental+--+-- Drop-in replacements for the statement runners in @Valiant.Effectful@ (the+-- @valiant-effectful@ adapter for <https://hackage.haskell.org/package/valiant valiant>,+-- the compile-time checked PostgreSQL library) that run each call inside a+-- @client@-kind span recording the stable OpenTelemetry database semantic+-- conventions (see "Effectful.Tracing.SemConv"). Each wrapper delegates to the+-- @Valiant@ effect and to "Effectful.Tracing.Instrumentation.Database", so the+-- span is named after the statement's operation and finalized even if the query+-- throws.+--+-- Import this module qualified /instead of/ @Valiant.Effectful@ for the traced+-- runners, keeping @Valiant.Effectful@ for the handler ('Valiant.Effectful.runValiant')+-- and the transaction \/ raw-connection helpers, which carry no statement to+-- describe:+--+-- > import Valiant (Statement)+-- > import Valiant.Effectful (Valiant, runValiant)+-- > import Effectful.Tracing.Instrumentation.Valiant qualified as V+-- >+-- > activeUsers :: (Valiant :> es, Tracer :> es) => Statement () User -> Eff es [User]+-- > activeUsers listUsers = V.fetchAllEff listUsers ()+--+-- The system name is @postgresql@. The recorded @db.query.text@ is the+-- statement's own validated SQL (a 'Valiant.Statement', whose text is the+-- parameterized query, never interpolated values), and @db.operation.name@ is+-- inferred from its leading keyword (see 'inferOperationName'). Set+-- @db.collection.name@ \/ @db.namespace@ yourself with+-- "Effectful.Tracing.addAttribute" inside the call if you want them, since they+-- cannot be derived reliably without parsing SQL.+module Effectful.Tracing.Instrumentation.Valiant+  ( -- * Queries+    fetchOneEff+  , fetchAllEff+  , fetchScalarEff+  , fetchOneOrThrowEff+  , fetchExistsEff++    -- * Commands+  , executeEff+  , executeReturningEff+  , executeBatchEff+  ) where++import Data.Int (Int64)+import Data.Text.Encoding (decodeUtf8Lenient)+import GHC.Stack (HasCallStack)++import Valiant (Statement (stmtSQL))+import Valiant.Effectful (Valiant)+import Valiant.Effectful qualified as V++import Effectful (Eff, (:>))+import Effectful.Tracing (Tracer, addAttribute)+import Effectful.Tracing.Instrumentation.Database+  ( DatabaseQuery (queryOperation, queryText)+  , databaseQuery+  , inferOperationName+  , withQuerySpan+  )+import Effectful.Tracing.SemConv qualified as SemConv++-- | 'Valiant.Effectful.fetchOneEff' wrapped in a traced @client@-kind span.+fetchOneEff+  :: (HasCallStack, Valiant :> es, Tracer :> es)+  => Statement p r+  -> p+  -> Eff es (Maybe r)+fetchOneEff stmt params =+  withQuerySpan (describe stmt) (V.fetchOneEff stmt params)++-- | 'Valiant.Effectful.fetchAllEff' wrapped in a traced @client@-kind span.+fetchAllEff+  :: (HasCallStack, Valiant :> es, Tracer :> es)+  => Statement p r+  -> p+  -> Eff es [r]+fetchAllEff stmt params =+  withQuerySpan (describe stmt) (V.fetchAllEff stmt params)++-- | 'Valiant.Effectful.fetchScalarEff' wrapped in a traced @client@-kind span.+fetchScalarEff+  :: (HasCallStack, Valiant :> es, Tracer :> es)+  => Statement p r+  -> p+  -> Eff es r+fetchScalarEff stmt params =+  withQuerySpan (describe stmt) (V.fetchScalarEff stmt params)++-- | 'Valiant.Effectful.fetchOneOrThrowEff' wrapped in a traced @client@-kind span.+fetchOneOrThrowEff+  :: (HasCallStack, Valiant :> es, Tracer :> es)+  => Statement p r+  -> p+  -> Eff es r+fetchOneOrThrowEff stmt params =+  withQuerySpan (describe stmt) (V.fetchOneOrThrowEff stmt params)++-- | 'Valiant.Effectful.fetchExistsEff' wrapped in a traced @client@-kind span.+fetchExistsEff+  :: (HasCallStack, Valiant :> es, Tracer :> es)+  => Statement p r+  -> p+  -> Eff es Bool+fetchExistsEff stmt params =+  withQuerySpan (describe stmt) (V.fetchExistsEff stmt params)++-- | 'Valiant.Effectful.executeEff' wrapped in a traced @client@-kind span.+executeEff+  :: (HasCallStack, Valiant :> es, Tracer :> es)+  => Statement p ()+  -> p+  -> Eff es Int64+executeEff stmt params =+  withQuerySpan (describe stmt) (V.executeEff stmt params)++-- | 'Valiant.Effectful.executeReturningEff' wrapped in a traced @client@-kind span.+executeReturningEff+  :: (HasCallStack, Valiant :> es, Tracer :> es)+  => Statement p r+  -> p+  -> Eff es (Int64, [r])+executeReturningEff stmt params =+  withQuerySpan (describe stmt) (V.executeReturningEff stmt params)++-- | 'Valiant.Effectful.executeBatchEff' wrapped in a traced @client@-kind span.+-- The number of parameter rows is recorded as @db.operation.batch.size@.+executeBatchEff+  :: (HasCallStack, Valiant :> es, Tracer :> es)+  => Statement p ()+  -> [p]+  -> Eff es Int64+executeBatchEff stmt paramsList =+  withQuerySpan (describe stmt) $ do+    addAttribute SemConv.dbOperationBatchSize (length paramsList)+    V.executeBatchEff stmt paramsList++-- | Build the query description from a 'Valiant.Statement': system+-- @\"postgresql\"@, @db.query.text@ from the statement's validated SQL, and+-- @db.operation.name@ inferred from its leading keyword.+describe :: Statement p r -> DatabaseQuery+describe stmt =+  (databaseQuery "postgresql")+    { queryText = Just statement+    , queryOperation = inferOperationName statement+    }+  where+    statement = decodeUtf8Lenient (stmtSQL stmt)
+ src/Effectful/Tracing/Instrumentation/Wai.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++-- |+-- Module      : Effectful.Tracing.Instrumentation.Wai+-- Description : Tracing middleware for WAI applications.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+-- Stability   : experimental+--+-- A WAI 'Middleware' that opens a @server@-kind span around each request. It+-- continues an inbound distributed trace (reading @traceparent@ \/ @tracestate@+-- with "Effectful.Tracing.Propagation"), records the request and response+-- following the stable OpenTelemetry HTTP semantic conventions (the+-- @http.request.method@ \/ @url.path@ \/ @http.response.status_code@ set; see+-- "Effectful.Tracing.SemConv"), and lets the shared span lifecycle record any+-- exception as a span error before it propagates.+--+-- Because span management lives in @'Eff' es@ but WAI runs in 'IO', the+-- middleware takes an unlift function @forall a. 'Eff' es a -> 'IO' a@. Obtain+-- one with effectful's @withEffToIO@ (or @withRunInIO@) at the point you start+-- the server:+--+-- > import Effectful+-- >+-- > server :: (IOE :> es, Tracer :> es) => Application -> Eff es ()+-- > server app = withEffToIO (ConcUnlift Persistent Unlimited) $ \runInIO ->+-- >   Warp.run 8080 (traceMiddleware runInIO app)+--+-- A real server handles requests concurrently, so the unlift must tolerate+-- concurrent invocation: use a concurrent unlift strategy, not the default+-- sequential one.+module Effectful.Tracing.Instrumentation.Wai+  ( -- * Middleware+    traceMiddleware+  , traceMiddlewareWith++    -- * Span naming+  , defaultSpanName++    -- * Building blocks+  , requestAttributes+  ) where++import Control.Monad (when)+import Control.Monad.IO.Class (liftIO)+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding (decodeUtf8Lenient)++import Network.HTTP.Types (HttpVersion (httpMajor, httpMinor), Status (statusCode, statusMessage))+import Network.Wai+  ( Middleware+  , Request+  , httpVersion+  , isSecure+  , rawPathInfo+  , rawQueryString+  , requestHeaders+  , requestMethod+  , responseStatus+  )++import Effectful (Eff, IOE, (:>))++import Effectful.Tracing+  ( Attribute+  , SpanArguments (attributes, kind)+  , SpanKind (Server)+  , SpanStatus (Error)+  , Tracer+  , addAttribute+  , defaultSpanArguments+  , extractContext+  , setStatus+  , withRemoteParent+  , withSpan'+  , (.=)+  )+import Effectful.Tracing.SemConv qualified as SemConv++-- | Wrap an 'Network.Wai.Application' so every request runs inside a+-- @server@-kind span, naming the span with 'defaultSpanName' (the request+-- method). See 'traceMiddlewareWith' to supply your own name (for example the+-- matched route, which produces lower-cardinality, more useful span names when+-- the routing layer knows it).+traceMiddleware+  :: (IOE :> es, Tracer :> es)+  => (forall a. Eff es a -> IO a)+  -- ^ Run an @'Eff' es@ action in 'IO'. Must tolerate concurrent calls; see the+  -- module header.+  -> Middleware+traceMiddleware = traceMiddlewareWith defaultSpanName++-- | 'traceMiddleware' with an explicit span-naming function. The OpenTelemetry+-- HTTP conventions recommend a low-cardinality name such as @\"{method}+-- {route}\"@; pass the matched route here when you have it, and avoid putting the+-- raw path (which is high-cardinality) in the name.+traceMiddlewareWith+  :: (IOE :> es, Tracer :> es)+  => (Request -> Text)+  -> (forall a. Eff es a -> IO a)+  -> Middleware+traceMiddlewareWith nameFor runInIO app req respond =+  runInIO (continueRemote (withSpan' (nameFor req) serverArgs body))+  where+    -- Rejoin an inbound distributed trace when the headers carry one; otherwise+    -- this request roots a new trace.+    continueRemote =+      maybe id withRemoteParent (extractContext (requestHeaders req))++    serverArgs =+      defaultSpanArguments+        { kind = Server+        , attributes = requestAttributes req+        }++    body = do+      -- Capture the response status as it flows back through the responder, so+      -- it can be recorded on the span before the scope closes.+      statusRef <- liftIO (newIORef Nothing)+      let respond' response = do+            -- Project and force the status before storing it, so the ref does+            -- not retain the whole response (body included) until the span+            -- closes.+            let !status = responseStatus response+            writeIORef statusRef (Just status)+            respond response+      received <- liftIO (app req respond')+      mStatus <- liftIO (readIORef statusRef)+      case mStatus of+        Nothing -> pure ()+        Just status -> do+          addAttribute SemConv.httpResponseStatusCode (statusCode status)+          -- 5xx marks the server span as failed (4xx is a client error, not the+          -- server's, so it leaves the status unset per the conventions).+          when (statusCode status >= 500) $+            setStatus (Error (decodeUtf8Lenient (statusMessage status)))+      pure received++-- | The default span name: the HTTP request method (for example @\"GET\"@). This+-- is deliberately low-cardinality. When the route template is known, prefer+-- 'traceMiddlewareWith' to name the span after it.+defaultSpanName :: Request -> Text+defaultSpanName = decodeUtf8Lenient . requestMethod++-- | The request attributes recorded at span start, following the stable HTTP+-- and URL semantic conventions (see "Effectful.Tracing.SemConv"). @url.query@ is+-- recorded only when the request carries a query string.+requestAttributes :: Request -> [Attribute]+requestAttributes req =+  [ SemConv.httpRequestMethod .= decodeUtf8Lenient (requestMethod req)+  , SemConv.urlPath .= decodeUtf8Lenient (rawPathInfo req)+  , SemConv.urlScheme .= (if isSecure req then "https" else "http" :: Text)+  , SemConv.networkProtocolVersion .= protocolVersion (httpVersion req)+  ]+    <> [SemConv.urlQuery .= query | not (T.null query)]+  where+    -- 'rawQueryString' includes the leading '?'; the @url.query@ convention is+    -- the query without it, and the attribute is omitted when there is none.+    query =+      let raw = decodeUtf8Lenient (rawQueryString req)+       in fromMaybe raw (T.stripPrefix "?" raw)++-- | Render an 'HttpVersion' as the OTel @network.protocol.version@ value, for+-- example @\"1.1\"@.+protocolVersion :: HttpVersion -> Text+protocolVersion v = T.pack (show (httpMajor v)) <> "." <> T.pack (show (httpMinor v))
+ src/Effectful/Tracing/Internal/Clock.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE DerivingStrategies #-}++-- |+-- Module      : Effectful.Tracing.Internal.Clock+-- Description : Timestamp abstraction for span timing.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+-- Stability   : internal+--+-- A thin wrapper over wall-clock time so tests can substitute a fixed clock and+-- so the underlying representation can change (for example to monotonic nanos)+-- without churning every call site.+module Effectful.Tracing.Internal.Clock+  ( Timestamp (..)+  , getTimestamp+  ) where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Time.Clock (UTCTime, getCurrentTime)++-- | A point in time associated with a span boundary or event.+newtype Timestamp = Timestamp UTCTime+  deriving stock (Eq, Ord, Show)++-- | The current wall-clock time.+getTimestamp :: (MonadIO m) => m Timestamp+getTimestamp = Timestamp <$> liftIO getCurrentTime
+ src/Effectful/Tracing/Internal/Ids.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- |+-- Module      : Effectful.Tracing.Internal.Ids+-- Description : Trace and span identifiers, generation, and hex codec.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+-- Stability   : internal+--+-- Trace and span identifiers as defined by the OpenTelemetry / W3C+-- TraceContext specifications: a 't:TraceId' is 16 bytes and a 't:SpanId' is 8+-- bytes. Identifiers render as lowercase hex, matching the wire form.+--+-- This is an @.Internal.@ module: it exposes the raw newtype constructors and+-- carries no stability promise. Prefer the validated constructors+-- ('traceIdFromBytes', 'traceIdFromHex', and the generators) over the raw+-- constructors.+module Effectful.Tracing.Internal.Ids+  ( -- * Identifiers+    TraceId (..)+  , SpanId (..)++    -- * Generation+  , newTraceId+  , newSpanId++    -- * Validation+  , traceIdFromBytes+  , spanIdFromBytes+  , isValidTraceId+  , isValidSpanId++    -- * Hex codec+  , traceIdToHex+  , spanIdToHex+  , traceIdFromHex+  , spanIdFromHex+  ) where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.ByteString.Builder (byteStringHex, toLazyByteString)+import Data.ByteString.Lazy qualified as BSL+import Data.Char (isDigit, ord)+import Data.Hashable (Hashable)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding (decodeLatin1)+import Data.Word (Word8)++#ifdef SECURE_IDS+import Crypto.Random (getRandomBytes)+#else+import System.Random.Stateful (globalStdGen, uniformByteStringM)+#endif++-- | The fixed length of a trace identifier, in bytes (16, per the spec).+traceIdByteLength :: Int+traceIdByteLength = 16++-- | The fixed length of a span identifier, in bytes (8, per the spec).+spanIdByteLength :: Int+spanIdByteLength = 8++-- | A 16-byte trace identifier. Renders as 32 lowercase hex characters.+newtype TraceId = TraceId ByteString+  deriving newtype (Eq, Ord, Hashable)++-- | An 8-byte span identifier. Renders as 16 lowercase hex characters.+newtype SpanId = SpanId ByteString+  deriving newtype (Eq, Ord, Hashable)++instance Show TraceId where+  show = T.unpack . traceIdToHex++instance Show SpanId where+  show = T.unpack . spanIdToHex++-- | Generate a fresh, valid (non-zero) trace identifier.+--+-- By default this uses a fast pseudo-random source (@random@'s global+-- @StdGen@, splitmix under the hood), not a CSPRNG. This is the conventional+-- SDK choice and keeps per-span cost low. Building with the @secure-ids@ cabal+-- flag swaps the byte source to @crypton@'s cryptographically secure system+-- entropy, leaving this function's name and type unchanged. The all-zero+-- identifier is the spec's "invalid" sentinel and is never returned in either+-- mode.+newTraceId :: (MonadIO m) => m TraceId+newTraceId = TraceId <$> randomNonZeroBytes traceIdByteLength++-- | Generate a fresh, valid (non-zero) span identifier. See 'newTraceId'.+newSpanId :: (MonadIO m) => m SpanId+newSpanId = SpanId <$> randomNonZeroBytes spanIdByteLength++-- | Draw @n@ random bytes, retrying on the astronomically unlikely all-zero+-- draw so the result is always a valid identifier.+randomNonZeroBytes :: (MonadIO m) => Int -> m ByteString+randomNonZeroBytes n = do+  bytes <- liftIO (drawBytes n)+  if BS.all (== 0) bytes+    then randomNonZeroBytes n+    else pure bytes++-- | Draw @n@ random bytes from the configured source. The @secure-ids@ cabal+-- flag selects between @crypton@'s cryptographically secure system entropy and+-- @random@'s fast splitmix-backed global generator (the default).+drawBytes :: Int -> IO ByteString+#ifdef SECURE_IDS+drawBytes = getRandomBytes+#else+drawBytes n = uniformByteStringM n globalStdGen+#endif++-- | A trace identifier is valid when it is the right length and not all zero.+isValidTraceId :: TraceId -> Bool+isValidTraceId (TraceId bs) = BS.length bs == traceIdByteLength && BS.any (/= 0) bs++-- | A span identifier is valid when it is the right length and not all zero.+isValidSpanId :: SpanId -> Bool+isValidSpanId (SpanId bs) = BS.length bs == spanIdByteLength && BS.any (/= 0) bs++-- | Build a 't:TraceId' from raw bytes, checking only the length. Returns+-- 'Nothing' on the wrong length. (An all-zero but correctly-sized value is+-- accepted here; use 'isValidTraceId' to reject the invalid sentinel.)+traceIdFromBytes :: ByteString -> Maybe TraceId+traceIdFromBytes bs+  | BS.length bs == traceIdByteLength = Just (TraceId bs)+  | otherwise = Nothing++-- | Build a 't:SpanId' from raw bytes, checking only the length. See+-- 'traceIdFromBytes'.+spanIdFromBytes :: ByteString -> Maybe SpanId+spanIdFromBytes bs+  | BS.length bs == spanIdByteLength = Just (SpanId bs)+  | otherwise = Nothing++-- | Render a 't:TraceId' as 32 lowercase hex characters.+traceIdToHex :: TraceId -> Text+traceIdToHex (TraceId bs) = bytesToHex bs++-- | Render a 't:SpanId' as 16 lowercase hex characters.+spanIdToHex :: SpanId -> Text+spanIdToHex (SpanId bs) = bytesToHex bs++-- | Parse a 't:TraceId' from hex. Returns 'Nothing' unless the input is exactly+-- 32 hex characters.+traceIdFromHex :: Text -> Maybe TraceId+traceIdFromHex t = hexToBytes t >>= traceIdFromBytes++-- | Parse a 't:SpanId' from hex. Returns 'Nothing' unless the input is exactly+-- 16 hex characters.+spanIdFromHex :: Text -> Maybe SpanId+spanIdFromHex t = hexToBytes t >>= spanIdFromBytes++-- | Render bytes as lowercase hex. @byteStringHex@ is the @bytestring@+-- library's builder-based encoder: it produces lowercase output (matching the+-- W3C wire form) and walks the input once, rather than building an+-- intermediate @String@ per byte. The result is ASCII, so decoding the bytes+-- back to 'Text' with 'decodeLatin1' is total and cannot fail.+bytesToHex :: ByteString -> Text+bytesToHex = decodeLatin1 . BSL.toStrict . toLazyByteString . byteStringHex++-- | Parse an even-length hex string into bytes. Total: returns 'Nothing' on an+-- odd length or any non-hex character.+hexToBytes :: Text -> Maybe ByteString+hexToBytes t+  | odd (T.length t) = Nothing+  | otherwise = BS.pack <$> traverse pairToByte (pairUp (T.unpack t))+  where+    pairUp :: [Char] -> [(Char, Char)]+    pairUp (a : b : rest) = (a, b) : pairUp rest+    pairUp _ = []++    pairToByte :: (Char, Char) -> Maybe Word8+    pairToByte (a, b) = do+      hi <- hexValue a+      lo <- hexValue b+      pure (fromIntegral (hi * 16 + lo))++hexValue :: Char -> Maybe Int+hexValue c+  | isDigit c = Just (ord c - ord '0')+  | c >= 'a' && c <= 'f' = Just (ord c - ord 'a' + 10)+  | c >= 'A' && c <= 'F' = Just (ord c - ord 'A' + 10)+  | otherwise = Nothing
+ src/Effectful/Tracing/Internal/Live.hs view
@@ -0,0 +1,379 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.Internal.Live+-- Description : Shared span-lifecycle handler for interpreters that open spans.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+-- Stability   : internal+--+-- Every interpreter that actually opens and closes spans (in-memory,+-- pretty-print, OpenTelemetry) shares the same lifecycle: the active span is+-- __lexical__ (carried in a private @'Reader' ('Maybe' ActiveSpan)@ installed+-- by 'reinterpret', and set for a child scope with 'local' around the unlifted+-- action), and span finalization runs inside 'generalBracket' so a span is+-- closed exactly once even when its action is killed by an asynchronous+-- exception.+--+-- 'interpretTracer' captures that lifecycle once and parameterizes the only+-- thing the interpreters differ on: what to do with a completed 't:Span'. The+-- sink is a plain @'t:Span' -> 'IO' ()@, which is all the in-memory (append to a+-- buffer), pretty-print (render a finished trace), and OpenTelemetry (hand to+-- an exporter) interpreters need.+--+-- This is an @.Internal.@ module: it carries no stability promise.+module Effectful.Tracing.Internal.Live+  ( interpretTracer+  ) where++import Control.Exception (SomeException, displayException)+import Control.Monad (when)+import Control.Monad.IO.Class (liftIO)+import Data.IORef (IORef, modifyIORef', newIORef, readIORef)+import Data.Maybe (fromMaybe, isNothing)+import Data.Text (Text)+import Data.Text qualified as T++import Effectful (Eff, IOE, (:>))+import Effectful.Dispatch.Dynamic (reinterpret)+import Effectful.Dispatch.Dynamic qualified as Dynamic+import Effectful.Exception (ExitCase (ExitCaseAbort, ExitCaseException), generalBracket)+import Effectful.Reader.Static (Reader, ask, local, runReader)++import Effectful.Tracing.Attribute (Attribute (Attribute), AttributeValue (AttrText))+import Effectful.Tracing.Effect+  ( SpanArguments (attributes, kind, links, startTime)+  , Tracer+      ( AddAttribute+      , AddAttributes+      , AddEvent+      , GetActiveSpan+      , RecordException+      , SetStatus+      , UpdateName+      , WithLinkedRoot+      , WithRemoteParent+      , WithSpan+      )+  , transitionStatus+  )+import Effectful.Tracing.Internal.Clock (Timestamp (Timestamp), getTimestamp)+import Effectful.Tracing.Internal.Ids (newSpanId, newTraceId)+import Effectful.Tracing.Internal.Types+  ( Event (Event)+  , Link+  , Span (..)+  , SpanContext (..)+  , SpanKind (Internal)+  , SpanStatus (Error, Unset)+  , defaultTraceFlags+  , emptyTraceState+  , setSampled+  )+import Effectful.Tracing.Sampler+  ( Sampler (shouldSample)+  , SamplerInput (SamplerInput)+  , SamplingDecision (Drop, RecordAndSample)+  , SamplingResult (decision, extraAttributes, newTraceState)+  )+import Effectful.Tracing.SemConv qualified as SemConv+import Effectful.Tracing.SpanLimits+  ( SpanLimits (attributeCountLimit, eventCountLimit)+  , applySpanLimits+  )++-- | The mutable, accumulating part of an in-flight span. Attributes and events+-- are stored newest-first and reversed when the span completes, so each emit is+-- an O(1) cons rather than an O(n) append. The name lives here too (rather than+-- in the immutable 't:ActiveSpan' identity) so 'UpdateName' can replace it. The+-- running counts let the count caps (see 'SpanLimits') be enforced as the span+-- records, in O(1) per emit, so an in-flight span cannot grow past its limit.+data SpanBuilder = SpanBuilder+  { builderName :: !Text+  , builderAttributes :: ![Attribute]+  , builderAttributeCount :: !Int+  , builderEvents :: ![Event]+  , builderEventCount :: !Int+  , builderStatus :: !SpanStatus+  }++-- | The lexically-active span, carried in the handler's private 'Reader'. Its+-- immutable identity travels alongside an 'IORef' to the accumulating builder+-- so emit operations can mutate the span they are nested inside.+data ActiveSpan = ActiveSpan+  { activeContext :: !SpanContext+  , activeParent :: !(Maybe SpanContext)+  , activeKind :: !SpanKind+  , activeStart :: !Timestamp+  , activeLinks :: ![Link]+  , activeBuilder :: !(IORef SpanBuilder)+  , activeDecision :: !SamplingDecision+  }++-- | Interpret 'Tracer' by opening a real span for each scoped action and+-- handing every completed, non-dropped 't:Span' to the given sink.+--+-- The active span is lexical: scoped actions run inside a fresh child span+-- installed for their scope only, emit operations annotate the+-- lexically-current span (and are silent no-ops when there is none), and+-- 'GetActiveSpan' reports it. Finalization runs in 'generalBracket', so the+-- sink sees each span exactly once, with an 'Error' status if the action was+-- killed, and exceptions still propagate (the interpreter records, it does not+-- swallow).+--+-- The 't:Sampler' is consulted once per span, at start. A 'Drop' decision still+-- runs the scoped action (the user's code must execute) and still establishes a+-- lexical span for nested operations, but the completed span is not handed to+-- the sink; 'Effectful.Tracing.Sampler.RecordOnly' and 'RecordAndSample' both reach the sink. The+-- @sampled@ trace flag is set exactly when the decision is 'RecordAndSample',+-- and the sampler's extra attributes and trace-state replacement are applied to+-- the span.+interpretTracer+  :: IOE :> es+  => SpanLimits+  -- ^ The per-span caps to enforce as spans record and finalize.+  -> Sampler+  -> (Span -> IO ())+  -- ^ What to do with each completed span. Runs on the thread that closed the+  -- span; keep it cheap and non-blocking.+  -> Eff (Tracer : es) a+  -> Eff es a+interpretTracer limits sampler onComplete =+  reinterpret (runReader (Nothing :: Maybe ActiveSpan) . runReader ([] :: [Link])) $ \env -> \case+    WithSpan name args action -> do+      parent <- ask+      pending <- ask+      active <- openSpan limits sampler name args parent pending+      Dynamic.localSeqUnlift env $ \unlift -> do+        -- Inside the span the active span is this one and the pending links have+        -- been consumed (a child must not re-link to the cause of its root).+        let use _ = local (const (Just active)) (local (const ([] :: [Link])) (unlift action))+        (result, ()) <-+          generalBracket+            (pure ())+            (\_ exitCase -> do+                completed <- finalizeSpan limits active exitCase+                when (activeDecision active /= Drop) (liftIO (onComplete completed)))+            use+        pure result+    WithLinkedRoot newLinks action ->+      -- Detach the active span so a nested WithSpan starts a new root, and stage+      -- the links so that root picks them up.+      Dynamic.localSeqUnlift env $ \unlift ->+        local (const (Nothing :: Maybe ActiveSpan)) (local (const newLinks) (unlift action))+    WithRemoteParent context action -> do+      -- Make the remote context the active parent for the scope so a nested+      -- WithSpan continues its trace. The remote span is not ours to emit, so it+      -- carries a throwaway builder and is never finalized.+      remote <- remoteActiveSpan context+      Dynamic.localSeqUnlift env $ \unlift ->+        local (const (Just remote)) (local (const ([] :: [Link])) (unlift action))+    AddAttribute key value ->+      withActive $ \active ->+        liftIO (modifyIORef' (activeBuilder active) (pushAttributes limits [Attribute key value]))+    AddAttributes attrs ->+      withActive $ \active ->+        liftIO (modifyIORef' (activeBuilder active) (pushAttributes limits attrs))+    AddEvent name attrs ->+      withActive $ \active -> do+        now <- getTimestamp+        liftIO (modifyIORef' (activeBuilder active) (pushEvent limits (Event name now attrs)))+    RecordException err ->+      withActive $ \active -> do+        now <- getTimestamp+        liftIO (modifyIORef' (activeBuilder active) (pushEvent limits (exceptionEvent now err)))+    SetStatus status ->+      withActive $ \active ->+        liftIO (modifyIORef' (activeBuilder active) (applyStatus status))+    UpdateName name ->+      withActive $ \active ->+        liftIO (modifyIORef' (activeBuilder active) (\b -> b {builderName = name}))+    GetActiveSpan -> fmap activeContext <$> ask++-- | Run an action against the active span, or do nothing if there is none.+withActive+  :: Reader (Maybe ActiveSpan) :> es+  => (ActiveSpan -> Eff es ())+  -> Eff es ()+withActive f = ask >>= maybe (pure ()) f++-- | Build a fresh 't:ActiveSpan': inherit trace identity from the parent (or mint+-- a new trace at a root), consult the sampler, allocate a span id, set the+-- @sampled@ flag and any sampler-supplied attributes and trace state, record+-- the start time, and seed the builder.+openSpan+  :: IOE :> es+  => SpanLimits+  -> Sampler+  -> Text+  -> SpanArguments+  -> Maybe ActiveSpan+  -> [Link]+  -- ^ Pending "caused by" links, attached only when this span is a root (a span+  -- opened inside a 'WithLinkedRoot' scope); ignored for child spans.+  -> Eff es ActiveSpan+openSpan limits sampler name args parent pendingLinks = do+  -- Force the projected parent context (not just the @Maybe@ to WHNF). A lazy+  -- @activeContext <$> parent@ leaves @Just (activeContext p)@ as a thunk that+  -- retains the parent's entire 't:ActiveSpan' (and its builder 'IORef') inside+  -- every completed child span. 'spanContextTraceId' etc. are strict, so+  -- forcing to WHNF keeps only the small immutable context.+  let parentContext = case parent of+        Nothing -> Nothing+        Just p -> Just $! activeContext p+      spanLinks = links args <> if isNothing parentContext then pendingLinks else []+  (traceId, baseFlags, baseState) <- case parentContext of+    Just pc -> pure (spanContextTraceId pc, spanContextTraceFlags pc, spanContextTraceState pc)+    Nothing -> do+      traceId <- newTraceId+      pure (traceId, defaultTraceFlags, emptyTraceState)+  -- Built positionally: SamplerInput's field names (spanName, spanKind, links)+  -- collide with Span and SpanArguments selectors, so its labels are not+  -- imported here.+  result <-+    liftIO . shouldSample sampler $+      SamplerInput parentContext traceId name (kind args) (attributes args) spanLinks+  spanId <- newSpanId+  let sampled = decision result == RecordAndSample+      context =+        SpanContext+          { spanContextTraceId = traceId+          , spanContextSpanId = spanId+          , spanContextTraceFlags = setSampled sampled baseFlags+          , spanContextTraceState = fromMaybe baseState (newTraceState result)+          , spanContextIsRemote = False+          }+  start <- maybe getTimestamp (pure . Timestamp) (startTime args)+  -- Seed the attributes through the same count cap the emit path uses, so an+  -- over-budget initial set (span arguments plus sampler extras) is bounded+  -- here rather than only at finalization.+  let initialAttributes = capCount (attributeCountLimit limits) (attributes args <> extraAttributes result)+  builder <-+    liftIO . newIORef $+      SpanBuilder+        { builderName = name+        , builderAttributes = reverse initialAttributes+        , builderAttributeCount = length initialAttributes+        , builderEvents = []+        , builderEventCount = 0+        , builderStatus = Unset+        }+  pure+    ActiveSpan+      { activeContext = context+      , activeParent = parentContext+      , activeKind = kind args+      , activeStart = start+      , activeLinks = spanLinks+      , activeBuilder = builder+      , activeDecision = decision result+      }++-- | A synthetic 't:ActiveSpan' standing in for a remote parent. It exists only to+-- be the parent context for spans opened inside a 'WithRemoteParent' scope: it+-- is never finalized or emitted, so its builder is a throwaway and its name and+-- kind are placeholders. The context is marked remote.+remoteActiveSpan :: IOE :> es => SpanContext -> Eff es ActiveSpan+remoteActiveSpan context = do+  start <- getTimestamp+  builder <- liftIO (newIORef (SpanBuilder "" [] 0 [] 0 Unset))+  pure+    ActiveSpan+      { activeContext = context {spanContextIsRemote = True}+      , activeParent = Nothing+      , activeKind = Internal+      , activeStart = start+      , activeLinks = []+      , activeBuilder = builder+      , activeDecision = RecordAndSample+      }++-- | Finalize a span: record its end time, fold in an error status and exception+-- event if the action did not complete normally, and snapshot the builder into+-- an immutable 't:Span'. Runs inside 'generalBracket', so it fires exactly once.+finalizeSpan+  :: IOE :> es+  => SpanLimits+  -> ActiveSpan+  -> ExitCase a+  -> Eff es Span+finalizeSpan limits active exitCase = do+  end <- getTimestamp+  case exitCase of+    ExitCaseException err ->+      liftIO . modifyIORef' (activeBuilder active) $+        applyStatus (Error (T.pack (displayException err)))+          . pushEvent limits (exceptionEvent end err)+    ExitCaseAbort ->+      liftIO . modifyIORef' (activeBuilder active) $+        applyStatus (Error "span aborted")+    _ -> pure ()+  builder <- liftIO (readIORef (activeBuilder active))+  -- Force the immutable span to WHNF before it leaves the closing thread. With+  -- 'StrictData' that realizes every field (the attribute and event lists are+  -- reversed and so fully traversed), so a sink that stores the span (the+  -- in-memory buffer, the pretty-print accumulator) holds a finished value+  -- rather than a thunk retaining this span's builder 'IORef' and 't:ActiveSpan'.+  -- 'applySpanLimits' is where the value-length truncation and the link cap land+  -- (the count caps were already enforced as the span recorded).+  pure $!+    applySpanLimits limits $+      Span+        { spanContext = activeContext active+        , spanParentContext = activeParent active+        , spanName = builderName builder+        , spanKind = activeKind active+        , spanStartTime = activeStart active+        , spanEndTime = end+        , spanAttributes = reverse (builderAttributes builder)+        , spanEvents = reverse (builderEvents builder)+        , spanLinks = activeLinks active+        , spanStatus = builderStatus builder+        }++-- | Prepend attributes to a builder (stored newest-first), keeping at most the+-- attribute-count limit. Only the entries that fit the remaining budget are+-- recorded (the earliest of the batch), so the running count never exceeds the+-- cap.+pushAttributes :: SpanLimits -> [Attribute] -> SpanBuilder -> SpanBuilder+pushAttributes limits attrs builder =+  builder+    { builderAttributes = reverse kept <> builderAttributes builder+    , builderAttributeCount = builderAttributeCount builder + length kept+    }+  where+    kept = case attributeCountLimit limits of+      Nothing -> attrs+      Just n -> take (max 0 (n - builderAttributeCount builder)) attrs++-- | Prepend an event to a builder (stored newest-first), unless the event-count+-- limit has already been reached, in which case the event is dropped (the+-- earliest events are the ones kept).+pushEvent :: SpanLimits -> Event -> SpanBuilder -> SpanBuilder+pushEvent limits event builder =+  case eventCountLimit limits of+    Just n | builderEventCount builder >= n -> builder+    _ ->+      builder+        { builderEvents = event : builderEvents builder+        , builderEventCount = builderEventCount builder + 1+        }++-- | Keep at most @n@ of a list (the first @n@) when a cap is set; 'Nothing'+-- keeps everything. Used to bound the initial attribute set at span open.+capCount :: Maybe Int -> [a] -> [a]+capCount Nothing = id+capCount (Just n) = take (max 0 n)++-- | Apply a status transition (see 'transitionStatus').+applyStatus :: SpanStatus -> SpanBuilder -> SpanBuilder+applyStatus status builder =+  builder {builderStatus = transitionStatus (builderStatus builder) status}++-- | An OpenTelemetry-style @exception@ event carrying the message.+exceptionEvent :: Timestamp -> SomeException -> Event+exceptionEvent time err =+  Event "exception" time [Attribute SemConv.exceptionMessage (AttrText (T.pack (displayException err)))]
+ src/Effectful/Tracing/Internal/Types.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.Internal.Types+-- Description : Core span data model shared by all interpreters.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+-- Stability   : internal+--+-- The effect-system-independent data types that every interpreter shares:+-- trace flags, trace state, span context, and the immutable record of a+-- completed 't:Span'. These deliberately do not depend on @effectful@ or+-- @hs-opentelemetry@; translation to OpenTelemetry happens in the bridge.+module Effectful.Tracing.Internal.Types+  ( -- * Trace flags+    TraceFlags (..)+  , defaultTraceFlags+  , isSampled+  , setSampled++    -- * Trace state+  , TraceState+  , emptyTraceState+  , insertTraceState+  , lookupTraceState+  , traceStateEntries+  , traceStateToHeader+  , traceStateFromHeader+  , maxTraceStateEntries++    -- * Span context+  , SpanContext (..)++    -- * Span metadata+  , SpanKind (..)+  , SpanStatus (..)+  , Event (..)+  , Link (..)++    -- * Completed span+  , Span (..)+  ) where++import Data.Bits (clearBit, setBit, testBit)+import Data.Char (isAsciiLower, isDigit, ord)+import Data.Maybe (mapMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Word (Word8)++import Effectful.Tracing.Attribute (Attribute)+import Effectful.Tracing.Internal.Clock (Timestamp)+import Effectful.Tracing.Internal.Ids (SpanId, TraceId)++-- | W3C trace flags. Only bit 0 (@sampled@) currently has a defined meaning;+-- the remaining bits are reserved and are preserved across round-trips.+newtype TraceFlags = TraceFlags Word8+  deriving (Eq, Ord, Show)++-- | Trace flags with all bits clear (not sampled).+defaultTraceFlags :: TraceFlags+defaultTraceFlags = TraceFlags 0++-- | Whether the @sampled@ bit is set.+isSampled :: TraceFlags -> Bool+isSampled (TraceFlags w) = testBit w 0++-- | Set or clear the @sampled@ bit, leaving the reserved bits untouched.+setSampled :: Bool -> TraceFlags -> TraceFlags+setSampled True (TraceFlags w) = TraceFlags (setBit w 0)+setSampled False (TraceFlags w) = TraceFlags (clearBit w 0)++-- | W3C @tracestate@: an ordered list of key/value pairs, most-recently-mutated+-- first, with at most 'maxTraceStateEntries' entries. Construct it through+-- 'emptyTraceState' and 'insertTraceState' (which validate keys and values) or+-- parse it with 'traceStateFromHeader'.+newtype TraceState = TraceState [(Text, Text)]+  deriving (Eq, Show)++-- | The maximum number of entries a 't:TraceState' may hold (32, per the W3C+-- spec).+maxTraceStateEntries :: Int+maxTraceStateEntries = 32++-- | An empty trace state.+emptyTraceState :: TraceState+emptyTraceState = TraceState []++-- | The entries of a trace state, in order (most-recently-mutated first).+traceStateEntries :: TraceState -> [(Text, Text)]+traceStateEntries (TraceState entries) = entries++-- | Insert or update a key, moving it to the head (most recent). Returns+-- 'Nothing' if the key or value is invalid, or if adding a new key would exceed+-- 'maxTraceStateEntries'.+insertTraceState :: Text -> Text -> TraceState -> Maybe TraceState+insertTraceState key value (TraceState entries)+  | not (isValidKey key) = Nothing+  | not (isValidValue value) = Nothing+  | length without >= maxTraceStateEntries = Nothing+  | otherwise = Just (TraceState ((key, value) : without))+  where+    without = filter ((/= key) . fst) entries++-- | Look up a key's value.+lookupTraceState :: Text -> TraceState -> Maybe Text+lookupTraceState key (TraceState entries) = lookup key entries++-- | Serialize to a @tracestate@ header value.+traceStateToHeader :: TraceState -> Text+traceStateToHeader (TraceState entries) =+  T.intercalate "," [key <> "=" <> value | (key, value) <- entries]++-- | Parse a @tracestate@ header value. Total: malformed members are dropped+-- (per the W3C resilience guidance), duplicate keys keep their first+-- occurrence, and the result is capped at 'maxTraceStateEntries'.+traceStateFromHeader :: Text -> TraceState+traceStateFromHeader header =+  TraceState (take maxTraceStateEntries (dedupe (mapMaybe parseMember members)))+  where+    members = T.splitOn "," header++    parseMember member =+      let trimmed = T.strip member+          (key, rest) = T.breakOn "=" trimmed+       in case T.stripPrefix "=" rest of+            Just value | isValidKey key && isValidValue value -> Just (key, value)+            _ -> Nothing++    dedupe = go []+      where+        go _ [] = []+        go seen (kv@(key, _) : rest)+          | key `elem` seen = go seen rest+          | otherwise = kv : go (key : seen) rest++-- | Whether a string is a valid @tracestate@ key. This validates a practical+-- subset of the W3C grammar: a non-empty, at-most-256-character string of+-- @[a-z0-9_\-*\/\@]@ beginning with a lowercase letter or digit.+isValidKey :: Text -> Bool+isValidKey key =+  not (T.null key)+    && T.length key <= 256+    && isKeyStart (T.head key)+    && T.all isKeyChar key+  where+    isKeyStart c = isAsciiLower c || isDigit c+    isKeyChar c = isAsciiLower c || isDigit c || c `elem` ['_', '-', '*', '/', '@']++-- | Whether a string is a valid @tracestate@ value: non-empty, at most 256+-- printable ASCII characters excluding comma and equals, with no trailing+-- space.+isValidValue :: Text -> Bool+isValidValue value =+  not (T.null value)+    && T.length value <= 256+    && T.all isValueChar value+    && T.last value /= ' '+  where+    isValueChar c =+      let o = ord c+       in o >= 0x20 && o <= 0x7E && c /= ',' && c /= '='++-- | The identity of a span and the trace it belongs to, as propagated in-band+-- and across process boundaries.+data SpanContext = SpanContext+  { spanContextTraceId :: !TraceId+  , spanContextSpanId :: !SpanId+  , spanContextTraceFlags :: !TraceFlags+  , spanContextTraceState :: !TraceState+  , spanContextIsRemote :: !Bool+  }+  deriving (Eq, Show)++-- | The role a span plays in a trace, per OpenTelemetry.+data SpanKind+  = Internal+  | Server+  | Client+  | Producer+  | Consumer+  deriving (Eq, Show, Enum, Bounded)++-- | A span's status. 'Unset' is the default; 'Error' carries a description.+data SpanStatus+  = Unset+  | Ok+  | Error !Text+  deriving (Eq, Show)++-- | A timestamped, named occurrence within a span.+data Event = Event+  { eventName :: !Text+  , eventTime :: !Timestamp+  , eventAttributes :: ![Attribute]+  }+  deriving (Eq, Show)++-- | A reference from this span to another span (possibly in another trace).+data Link = Link+  { linkContext :: !SpanContext+  , linkAttributes :: ![Attribute]+  }+  deriving (Eq, Show)++-- | The immutable record of a completed span. This is the value that crosses+-- the boundary into an interpreter for capture or export. The+-- mutable-during-construction representation lives in the interpreter layer.+data Span = Span+  { spanContext :: !SpanContext+  , spanParentContext :: !(Maybe SpanContext)+  , spanName :: !Text+  , spanKind :: !SpanKind+  , spanStartTime :: !Timestamp+  , spanEndTime :: !Timestamp+  , spanAttributes :: ![Attribute]+  , spanEvents :: ![Event]+  , spanLinks :: ![Link]+  , spanStatus :: !SpanStatus+  }+  deriving (Eq, Show)
+ src/Effectful/Tracing/Interpreter/InMemory.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE DataKinds #-}++-- |+-- Module      : Effectful.Tracing.Interpreter.InMemory+-- Description : An interpreter that captures completed spans in memory.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+-- Stability   : experimental+--+-- 'runTracerInMemory' captures every completed 't:Span' into a shared buffer so+-- tests can assert on what a traced computation produced. It is the workhorse+-- for testing user code that uses 'Tracer', and the reference against which the+-- later interpreters are tested.+--+-- == How to test traced code+--+-- > import Effectful (runEff)+-- > import Effectful.Tracing+-- > import Effectful.Tracing.Interpreter.InMemory+-- >+-- > test = do+-- >   captured <- newCapturedSpans+-- >   _ <- runEff . runTracerInMemory captured $+-- >     withSpan "outer" (withSpan "inner" (pure ()))+-- >   spans <- readCapturedSpans captured+-- >   -- inner closes before outer, so it is captured first:+-- >   let Just inner = findSpan "inner" spans+-- >       Just outer = findSpan "outer" spans+-- >   pure (childrenOf outer spans == [inner])+--+-- == Design+--+-- The span lifecycle (lexical active span, finalize-exactly-once under+-- 'Effectful.Exception.generalBracket') is shared with the other span-opening interpreters and+-- lives in "Effectful.Tracing.Internal.Live". This module supplies only the+-- sink: append each completed span to a shared, write-only capture buffer.+module Effectful.Tracing.Interpreter.InMemory+  ( -- * Capturing spans+    CapturedSpans+  , newCapturedSpans+  , readCapturedSpans+  , runTracerInMemory+  , runTracerInMemoryWith+  , runTracerInMemoryWithLimits++    -- * Querying captured spans+  , findSpan+  , childrenOf+  , rootSpans+  ) where++import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVarIO)+import Control.Monad.IO.Class (liftIO)+import Data.Foldable (toList)+import Data.List (find)+import Data.Maybe (isNothing)+import Data.Sequence (Seq, (|>))+import Data.Sequence qualified as Seq+import Data.Text (Text)++import Effectful (Eff, IOE, (:>))++import Effectful.Tracing.Effect (Tracer)+import Effectful.Tracing.Internal.Live (interpretTracer)+import Effectful.Tracing.Sampler (Sampler, alwaysOn)+import Effectful.Tracing.SpanLimits (SpanLimits, defaultSpanLimits)+import Effectful.Tracing.Internal.Types+  ( Span (spanContext, spanName, spanParentContext)+  , SpanContext (spanContextSpanId, spanContextTraceId)+  )++-- | A buffer of completed spans, shared across threads. Created with+-- 'newCapturedSpans' and read with 'readCapturedSpans'.+newtype CapturedSpans = CapturedSpans (TVar (Seq Span))++-- | Allocate an empty capture buffer.+newCapturedSpans :: IOE :> es => Eff es CapturedSpans+newCapturedSpans = liftIO (CapturedSpans <$> newTVarIO Seq.empty)++-- | Read the spans captured so far, in completion order (a child span, which+-- closes before its parent, appears before the parent).+readCapturedSpans :: IOE :> es => CapturedSpans -> Eff es [Span]+readCapturedSpans (CapturedSpans buffer) = liftIO (toList <$> readTVarIO buffer)++-- | Capture completed spans into the given buffer, sampling every span+-- ('alwaysOn'). Scoped actions run inside a fresh child span; emit operations+-- annotate the lexically-current span and are silent no-ops when there is none.+runTracerInMemory+  :: IOE :> es+  => CapturedSpans+  -> Eff (Tracer : es) a+  -> Eff es a+runTracerInMemory = runTracerInMemoryWith alwaysOn++-- | Like 'runTracerInMemory', but with a caller-chosen 't:Sampler'. There is no+-- export step here, so 'Effectful.Tracing.Sampler.RecordOnly' and 'Effectful.Tracing.Sampler.RecordAndSample' both capture the+-- span; only 'Effectful.Tracing.Sampler.Drop' omits it. Uses 'defaultSpanLimits';+-- 'runTracerInMemoryWithLimits' overrides them.+runTracerInMemoryWith+  :: IOE :> es+  => Sampler+  -> CapturedSpans+  -> Eff (Tracer : es) a+  -> Eff es a+runTracerInMemoryWith = runTracerInMemoryWithLimits defaultSpanLimits++-- | Like 'runTracerInMemoryWith', but with caller-chosen 'SpanLimits' as well as+-- a sampler. Pass 'Effectful.Tracing.SpanLimits.unlimitedSpanLimits' to capture+-- everything a computation emitted, or a tightened 'SpanLimits' to exercise the+-- caps in a test.+runTracerInMemoryWithLimits+  :: IOE :> es+  => SpanLimits+  -> Sampler+  -> CapturedSpans+  -> Eff (Tracer : es) a+  -> Eff es a+runTracerInMemoryWithLimits limits sampler (CapturedSpans buffer) =+  interpretTracer limits sampler (\completed -> atomically (modifyTVar' buffer (|> completed)))++-- | Find the first captured span with the given name.+findSpan :: Text -> [Span] -> Maybe Span+findSpan name = find ((== name) . spanName)++-- | The captured spans whose parent is the given span.+childrenOf :: Span -> [Span] -> [Span]+childrenOf parent = filter isChild+  where+    parentContext = spanContext parent+    isChild s = case spanParentContext s of+      Just pc ->+        spanContextSpanId pc == spanContextSpanId parentContext+          && spanContextTraceId pc == spanContextTraceId parentContext+      Nothing -> False++-- | The captured spans that have no parent.+rootSpans :: [Span] -> [Span]+rootSpans = filter (isNothing . spanParentContext)
+ src/Effectful/Tracing/Interpreter/NoOp.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}++-- |+-- Module      : Effectful.Tracing.Interpreter.NoOp+-- Description : An interpreter that discards all tracing.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+-- Stability   : experimental+--+-- 'runTracerNoOp' satisfies the 'Tracer' effect with no observable effect:+-- scoped actions run unchanged, every emit operation is silently dropped, and+-- there is never an active span. It is the interpreter to reach for when a+-- component requires @Tracer@ but the caller does not want tracing (tests,+-- benchmarks, or production paths where tracing is disabled), and it is the+-- baseline against which the library's near-zero-overhead claim is measured.+module Effectful.Tracing.Interpreter.NoOp+  ( runTracerNoOp+  ) where++import Effectful (Eff)+import Effectful.Dispatch.Dynamic (interpret, localSeqUnlift)++import Effectful.Tracing.Effect+  ( Tracer+      ( AddAttribute+      , AddAttributes+      , AddEvent+      , GetActiveSpan+      , RecordException+      , SetStatus+      , UpdateName+      , WithLinkedRoot+      , WithRemoteParent+      , WithSpan+      )+  )++-- | Discharge the 'Tracer' effect by doing nothing. 'Effectful.Tracing.Effect.withSpan' runs its body in+-- the current scope (no span is created), the emit operations are no-ops, and+-- 'Effectful.Tracing.Effect.getActiveSpan' returns 'Nothing'. Exceptions thrown inside a scoped action+-- propagate unchanged.+--+-- > runEff . runTracerNoOp $ do+-- >   withSpan "outer" $ addAttribute "ignored" (1 :: Int) >> pure ()+runTracerNoOp :: Eff (Tracer : es) a -> Eff es a+runTracerNoOp = interpret $ \env -> \case+  WithSpan _ _ action -> localSeqUnlift env (\unlift -> unlift action)+  WithLinkedRoot _ action -> localSeqUnlift env (\unlift -> unlift action)+  WithRemoteParent _ action -> localSeqUnlift env (\unlift -> unlift action)+  AddAttribute _ _ -> pure ()+  AddAttributes _ -> pure ()+  AddEvent _ _ -> pure ()+  RecordException _ -> pure ()+  SetStatus _ -> pure ()+  UpdateName _ -> pure ()+  GetActiveSpan -> pure Nothing
+ src/Effectful/Tracing/Interpreter/OpenTelemetry.hs view
@@ -0,0 +1,275 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}++-- |+-- Module      : Effectful.Tracing.Interpreter.OpenTelemetry+-- Description : Export spans to an OpenTelemetry SDK via @hs-opentelemetry@.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+-- Stability   : experimental+--+-- 'runTracerOTel' interprets the 'Tracer' effect by opening real spans (the+-- shared lifecycle in "Effectful.Tracing.Internal.Live") and, as each span+-- completes, translating it into an @hs-opentelemetry@ 'OTel.ImmutableSpan' and+-- handing it to one or more OpenTelemetry 'SpanProcessor's. This is the bridge+-- to real export: pair it with an exporter (OTLP over HTTP\/gRPC, or a file+-- exporter for testing) and a processor (simple or batch) from+-- @hs-opentelemetry-sdk@.+--+-- __Identity stays ours.__ The library mints its own trace and span ids and runs+-- its own 't:Sampler' before OpenTelemetry sees the span; the translation copies+-- those ids verbatim into the exported span. This keeps the ids consistent with+-- what "Effectful.Tracing.Propagation" injects on the wire, which would not hold+-- if we delegated id generation to OpenTelemetry's @createSpan@.+--+-- __Interop boundary.__ We deliberately do not thread OpenTelemetry's in-process+-- @Context@. Mixing this interpreter with an existing @hs-opentelemetry@+-- instrumented library (for example upstream WAI or @http-client@+-- instrumentation that reads\/writes OpenTelemetry's @Context@) will not+-- automatically nest spans across that boundary: the two context worlds are+-- separate. Use this library's own instrumentation helpers, or bridge the two+-- worlds explicitly at the seam. The design note expands on this.+module Effectful.Tracing.Interpreter.OpenTelemetry+  ( OtelConfig (..)+  , runTracerOTel++    -- * Translation (exposed for testing)+  , toImmutableSpan+  ) where++import Data.IORef (newIORef)+import Data.Text (Text)+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)+import Data.Vector qualified as V++-- @foldl'@ moved into Prelude in base-4.20 (GHC 9.10); import it explicitly on+-- older bases so the package still builds on GHC 9.6 / 9.8.+#if !MIN_VERSION_base(4,20,0)+import Data.List (foldl')+#endif++import System.Clock (TimeSpec (TimeSpec))++import OpenTelemetry.Attributes qualified as OtelAttr+import OpenTelemetry.Common qualified as OtelCommon+import OpenTelemetry.Processor.Span (SpanProcessor, spanProcessorForceFlush, spanProcessorOnEnd)+import OpenTelemetry.Trace.Core+  ( InstrumentationLibrary+  , TracerOptions+  , tracerOptions+  )+import OpenTelemetry.Trace.Core qualified as OTel+import OpenTelemetry.Trace.Id qualified as OtelId+import OpenTelemetry.Trace.TraceState qualified as OtelTS+import OpenTelemetry.Util qualified as OtelUtil++import Effectful (Eff, IOE, (:>))+import Effectful.Exception (finally)+import Control.Monad.IO.Class (liftIO)++import Effectful.Tracing.Attribute (Attribute (Attribute), AttributeValue (..))+import Effectful.Tracing.Effect (Tracer)+import Effectful.Tracing.Internal.Clock (Timestamp (Timestamp))+import Effectful.Tracing.Internal.Ids (SpanId (SpanId), TraceId (TraceId))+import Effectful.Tracing.Internal.Live (interpretTracer)+import Effectful.Tracing.Internal.Types+  ( Event (Event)+  , Link (Link)+  , Span (..)+  , SpanContext (..)+  , SpanKind (Client, Consumer, Internal, Producer, Server)+  , SpanStatus (Error, Ok, Unset)+  , TraceFlags (TraceFlags)+  , TraceState+  , traceStateEntries+  )+import Effectful.Tracing.Sampler (Sampler)+import Effectful.Tracing.SpanLimits (SpanLimits)++-- | How to export spans to OpenTelemetry.+--+-- The library cannot reach the processors registered inside a+-- @TracerProvider@ (the SDK does not expose them), so the processors are passed+-- here directly. Build them from @hs-opentelemetry-sdk@ (for example+-- @simpleProcessor@ or @batchProcessor@ wrapping an OTLP or file exporter) and+-- supply the same instrumentation scope you would give the SDK. Completed spans+-- are handed to every processor in the list.+data OtelConfig = OtelConfig+  { spanProcessors :: ![SpanProcessor]+  -- ^ Processors that receive each completed span. Lifecycle (shutdown) is the+  -- caller's responsibility; 'runTracerOTel' force-flushes them when its scope+  -- ends.+  , instrumentationScope :: !InstrumentationLibrary+  -- ^ Names the instrumentation (library name and version). Exporters group+  -- spans by this scope.+  , sampler :: !Sampler+  -- ^ Our sampler, consulted once per span before OpenTelemetry sees it.+  , spanLimits :: !SpanLimits+  -- ^ The per-span caps applied as spans record and finalize, before they reach+  -- the processors. Use 'Effectful.Tracing.SpanLimits.defaultSpanLimits' to match+  -- the OpenTelemetry SDK defaults.+  }++-- | Interpret 'Tracer' by exporting every recorded span to the configured+-- OpenTelemetry processors. Spans dropped by the 't:Sampler' are not exported;+-- 'Effectful.Tracing.Sampler.RecordOnly' and 'Effectful.Tracing.Sampler.RecordAndSample' both are (the @sampled@ flag distinguishes+-- them on the wire). When the scope ends, every processor is force-flushed so+-- buffered spans are not lost.+--+-- > main :: IO ()+-- > main = do+-- >   exporter  <- loadExporterEnvironmentVariables >>= otlpExporter+-- >   processor <- batchProcessor batchTimeoutConfig exporter+-- >   let config = OtelConfig [processor] "my-service" alwaysOn defaultSpanLimits+-- >   runEff . runTracerOTel config $ withSpan "request" (pure ())+runTracerOTel+  :: IOE :> es+  => OtelConfig+  -> Eff (Tracer : es) a+  -> Eff es a+runTracerOTel config action = do+  -- A Tracer is required for the ImmutableSpan's tracer field (exporters read+  -- its instrumentation scope to group spans). It needs a TracerProvider, but+  -- not its processors: we feed the processors ourselves, so an empty provider+  -- suffices to carry the scope.+  provider <- liftIO (OTel.createTracerProvider [] OTel.emptyTracerProviderOptions)+  let tracer = OTel.makeTracer provider (instrumentationScope config) emptyTracerOptions+      processors = spanProcessors config+  interpretTracer (spanLimits config) (sampler config) (export tracer processors) action+    `finally` liftIO (mapM_ spanProcessorForceFlush processors)++-- | 'tracerOptions' with no overrides.+emptyTracerOptions :: TracerOptions+emptyTracerOptions = tracerOptions++-- | Translate a completed span and hand it to each processor. A span whose ids+-- are malformed (impossible for spans this library mints, since it always uses+-- 16- and 8-byte ids) is skipped rather than crashing the closing thread.+export :: OTel.Tracer -> [SpanProcessor] -> Span -> IO ()+export tracer processors completed =+  case toImmutableSpan tracer completed of+    Left _ -> pure ()+    Right immutable -> do+      ref <- newIORef immutable+      mapM_ (`spanProcessorOnEnd` ref) processors++-- | Translate one of our completed 't:Span's into an @hs-opentelemetry@+-- 'OTel.ImmutableSpan'. Returns 'Left' only if a trace or span id is not the+-- byte length OpenTelemetry requires, which cannot happen for spans this library+-- produces; the 'Either' makes the translation total and gives the round-trip+-- tests something to assert on.+toImmutableSpan :: OTel.Tracer -> Span -> Either String OTel.ImmutableSpan+toImmutableSpan tracer completed = do+  context <- toOtelContext (spanContext completed)+  parentContext <- traverse toOtelContext (spanParentContext completed)+  links <- traverse toOtelLink (spanLinks completed)+  pure+    OTel.ImmutableSpan+      { OTel.spanName = spanName completed+      , OTel.spanParent = OTel.wrapSpanContext <$> parentContext+      , OTel.spanContext = context+      , OTel.spanKind = toOtelKind (spanKind completed)+      , OTel.spanStart = toOtelTimestamp (spanStartTime completed)+      , OTel.spanEnd = Just (toOtelTimestamp (spanEndTime completed))+      , OTel.spanAttributes = toOtelAttributes (spanAttributes completed)+      , OTel.spanLinks = toCollection links+      , OTel.spanEvents = toCollection (map toOtelEvent (spanEvents completed))+      , OTel.spanStatus = toOtelStatus (spanStatus completed)+      , OTel.spanTracer = tracer+      }++-- | Translate a span context, copying our ids and flags verbatim.+toOtelContext :: SpanContext -> Either String OTel.SpanContext+toOtelContext context = do+  let TraceId traceBytes = spanContextTraceId context+      SpanId spanBytes = spanContextSpanId context+  traceId <- OtelId.bytesToTraceId traceBytes+  spanId <- OtelId.bytesToSpanId spanBytes+  pure+    OTel.SpanContext+      { OTel.traceFlags = toOtelFlags (spanContextTraceFlags context)+      , OTel.isRemote = spanContextIsRemote context+      , OTel.traceId = traceId+      , OTel.spanId = spanId+      , OTel.traceState = toOtelTraceState (spanContextTraceState context)+      }++-- | The only flag is @sampled@, so the byte maps across directly.+toOtelFlags :: TraceFlags -> OTel.TraceFlags+toOtelFlags (TraceFlags w) = OTel.traceFlagsFromWord8 w++-- | Rebuild the W3C trace state in OpenTelemetry's representation, preserving+-- the most-recently-mutated-first ordering ('OtelTS.insert' prepends, so folding+-- from the oldest entry leaves the newest first).+toOtelTraceState :: TraceState -> OtelTS.TraceState+toOtelTraceState traceState =+  foldr+    (\(key, value) -> OtelTS.insert (OtelTS.Key key) (OtelTS.Value value))+    OtelTS.empty+    (traceStateEntries traceState)++toOtelKind :: SpanKind -> OTel.SpanKind+toOtelKind = \case+  Internal -> OTel.Internal+  Server -> OTel.Server+  Client -> OTel.Client+  Producer -> OTel.Producer+  Consumer -> OTel.Consumer++toOtelStatus :: SpanStatus -> OTel.SpanStatus+toOtelStatus = \case+  Unset -> OTel.Unset+  Ok -> OTel.Ok+  Error message -> OTel.Error message++-- | Our 't:Timestamp' is a 'Data.Time.Clock.UTCTime'; OpenTelemetry's is a @TimeSpec@ split into+-- whole seconds and nanoseconds since the Unix epoch.+toOtelTimestamp :: Timestamp -> OtelCommon.Timestamp+toOtelTimestamp (Timestamp utc) =+  let nanos = floor (toRational (utcTimeToPOSIXSeconds utc) * 1_000_000_000) :: Integer+      (secs, nsec) = nanos `divMod` 1_000_000_000+   in OtelCommon.Timestamp (TimeSpec (fromInteger secs) (fromInteger nsec))++toOtelEvent :: Event -> OTel.Event+toOtelEvent (Event name time attrs) =+  OTel.Event+    { OTel.eventName = name+    , OTel.eventAttributes = toOtelAttributes attrs+    , OTel.eventTimestamp = toOtelTimestamp time+    }++toOtelLink :: Link -> Either String OTel.Link+toOtelLink (Link context attrs) = do+  otelContext <- toOtelContext context+  pure+    OTel.Link+      { OTel.frozenLinkContext = otelContext+      , OTel.frozenLinkAttributes = toOtelAttributes attrs+      }++-- | Build OpenTelemetry 'OtelAttr.Attributes' from our attribute list. The+-- limits are not applied (the library does not impose its own caps); the SDK's+-- span limits still apply downstream.+toOtelAttributes :: [Attribute] -> OtelAttr.Attributes+toOtelAttributes attrs =+  OtelAttr.unsafeAttributesFromListIgnoringLimits (map toOtelAttribute attrs)++toOtelAttribute :: Attribute -> (Text, OTel.Attribute)+toOtelAttribute (Attribute key value) = (key, toOtelAttributeValue value)++toOtelAttributeValue :: AttributeValue -> OTel.Attribute+toOtelAttributeValue = \case+  AttrText t -> OTel.AttributeValue (OTel.TextAttribute t)+  AttrBool b -> OTel.AttributeValue (OTel.BoolAttribute b)+  AttrInt i -> OTel.AttributeValue (OTel.IntAttribute i)+  AttrDouble d -> OTel.AttributeValue (OTel.DoubleAttribute d)+  AttrTextArray xs -> OTel.AttributeArray (map OTel.TextAttribute (V.toList xs))+  AttrBoolArray xs -> OTel.AttributeArray (map OTel.BoolAttribute (V.toList xs))+  AttrIntArray xs -> OTel.AttributeArray (map OTel.IntAttribute (V.toList xs))+  AttrDoubleArray xs -> OTel.AttributeArray (map OTel.DoubleAttribute (V.toList xs))++-- | Pour a list into an append-only bounded collection. Our spans are already+-- bounded by the caller, so the cap is generous.+toCollection :: [a] -> OtelUtil.AppendOnlyBoundedCollection a+toCollection = foldl' OtelUtil.appendToBoundedCollection (OtelUtil.emptyAppendOnlyBoundedCollection 1024)
+ src/Effectful/Tracing/Interpreter/PrettyPrint.hs view
@@ -0,0 +1,357 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.Interpreter.PrettyPrint+-- Description : A development-time interpreter that prints traces as a tree.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+-- Stability   : experimental+--+-- 'runTracerPretty' writes a human-readable, tree-shaped rendering of each+-- finished trace to a 'Handle' (typically 'System.IO.stderr'). It is meant for+-- local development and debugging, not production export.+--+-- > import Effectful (runEff)+-- > import Effectful.Tracing+-- > import Effectful.Tracing.Interpreter.PrettyPrint+-- > import System.IO (stderr)+-- >+-- > main :: IO ()+-- > main =+-- >   runEff . runTracerPretty (defaultPrettyPrintConfig stderr) $+-- >     withSpan "handle_request" $ do+-- >       addAttribute "user.id" ("u123" :: Text)+-- >       withSpan "load_user" (pure ())+--+-- produces something like:+--+-- > trace 4f1a9c.. (1ms)+-- > └─ handle_request (1ms) status=Unset+-- >    user.id=u123+-- >    └─ load_user (0ms) status=Unset+--+-- == Why a trace is buffered until its root closes+--+-- Spans complete out of order: a parent finishes after its children, so the+-- tree is not known until the root closes. The interpreter accumulates the+-- spans of each in-flight trace in a @'TVar' ('Map' 't:TraceId' [Span])@ and+-- renders the whole tree the moment the root (a span with no parent) closes,+-- then drops that trace from the map. The lexical span model guarantees the+-- root closes last, so by then every descendant has been collected.+--+-- The lifecycle itself (lexical active span, finalize-exactly-once under+-- 'Effectful.Exception.generalBracket') is shared with the in-memory interpreter and lives in+-- "Effectful.Tracing.Internal.Live"; this module supplies the+-- buffer-and-render sink and the pure 'renderTrace' formatter.+module Effectful.Tracing.Interpreter.PrettyPrint+  ( -- * Interpreter+    runTracerPretty+  , runTracerPrettyWith++    -- * Configuration+  , PrettyPrintConfig (..)+  , defaultPrettyPrintConfig+  , TimeFormat (..)++    -- * Pure rendering+  , renderTrace+  ) where++import Control.Concurrent.STM (TVar, atomically, newTVarIO, readTVar, writeTVar)+import Control.Monad.IO.Class (liftIO)+import Data.Foldable (toList)+import Data.List (sortOn)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (isNothing)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.IO qualified as T+import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime)+import Data.Time.Format (defaultTimeLocale, formatTime)+import Numeric (showFFloat)+import System.IO (Handle)++import Effectful (Eff, IOE, (:>))++import Effectful.Tracing.Attribute+  ( Attribute (Attribute)+  , AttributeValue (..)+  )+import Effectful.Tracing.Effect (Tracer)+import Effectful.Tracing.Sampler (Sampler, alwaysOn)+import Effectful.Tracing.SpanLimits (SpanLimits, defaultSpanLimits)+import Effectful.Tracing.Internal.Clock (Timestamp (Timestamp))+import Effectful.Tracing.Internal.Ids (SpanId, TraceId, traceIdToHex)+import Effectful.Tracing.Internal.Live (interpretTracer)+import Effectful.Tracing.Internal.Types+  ( Event (eventName, eventTime)+  , Span (..)+  , SpanContext (spanContextSpanId, spanContextTraceId)+  , SpanKind (Internal)+  , SpanStatus (Error, Ok, Unset)+  )++-- | How a span's time is shown in the rendered tree.+data TimeFormat+  = -- | Wall-clock start time plus duration, e.g. @14:03:11.024 (78ms)@.+    Absolute+  | -- | Offset from the start of the trace plus duration, e.g. @+12ms (8ms)@.+    RelativeToTraceStart+  | -- | Duration only, e.g. @(78ms)@. The default.+    DurationOnly+  deriving (Eq, Show)++-- | How 'runTracerPretty' renders traces.+data PrettyPrintConfig = PrettyPrintConfig+  { handle :: !Handle+  -- ^ Where rendered traces are written. 'renderTrace' ignores this field.+  , useColor :: !Bool+  -- ^ Emit ANSI color escapes. There is no auto-detection here; a caller that+  -- wants \"color when attached to a terminal\" should set this from+  -- @'System.IO.hIsTerminalDevice' h@.+  , showAttributes :: !Bool+  -- ^ Print each span's attributes beneath it.+  , showEvents :: !Bool+  -- ^ Print each span's events beneath it.+  , timeFormat :: !TimeFormat+  -- ^ How span times are shown.+  , sampler :: !Sampler+  -- ^ Which spans to print. The \"export\" step here is printing, so 'Effectful.Tracing.Sampler.Drop'+  -- omits a span and both other decisions print it. 'renderTrace' ignores this+  -- field.+  , spanLimits :: !SpanLimits+  -- ^ The per-span caps applied as spans record and finalize. 'renderTrace'+  -- ignores this field.+  }++-- | A reasonable default: no color, attributes and events shown, durations+-- only. Pass the 'Handle' to write to (e.g. 'System.IO.stderr').+defaultPrettyPrintConfig :: Handle -> PrettyPrintConfig+defaultPrettyPrintConfig h =+  PrettyPrintConfig+    { handle = h+    , useColor = False+    , showAttributes = True+    , showEvents = True+    , timeFormat = DurationOnly+    , sampler = alwaysOn+    , spanLimits = defaultSpanLimits+    }++-- | Interpret 'Tracer' by rendering each finished trace to the configured+-- handle as a tree. Each trace is printed once, when its root span closes.+runTracerPretty+  :: IOE :> es+  => PrettyPrintConfig+  -> Eff (Tracer : es) a+  -> Eff es a+runTracerPretty config eff = do+  traces <- liftIO (newTVarIO Map.empty)+  runTracerPrettyWith traces config eff++-- | Like 'runTracerPretty', but render through a caller-supplied buffer of+-- in-flight traces rather than allocating a fresh one internally. A trace is+-- accumulated in the buffer and removed the instant its root span closes (when+-- the whole tree is rendered), so once every root has closed the buffer holds+-- nothing.+--+-- This exists mainly as a testing and diagnostic seam: a caller can read the+-- @TVar@ to confirm the buffer drains to empty, that is, that no in-flight trace+-- is retained after its root closes. Ordinary callers want 'runTracerPretty',+-- which manages the buffer for you.+runTracerPrettyWith+  :: IOE :> es+  => TVar (Map TraceId [Span])+  -- ^ The in-flight trace buffer, keyed by trace id. Pass a freshly-created+  -- empty buffer (a @TVar@ holding the empty @Map@) unless you mean to observe+  -- it.+  -> PrettyPrintConfig+  -> Eff (Tracer : es) a+  -> Eff es a+runTracerPrettyWith traces config =+  interpretTracer (spanLimits config) (sampler config) (flushOnRoot config traces)++-- | Accumulate a completed span under its trace id; when the span is a root,+-- pop the whole trace and render it.+flushOnRoot :: PrettyPrintConfig -> TVar (Map TraceId [Span]) -> Span -> IO ()+flushOnRoot config traces completed = do+  let traceId = spanContextTraceId (spanContext completed)+  finished <- atomically $ do+    pending <- readTVar traces+    let gathered = completed : Map.findWithDefault [] traceId pending+    -- Force the rebuilt map before writing it back so the 'TVar' holds an+    -- evaluated map rather than a thunk capturing the previous one.+    if isNothing (spanParentContext completed)+      then Just gathered <$ (writeTVar traces $! Map.delete traceId pending)+      else Nothing <$ (writeTVar traces $! Map.insert traceId gathered pending)+  case finished of+    Just spans -> T.hPutStr (handle config) (renderTrace config spans)+    Nothing -> pure ()++-- | Render the spans of a single trace as a tree, in the layout described by+-- the module documentation. The input may be in any order and is expected to+-- belong to one trace; siblings are ordered by start time. The 'handle' field+-- of the config is ignored. Pure, so it is the unit of golden testing.+renderTrace :: PrettyPrintConfig -> [Span] -> Text+renderTrace config spans = case spans of+  [] -> ""+  (representative : _) ->+    let traceId = spanContextTraceId (spanContext representative)+        traceStart = minimum (map spanStartTime spans)+        traceEnd = maximum (map spanEndTime spans)+        header =+          "trace "+            <> traceIdToHex traceId+            <> " ("+            <> formatDuration (durationBetween traceStart traceEnd)+            <> ")"+        roots = sortOn spanStartTime (filter isRoot spans)+     in T.unlines (header : renderForest config traceStart "" roots spans)+  where+    presentIds :: Set.Set SpanId+    presentIds = Set.fromList (map (spanContextSpanId . spanContext) spans)++    isRoot s = case spanParentContext s of+      Nothing -> True+      Just pc -> not (spanContextSpanId pc `Set.member` presentIds)++-- | Render a list of sibling spans, each with its subtree, under a shared+-- indentation prefix.+renderForest :: PrettyPrintConfig -> Timestamp -> Text -> [Span] -> [Span] -> [Text]+renderForest config traceStart prefix nodes allSpans =+  concat+    [ renderNode config traceStart prefix (index == lastIndex) node allSpans+    | (index, node) <- zip [0 :: Int ..] nodes+    ]+  where+    lastIndex = length nodes - 1++-- | Render one span: its label line, then its detail lines (attributes,+-- events), then its children.+renderNode :: PrettyPrintConfig -> Timestamp -> Text -> Bool -> Span -> [Span] -> [Text]+renderNode config traceStart prefix isLast node allSpans =+  nodeLine : (details <> childLines)+  where+    connector = if isLast then "\x2514\x2500 " else "\x251C\x2500 "+    childPrefix = prefix <> if isLast then "   " else "\x2502  "+    nodeLine = prefix <> connector <> label config traceStart node+    details = map (childPrefix <>) (attributeLines config node <> eventLines config node)+    children = sortOn spanStartTime (childrenOfSpan node allSpans)+    childLines = renderForest config traceStart childPrefix children allSpans++-- | The spans whose direct parent is the given span.+childrenOfSpan :: Span -> [Span] -> [Span]+childrenOfSpan node = filter isChild+  where+    nodeId = spanContextSpanId (spanContext node)+    isChild s = (spanContextSpanId <$> spanParentContext s) == Just nodeId++-- | The single-line summary of a span: name, kind, time, and status.+label :: PrettyPrintConfig -> Timestamp -> Span -> Text+label config traceStart s =+  colorName config (spanName s)+    <> kindPart (spanKind s)+    <> " ("+    <> timePart config traceStart s+    <> ") status="+    <> colorStatus config (spanStatus s)+  where+    kindPart Internal = ""+    kindPart k = " [" <> T.toLower (T.pack (show k)) <> "]"++-- | The time portion of a span label, per the configured 'TimeFormat'.+timePart :: PrettyPrintConfig -> Timestamp -> Span -> Text+timePart config traceStart s = case timeFormat config of+  DurationOnly -> formatDuration spanDuration+  RelativeToTraceStart ->+    "+" <> formatDuration (durationBetween traceStart (spanStartTime s)) <> " " <> formatDuration spanDuration+  Absolute ->+    formatAbsolute (spanStartTime s) <> " " <> formatDuration spanDuration+  where+    spanDuration = durationBetween (spanStartTime s) (spanEndTime s)++attributeLines :: PrettyPrintConfig -> Span -> [Text]+attributeLines config s+  | showAttributes config = map (colorAttribute config . renderAttribute) (spanAttributes s)+  | otherwise = []++eventLines :: PrettyPrintConfig -> Span -> [Text]+eventLines config s+  | showEvents config = map renderEvent (spanEvents s)+  | otherwise = []+  where+    renderEvent e =+      colorEvent config $+        "event: "+          <> eventName e+          <> " @ +"+          <> formatDuration (durationBetween (spanStartTime s) (eventTime e))++renderAttribute :: Attribute -> Text+renderAttribute (Attribute key value) = key <> "=" <> renderAttributeValue value++renderAttributeValue :: AttributeValue -> Text+renderAttributeValue = \case+  AttrText t -> t+  AttrBool b -> renderBool b+  AttrInt i -> T.pack (show i)+  AttrDouble d -> T.pack (show d)+  AttrTextArray v -> renderArray id (toList v)+  AttrBoolArray v -> renderArray renderBool (toList v)+  AttrIntArray v -> renderArray (T.pack . show) (toList v)+  AttrDoubleArray v -> renderArray (T.pack . show) (toList v)+  where+    renderBool b = if b then "true" else "false"+    renderArray render xs = "[" <> T.intercalate ", " (map render xs) <> "]"++-- Time formatting -----------------------------------------------------------++durationBetween :: Timestamp -> Timestamp -> NominalDiffTime+durationBetween (Timestamp from) (Timestamp to) = diffUTCTime to from++-- | Format a duration with a unit chosen for readability: seconds when at least+-- a second, milliseconds otherwise (with one decimal place for sub-millisecond+-- durations so short spans are not all rendered as @0ms@).+formatDuration :: NominalDiffTime -> Text+formatDuration d+  | millis >= 1000 = fixed 2 (millis / 1000) <> "s"+  | millis >= 1 = fixed 0 millis <> "ms"+  | otherwise = fixed 1 millis <> "ms"+  where+    millis = realToFrac d * 1000 :: Double+    fixed places n = T.pack (showFFloat (Just places) n "")++formatAbsolute :: Timestamp -> Text+formatAbsolute (Timestamp t) = T.pack (formatTime defaultTimeLocale "%H:%M:%S%3Q" (t :: UTCTime))++-- Color ---------------------------------------------------------------------++colorName :: PrettyPrintConfig -> Text -> Text+colorName config = withColor config "1" -- bold++colorStatus :: PrettyPrintConfig -> SpanStatus -> Text+colorStatus config status = withColor config (statusColor status) (statusText status)+  where+    statusColor Ok = "32" -- green+    statusColor (Error _) = "31" -- red+    statusColor Unset = "90" -- dim+    statusText Unset = "Unset"+    statusText Ok = "Ok"+    statusText (Error msg) = "Error: " <> msg++colorAttribute :: PrettyPrintConfig -> Text -> Text+colorAttribute config = withColor config "90" -- dim++colorEvent :: PrettyPrintConfig -> Text -> Text+colorEvent config = withColor config "36" -- cyan++-- | Wrap text in an ANSI SGR escape when color is enabled, otherwise return it+-- unchanged.+withColor :: PrettyPrintConfig -> Text -> Text -> Text+withColor config code t+  | useColor config = "\ESC[" <> code <> "m" <> t <> "\ESC[0m"+  | otherwise = t
+ src/Effectful/Tracing/Log.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.Log+-- Description : Correlate log lines with the active trace and span.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+-- Stability   : experimental+--+-- The single most useful thing you can do with a trace and a log line is join+-- them: stamp every log record with the trace and span id that was active when+-- it was written, so a log search jumps straight to the trace and a trace view+-- links back to its logs. This module exposes the active span's identifiers for+-- exactly that, using the field names from the OpenTelemetry+-- <https://opentelemetry.io/docs/specs/otel/logs/ logs data model> (@trace_id@,+-- @span_id@, @trace_flags@).+--+-- It is deliberately framework-agnostic, in the same spirit as+-- "Effectful.Tracing.Testing": the accessors return plain 'Text' and+-- @[('Text', 'Text')]@ with no logging-library dependency, so they drop into+-- @co-log@, @katip@, @fast-logger@, @monad-logger@, or a bare @hPutStrLn@ the+-- same way.+--+-- > -- attach trace context to a structured log call+-- > logWithTrace :: (Tracer :> es, Logger :> es) => Text -> Eff es ()+-- > logWithTrace message = do+-- >   fields <- activeCorrelationFields+-- >   emit message fields+--+-- All accessors read the active span through the 'Tracer' effect, so they return+-- the empty / 'Nothing' case cleanly when no span is in scope (a startup log+-- line, say) rather than forcing the caller to special-case it.+module Effectful.Tracing.Log+  ( -- * Correlation context+    Correlation (..)+  , activeCorrelation++    -- * Log fields+  , correlationFields+  , activeCorrelationFields++    -- * Individual identifiers+  , activeTraceId+  , activeSpanId+  ) where++import Data.Text (Text)++import Effectful (Eff, (:>))++import Effectful.Tracing.Effect (Tracer, getActiveSpan)+import Effectful.Tracing.Internal.Ids (spanIdToHex, traceIdToHex)+import Effectful.Tracing.Internal.Types+  ( SpanContext (..)+  , isSampled+  )++-- | The identifiers needed to tie a log record to a trace: the active span's+-- trace id and span id (lower-case hex, the wire form), and whether the trace is+-- sampled. Built from the active 't:SpanContext'.+data Correlation = Correlation+  { correlationTraceId :: !Text+  -- ^ The 32-character hex trace id.+  , correlationSpanId :: !Text+  -- ^ The 16-character hex span id.+  , correlationSampled :: !Bool+  -- ^ Whether the trace is sampled (the @trace_flags@ low bit).+  }+  deriving (Eq, Show)++-- | The 'Correlation' for the active span, or 'Nothing' when no span is in+-- scope.+activeCorrelation :: Tracer :> es => Eff es (Maybe Correlation)+activeCorrelation = fmap toCorrelation <$> getActiveSpan+  where+    toCorrelation context =+      Correlation+        { correlationTraceId = traceIdToHex (spanContextTraceId context)+        , correlationSpanId = spanIdToHex (spanContextSpanId context)+        , correlationSampled = isSampled (spanContextTraceFlags context)+        }++-- | Render a 'Correlation' as the OpenTelemetry log-correlation fields:+-- @trace_id@, @span_id@, and @trace_flags@ (@"01"@ when sampled, @"00"@+-- otherwise). The pairs drop straight into any structured logger's key-value+-- context.+correlationFields :: Correlation -> [(Text, Text)]+correlationFields correlation =+  [ ("trace_id", correlationTraceId correlation)+  , ("span_id", correlationSpanId correlation)+  , ("trace_flags", if correlationSampled correlation then "01" else "00")+  ]++-- | The log-correlation fields for the active span, or @[]@ when no span is in+-- scope, so the result appends to a logger's context unconditionally.+activeCorrelationFields :: Tracer :> es => Eff es [(Text, Text)]+activeCorrelationFields = maybe [] correlationFields <$> activeCorrelation++-- | The active span's hex trace id, or 'Nothing' when no span is in scope.+activeTraceId :: Tracer :> es => Eff es (Maybe Text)+activeTraceId = fmap correlationTraceId <$> activeCorrelation++-- | The active span's hex span id, or 'Nothing' when no span is in scope.+activeSpanId :: Tracer :> es => Eff es (Maybe Text)+activeSpanId = fmap correlationSpanId <$> activeCorrelation
+ src/Effectful/Tracing/Propagation.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.Propagation+-- Description : W3C Trace Context propagation across process boundaries.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+-- Stability   : experimental+--+-- Carry a trace across a network hop using the+-- <https://www.w3.org/TR/trace-context/ W3C Trace Context> @traceparent@ and+-- @tracestate@ headers. 'injectContext' serializes the active span for an+-- outbound request; 'extractContext' parses the headers from an inbound request+-- into a 't:SpanContext', which 'withRemoteParent' then continues as a local+-- trace.+--+-- > -- server side: rejoin the caller's trace+-- > handle req =+-- >   case extractContext (requestHeaders req) of+-- >     Just parent -> withRemoteParent parent (withSpan "handle" (serve req))+-- >     Nothing     -> withSpan "handle" (serve req)+-- >+-- > -- client side: propagate to the next hop+-- > call = withSpan "call.downstream" $ do+-- >   headers <- injectContext+-- >   liftIO (httpGet url (baseHeaders <> headers))+--+-- This implements propagation directly against the library's own context, with+-- no dependency on an OpenTelemetry SDK, so it works under any interpreter that+-- maintains an active span (in-memory, pretty-print, OpenTelemetry).+module Effectful.Tracing.Propagation+  ( -- * Wire format+    traceparentHeader+  , tracestateHeader++    -- * Outbound+  , injectContext++    -- * Inbound+  , extractContext+  , withRemoteParent+  ) where++import Data.ByteString (ByteString)+import Data.Char (isHexDigit)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding (decodeUtf8', encodeUtf8)+import Network.HTTP.Types.Header (HeaderName)+import Numeric (readHex, showHex)++import Effectful (Eff, (:>))++import Effectful.Tracing.Effect (Tracer, getActiveSpan, withRemoteParent)+import Effectful.Tracing.Internal.Ids+  ( isValidSpanId+  , isValidTraceId+  , spanIdFromHex+  , spanIdToHex+  , traceIdFromHex+  , traceIdToHex+  )+import Effectful.Tracing.Internal.Types+  ( SpanContext (..)+  , TraceFlags (TraceFlags)+  , TraceState+  , emptyTraceState+  , traceStateFromHeader+  , traceStateToHeader+  )++-- | The @traceparent@ header name (case-insensitive, per HTTP).+traceparentHeader :: HeaderName+traceparentHeader = "traceparent"++-- | The @tracestate@ header name.+tracestateHeader :: HeaderName+tracestateHeader = "tracestate"++-- | Serialize the active span's context as @traceparent@ (and @tracestate@, if+-- non-empty) headers for an outbound request. Returns @[]@ when there is no+-- active span, so it composes with a base header list unconditionally.+injectContext :: Tracer :> es => Eff es [(HeaderName, ByteString)]+injectContext = maybe [] contextToHeaders <$> getActiveSpan++-- | The header list for a specific context.+contextToHeaders :: SpanContext -> [(HeaderName, ByteString)]+contextToHeaders context =+  (traceparentHeader, encodeUtf8 (renderTraceparent context))+    : [ (tracestateHeader, encodeUtf8 rendered)+      | let rendered = traceStateToHeader (spanContextTraceState context)+      , not (T.null rendered)+      ]++-- | Render a @traceparent@ value: @version-traceid-spanid-flags@, all lowercase+-- hex, version pinned to @00@.+renderTraceparent :: SpanContext -> Text+renderTraceparent context =+  T.intercalate+    "-"+    [ "00"+    , traceIdToHex (spanContextTraceId context)+    , spanIdToHex (spanContextSpanId context)+    , flagsToHex (spanContextTraceFlags context)+    ]++-- | A 't:TraceFlags' byte as two lowercase hex digits.+flagsToHex :: TraceFlags -> Text+flagsToHex (TraceFlags w) = T.justifyRight 2 '0' (T.pack (showHex w ""))++-- | Parse @traceparent@ / @tracestate@ headers from an inbound request into a+-- 't:SpanContext' marked remote. Returns 'Nothing' if @traceparent@ is absent or+-- malformed (an unparsable @tracestate@ is treated as empty rather than failing+-- the whole extraction, per the spec's resilience guidance). Header lookup is+-- case-insensitive because 'HeaderName' is case-insensitive.+extractContext :: [(HeaderName, ByteString)] -> Maybe SpanContext+extractContext headers = do+  rawTraceparent <- lookup traceparentHeader headers+  traceparent <- either (const Nothing) Just (decodeUtf8' rawTraceparent)+  parseTraceparent traceparent traceState+  where+    traceState = case lookup tracestateHeader headers of+      Just raw -> either (const emptyTraceState) traceStateFromHeader (decodeUtf8' raw)+      Nothing -> emptyTraceState++-- | Parse a decoded @traceparent@ value, attaching the already-parsed trace+-- state. Future versions are accepted by reading the first four fields; version+-- @00@ must have exactly four fields, and the all-zero ids are rejected.+parseTraceparent :: Text -> TraceState -> Maybe SpanContext+parseTraceparent raw traceState =+  case T.splitOn "-" (T.strip raw) of+    (version : tid : sid : flags : rest)+      | validVersion version+      , version /= "00" || null rest -> do+          traceId <- traceIdFromHex tid+          spanId <- spanIdFromHex sid+          if isValidTraceId traceId && isValidSpanId spanId+            then do+              flagsByte <- parseFlags flags+              Just+                SpanContext+                  { spanContextTraceId = traceId+                  , spanContextSpanId = spanId+                  , spanContextTraceFlags = flagsByte+                  , spanContextTraceState = traceState+                  , spanContextIsRemote = True+                  }+            else Nothing+    _ -> Nothing++-- | A version field is two hex digits and not the reserved @ff@.+validVersion :: Text -> Bool+validVersion v = T.length v == 2 && T.all isHexDigit v && v /= "ff"++-- | Parse the two-hex-digit flags field into a 't:TraceFlags' byte.+parseFlags :: Text -> Maybe TraceFlags+parseFlags t+  | T.length t == 2+  , T.all isHexDigit t+  , [(n, "")] <- readHex (T.unpack t) =+      Just (TraceFlags (fromIntegral (n :: Int)))+  | otherwise = Nothing
+ src/Effectful/Tracing/Propagation/B3.hs view
@@ -0,0 +1,242 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.Propagation.B3+-- Description : B3 (Zipkin) propagation across process boundaries.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+-- Stability   : experimental+--+-- Carry a trace across a network hop using the+-- <https://github.com/openzipkin/b3-propagation B3> headers that Zipkin and+-- many service meshes (Envoy, older Istio) emit. This is an alternative to the+-- W3C Trace Context propagator in "Effectful.Tracing.Propagation"; reach for it+-- when interoperating with infrastructure that speaks B3 rather than+-- @traceparent@.+--+-- Two wire encodings are supported, as in the B3 spec:+--+-- * the single @b3@ header, @{traceId}-{spanId}-{samplingState}-{parentSpanId}@+--   (the last two fields optional), which is the recommended form for new+--   deployments; and+-- * the legacy multi-header form (@X-B3-TraceId@, @X-B3-SpanId@,+--   @X-B3-Sampled@, @X-B3-Flags@, @X-B3-ParentSpanId@).+--+-- 'injectContextB3' writes the single header and 'injectContextB3Multi' the+-- multi-header form; 'extractContextB3' reads either (preferring the single+-- header when present) into a 't:SpanContext' that 'Effectful.Tracing.withRemoteParent'+-- can continue locally.+--+-- > -- server side: rejoin a B3 caller's trace+-- > handle req =+-- >   case extractContextB3 (requestHeaders req) of+-- >     Just parent -> withRemoteParent parent (withSpan "handle" (serve req))+-- >     Nothing     -> withSpan "handle" (serve req)+-- >+-- > -- client side: propagate to a B3 downstream+-- > call = withSpan "call.downstream" $ do+-- >   headers <- injectContextB3+-- >   liftIO (httpGet url (baseHeaders <> headers))+--+-- Like the W3C propagator, this works directly against the library's own+-- context under any interpreter that maintains an active span, with no+-- dependency on an OpenTelemetry SDK.+module Effectful.Tracing.Propagation.B3+  ( -- * Single-header wire format+    b3Header++    -- * Multi-header wire format+  , b3TraceIdHeader+  , b3SpanIdHeader+  , b3ParentSpanIdHeader+  , b3SampledHeader+  , b3FlagsHeader++    -- * Outbound+  , injectContextB3+  , injectContextB3Multi++    -- * Inbound+  , extractContextB3+  ) where++import Data.ByteString (ByteString)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding (decodeUtf8', encodeUtf8)+import Network.HTTP.Types.Header (HeaderName)++import Effectful (Eff, (:>))++import Effectful.Tracing.Effect (Tracer, getActiveSpan)+import Effectful.Tracing.Internal.Ids+  ( SpanId+  , TraceId+  , isValidSpanId+  , isValidTraceId+  , spanIdFromHex+  , spanIdToHex+  , traceIdFromHex+  , traceIdToHex+  )+import Effectful.Tracing.Internal.Types+  ( SpanContext (..)+  , TraceFlags+  , defaultTraceFlags+  , emptyTraceState+  , isSampled+  , setSampled+  )++-- | The single @b3@ header name (case-insensitive, per HTTP).+b3Header :: HeaderName+b3Header = "b3"++-- | The @X-B3-TraceId@ header name (multi-header form).+b3TraceIdHeader :: HeaderName+b3TraceIdHeader = "X-B3-TraceId"++-- | The @X-B3-SpanId@ header name (multi-header form).+b3SpanIdHeader :: HeaderName+b3SpanIdHeader = "X-B3-SpanId"++-- | The @X-B3-ParentSpanId@ header name. Read tolerantly but never required:+-- the library continues the caller's span (@X-B3-SpanId@) as the remote parent,+-- so the grandparent id carries no information it needs.+b3ParentSpanIdHeader :: HeaderName+b3ParentSpanIdHeader = "X-B3-ParentSpanId"++-- | The @X-B3-Sampled@ header name, carrying @1@ or @0@.+b3SampledHeader :: HeaderName+b3SampledHeader = "X-B3-Sampled"++-- | The @X-B3-Flags@ header name. A value of @1@ is B3's debug flag, which+-- implies a sampling decision of accept.+b3FlagsHeader :: HeaderName+b3FlagsHeader = "X-B3-Flags"++-- | Serialize the active span's context as a single @b3@ header for an outbound+-- request, using the full 128-bit trace id. Returns @[]@ when there is no+-- active span, so it composes with a base header list unconditionally.+injectContextB3 :: Tracer :> es => Eff es [(HeaderName, ByteString)]+injectContextB3 = maybe [] (\context -> [renderSingle context]) <$> getActiveSpan++-- | Serialize the active span's context as the legacy multi-header form+-- (@X-B3-TraceId@ \/ @X-B3-SpanId@ \/ @X-B3-Sampled@). Returns @[]@ when there+-- is no active span.+injectContextB3Multi :: Tracer :> es => Eff es [(HeaderName, ByteString)]+injectContextB3Multi = maybe [] renderMulti <$> getActiveSpan++-- | The single @b3@ header for a context.+renderSingle :: SpanContext -> (HeaderName, ByteString)+renderSingle context = (b3Header, encodeUtf8 value)+  where+    value =+      T.intercalate+        "-"+        [ traceIdToHex (spanContextTraceId context)+        , spanIdToHex (spanContextSpanId context)+        , renderSampling (spanContextTraceFlags context)+        ]++-- | The multi-header list for a context.+renderMulti :: SpanContext -> [(HeaderName, ByteString)]+renderMulti context =+  [ (b3TraceIdHeader, encodeUtf8 (traceIdToHex (spanContextTraceId context)))+  , (b3SpanIdHeader, encodeUtf8 (spanIdToHex (spanContextSpanId context)))+  , (b3SampledHeader, encodeUtf8 (renderSampling (spanContextTraceFlags context)))+  ]++-- | The sampling field for the sampled bit: @"1"@ when set, @"0"@ otherwise.+renderSampling :: TraceFlags -> Text+renderSampling flags = if isSampled flags then "1" else "0"++-- | Parse B3 headers from an inbound request into a 't:SpanContext' marked+-- remote. The single @b3@ header is preferred when present (and a malformed one+-- fails the extraction rather than falling through); otherwise the multi-header+-- form is read. Returns 'Nothing' when neither form yields a valid trace id and+-- span id. B3 carries no @tracestate@ equivalent, so the trace state is empty.+extractContextB3 :: [(HeaderName, ByteString)] -> Maybe SpanContext+extractContextB3 headers =+  case lookup b3Header headers of+    Just raw -> eitherToMaybe (decodeUtf8' raw) >>= parseSingle+    Nothing -> parseMulti headers++-- | Parse a decoded single-header value. The trace and span ids are required;+-- the sampling field is optional (absent means a deferred decision, treated as+-- unsampled) and a trailing parent span id is accepted and ignored.+parseSingle :: Text -> Maybe SpanContext+parseSingle raw =+  case T.splitOn "-" (T.strip raw) of+    [tid, sid] -> build tid sid Nothing+    [tid, sid, samp] -> build tid sid (Just samp)+    [tid, sid, samp, _parent] -> build tid sid (Just samp)+    _ -> Nothing+  where+    build tid sid msamp = do+      traceId <- parseTraceId tid+      spanId <- parseSpanId sid+      flags <- maybe (Just deferredFlags) parseSampling msamp+      validContext traceId spanId flags++-- | Parse the multi-header form. @X-B3-TraceId@ and @X-B3-SpanId@ are required;+-- the sampling decision comes from @X-B3-Flags: 1@ (debug, implies accept) or+-- @X-B3-Sampled@, defaulting to unsampled when neither is present.+parseMulti :: [(HeaderName, ByteString)] -> Maybe SpanContext+parseMulti headers = do+  tid <- decoded b3TraceIdHeader+  sid <- decoded b3SpanIdHeader+  traceId <- parseTraceId tid+  spanId <- parseSpanId sid+  validContext traceId spanId multiFlags+  where+    decoded name = lookup name headers >>= eitherToMaybe . decodeUtf8'+    multiFlags =+      case (decoded b3FlagsHeader, decoded b3SampledHeader) of+        (Just "1", _) -> setSampled True defaultTraceFlags+        (_, Just samp) -> fromMaybe deferredFlags (parseSampling samp)+        _ -> deferredFlags++-- | The flags for a deferred or absent sampling decision: unsampled, the+-- conservative choice when the caller has expressed no preference we can read.+deferredFlags :: TraceFlags+deferredFlags = defaultTraceFlags++-- | Parse a B3 sampling field. @1@ and @d@ (debug) mean accept; @0@ means deny.+parseSampling :: Text -> Maybe TraceFlags+parseSampling s+  | s == "1" || s == "d" = Just (setSampled True defaultTraceFlags)+  | s == "0" = Just defaultTraceFlags+  | otherwise = Nothing++-- | Parse a B3 trace id, which may be 64-bit (16 hex characters) or 128-bit (32+-- hex characters). A 64-bit id is left-padded with zeros to the library's+-- fixed 128-bit width, per the B3 spec.+parseTraceId :: Text -> Maybe TraceId+parseTraceId t+  | T.length t == 16 = traceIdFromHex (T.replicate 16 "0" <> t)+  | otherwise = traceIdFromHex t++-- | Parse a B3 span id (16 hex characters).+parseSpanId :: Text -> Maybe SpanId+parseSpanId = spanIdFromHex++-- | Assemble a remote 't:SpanContext' once the ids are confirmed non-zero and+-- correctly sized.+validContext :: TraceId -> SpanId -> TraceFlags -> Maybe SpanContext+validContext traceId spanId flags+  | isValidTraceId traceId && isValidSpanId spanId =+      Just+        SpanContext+          { spanContextTraceId = traceId+          , spanContextSpanId = spanId+          , spanContextTraceFlags = flags+          , spanContextTraceState = emptyTraceState+          , spanContextIsRemote = True+          }+  | otherwise = Nothing++-- | Collapse a decode 'Either' to 'Maybe', discarding the error.+eitherToMaybe :: Either e a -> Maybe a+eitherToMaybe = either (const Nothing) Just
+ src/Effectful/Tracing/Propagation/Baggage.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.Propagation.Baggage+-- Description : W3C Baggage propagation across process boundaries.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+-- Stability   : experimental+--+-- Carry ambient key-value context across a network hop using the+-- <https://www.w3.org/TR/baggage/ W3C Baggage> @baggage@ header. 'injectBaggage'+-- renders the in-scope baggage for an outbound request; 'extractBaggage' parses+-- an inbound header back into a 't:Baggage' value, which+-- 'Effectful.Tracing.Baggage.runBaggageWith' then makes ambient for the request.+--+-- > -- inbound: seed the ambient baggage from the request+-- > handle req = runBaggageWith (extractBaggage (requestHeaders req)) (serve req)+-- >+-- > -- outbound: forward the ambient baggage to the next hop+-- > call = do+-- >   headers <- injectBaggage+-- >   liftIO (httpGet url (baseHeaders <> headers))+--+-- The wire format is @key1=value1,key2=value2;prop=x@: comma-separated entries,+-- each an optionally percent-encoded value with optional @;@-separated metadata.+-- Values are percent-encoded on the way out and decoded on the way in; keys are+-- emitted verbatim. Parsing is resilient: a malformed entry is skipped rather+-- than failing the whole header, and the entry count is capped at+-- 'maxBaggageEntries'.+--+-- This is built directly against the 'Effectful.Tracing.Baggage.BaggageContext'+-- effect, with no dependency on an OpenTelemetry SDK.+module Effectful.Tracing.Propagation.Baggage+  ( -- * Wire format+    baggageHeader+  , maxBaggageEntries++    -- * Outbound+  , injectBaggage+  , renderBaggage++    -- * Inbound+  , extractBaggage+  , parseBaggage+  ) where++import Data.Bits (shiftL, shiftR, (.&.), (.|.))+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.Char (isAsciiLower, isAsciiUpper, isDigit, ord)+import Data.Maybe (mapMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding (decodeUtf8', decodeUtf8Lenient, encodeUtf8)+import Data.Word (Word8)+import Network.HTTP.Types.Header (HeaderName)++import Effectful (Eff, (:>))++import Effectful.Tracing.Baggage+  ( Baggage+  , BaggageContext+  , BaggageEntry (BaggageEntry)+  , baggageFromList+  , baggageToList+  , getBaggage+  )++-- | The @baggage@ header name (case-insensitive, per HTTP).+baggageHeader :: HeaderName+baggageHeader = "baggage"++-- | The maximum number of entries parsed from a single header, per the W3C+-- limit. Extra entries beyond this are dropped.+maxBaggageEntries :: Int+maxBaggageEntries = 180++-- | Serialize the in-scope baggage as a @baggage@ header for an outbound+-- request. Returns @[]@ when the baggage is empty, so it composes with a base+-- header list unconditionally.+injectBaggage :: BaggageContext :> es => Eff es [(HeaderName, ByteString)]+injectBaggage = do+  rendered <- renderBaggage <$> getBaggage+  pure [(baggageHeader, encodeUtf8 rendered) | not (T.null rendered)]++-- | Render baggage to a header value: @key=value@ entries (values+-- percent-encoded, metadata appended verbatim) joined with commas, ordered by+-- key. Empty baggage renders to the empty string.+renderBaggage :: Baggage -> Text+renderBaggage = T.intercalate "," . map renderMember . baggageToList+  where+    renderMember (key, BaggageEntry value metadata) =+      key <> "=" <> percentEncode value <> maybe "" (";" <>) metadata++-- | Parse the @baggage@ header from an inbound request into a 'Baggage' value.+-- An absent or undecodable header yields empty baggage.+extractBaggage :: [(HeaderName, ByteString)] -> Baggage+extractBaggage headers =+  case lookup baggageHeader headers of+    Nothing -> baggageFromList []+    Just raw -> either (const (baggageFromList [])) parseBaggage (decodeUtf8' raw)++-- | Parse a decoded @baggage@ header value. Total: malformed entries (no key,+-- an invalid key token) are skipped, surrounding whitespace is trimmed, values+-- are percent-decoded, and the result is capped at 'maxBaggageEntries'.+parseBaggage :: Text -> Baggage+parseBaggage =+  baggageFromList . take maxBaggageEntries . mapMaybe parseMember . T.splitOn ","++-- | Parse one @key=value;props@ member, or 'Nothing' if it is malformed.+parseMember :: Text -> Maybe (Text, BaggageEntry)+parseMember member =+  case T.splitOn ";" (T.strip member) of+    [] -> Nothing+    (keyValue : props) -> do+      let (rawKey, rest) = T.breakOn "=" keyValue+          key = T.strip rawKey+      _ <- T.stripPrefix "=" rest -- require a '=' to be present+      if not (isToken key)+        then Nothing+        else+          let value = percentDecode (T.strip (T.drop 1 rest))+              metadata = case map T.strip props of+                [] -> Nothing+                stripped -> Just (T.intercalate ";" stripped)+           in Just (key, BaggageEntry value metadata)++-- | Whether a key is a non-empty RFC 7230 token (the W3C key grammar).+isToken :: Text -> Bool+isToken key = not (T.null key) && T.all isTokenChar key++-- | An RFC 7230 @tchar@: an unreserved token character.+isTokenChar :: Char -> Bool+isTokenChar c =+  isAsciiLower c+    || isAsciiUpper c+    || isDigit c+    || c `elem` ("!#$%&'*+-.^_`|~" :: String)++-- | Percent-encode a value: keep RFC 3986 unreserved bytes, escape the rest as+-- @%XX@ (uppercase hex) over the UTF-8 encoding. Conservative (it escapes more+-- than the W3C grammar strictly requires), but always produces a valid value.+percentEncode :: Text -> Text+percentEncode = T.concat . map encodeByte . BS.unpack . encodeUtf8+  where+    encodeByte w+      | isUnreserved w = T.singleton (toEnum (fromIntegral w))+      | otherwise = T.pack ['%', hexDigit (w `shiftR` 4), hexDigit (w .&. 0x0F)]++-- | The uppercase hex digit for a nibble (0-15).+hexDigit :: Word8 -> Char+hexDigit n+  | n < 10 = toEnum (fromIntegral n + ord '0')+  | otherwise = toEnum (fromIntegral n - 10 + ord 'A')++-- | An RFC 3986 unreserved byte: @ALPHA@, @DIGIT@, or one of @-._~@.+isUnreserved :: Word8 -> Bool+isUnreserved w =+  (w >= 0x41 && w <= 0x5A) -- A-Z+    || (w >= 0x61 && w <= 0x7A) -- a-z+    || (w >= 0x30 && w <= 0x39) -- 0-9+    || w == 0x2D -- '-'+    || w == 0x2E -- '.'+    || w == 0x5F -- '_'+    || w == 0x7E -- '~'++-- | Percent-decode a value. Total: a @%@ not followed by two hex digits is kept+-- literally. Decodes over the UTF-8 bytes, so multi-byte values round-trip.+percentDecode :: Text -> Text+percentDecode = decodeUtf8Lenient . BS.pack . decodeBytes . BS.unpack . encodeUtf8+  where+    decodeBytes (w : a : b : rest)+      | w == 0x25 -- '%'+      , Just hi <- hexValue a+      , Just lo <- hexValue b =+          ((hi `shiftL` 4) .|. lo) : decodeBytes rest+    decodeBytes (w : rest) = w : decodeBytes rest+    decodeBytes [] = []++-- | The numeric value of an ASCII hex-digit byte, if it is one.+hexValue :: Word8 -> Maybe Word8+hexValue w+  | w >= 0x30 && w <= 0x39 = Just (w - 0x30) -- 0-9+  | w >= 0x41 && w <= 0x46 = Just (w - 0x41 + 10) -- A-F+  | w >= 0x61 && w <= 0x66 = Just (w - 0x61 + 10) -- a-f+  | otherwise = Nothing
+ src/Effectful/Tracing/Propagation/Composite.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++-- |+-- Module      : Effectful.Tracing.Propagation.Composite+-- Description : Combine several propagators into one inject\/extract pass.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+-- Stability   : experimental+--+-- A real deployment rarely speaks exactly one wire format. A service may emit+-- W3C @traceparent@ for its own backend while still honouring inbound B3 headers+-- from a mesh, or run alongside legacy Jaeger clients during a migration.+-- OpenTelemetry models this with a __composite propagator__: a list of+-- single-format propagators that all run on inject (every format is written) and+-- are tried in order on extract (the first that parses wins).+--+-- This module packages each single-format propagator from+-- "Effectful.Tracing.Propagation", "Effectful.Tracing.Propagation.B3", and+-- "Effectful.Tracing.Propagation.Jaeger" as a first-class value+-- ('TraceContextPropagator' for the span context, 'BaggagePropagator' for+-- baggage), and provides the combinators that fan a list of them out on the way+-- out ('injectContextAll', 'injectBaggageAll') and collapse them on the way in+-- ('extractContextFirst', 'extractBaggageAll').+--+-- > -- write W3C and B3, accept either inbound+-- > let propagators = [w3cTraceContext, b3Single]+-- >+-- > -- server side: continue whichever format the caller used+-- > handle req = case extractContextFirst propagators (requestHeaders req) of+-- >   Just parent -> withRemoteParent parent (withSpan "handle" (serve req))+-- >   Nothing     -> withSpan "handle" (serve req)+-- >+-- > -- client side: emit every configured format+-- > call = withSpan "call.downstream" $ do+-- >   headers <- injectContextAll propagators+-- >   liftIO (httpGet url (baseHeaders <> headers))+--+-- Each standard propagator is tagged with the token name OpenTelemetry's+-- @OTEL_PROPAGATORS@ environment variable uses for it (@tracecontext@, @baggage@,+-- @b3@, @b3multi@, @jaeger@), and 'traceContextByToken' \/ 'baggageByToken' resolve+-- a token to its propagator. This is the foundation environment-variable+-- configuration builds on.+--+-- Like the underlying propagators, this works directly against the library's own+-- context under any interpreter, with no dependency on an OpenTelemetry SDK.+module Effectful.Tracing.Propagation.Composite+  ( -- * Trace-context propagators+    TraceContextPropagator (..)+  , w3cTraceContext+  , b3Single+  , b3Multi+  , jaegerTraceContext+  , traceContextByToken++    -- * Baggage propagators+  , BaggagePropagator (..)+  , w3cBaggage+  , jaegerBaggage+  , baggageByToken++    -- * Combining propagators+  , injectContextAll+  , extractContextFirst+  , injectBaggageAll+  , extractBaggageAll+  ) where++import Data.ByteString (ByteString)+import Data.Foldable (asum)+import Data.Text (Text)+import Network.HTTP.Types.Header (HeaderName)++import Effectful (Eff, (:>))++import Effectful.Tracing.Baggage+  ( Baggage+  , BaggageContext+  , baggageFromList+  , baggageToList+  )+import Effectful.Tracing.Effect (Tracer)+import Effectful.Tracing.Internal.Types (SpanContext)+import Effectful.Tracing.Propagation (extractContext, injectContext)+import Effectful.Tracing.Propagation.B3+  ( extractContextB3+  , injectContextB3+  , injectContextB3Multi+  )+import Effectful.Tracing.Propagation.Baggage (extractBaggage, injectBaggage)+import Effectful.Tracing.Propagation.Jaeger+  ( extractBaggageJaeger+  , extractContextJaeger+  , injectBaggageJaeger+  , injectContextJaeger+  )++-- | A single span-context propagator captured as a value: its+-- @OTEL_PROPAGATORS@ token name, its outbound 'inject', and its inbound+-- 'extract'. The standard ones are 'w3cTraceContext', 'b3Single', 'b3Multi', and+-- 'jaegerTraceContext'; construct your own to plug in a custom header scheme.+data TraceContextPropagator = TraceContextPropagator+  { traceContextName :: !Text+  -- ^ The @OTEL_PROPAGATORS@ token this propagator is configured by.+  , inject :: forall es. Tracer :> es => Eff es [(HeaderName, ByteString)]+  -- ^ Serialize the active span's context as outbound headers (@[]@ when there+  -- is no active span).+  , extract :: [(HeaderName, ByteString)] -> Maybe SpanContext+  -- ^ Parse a remote context from inbound headers, or 'Nothing' if this format+  -- is absent or malformed.+  }++-- | A single baggage propagator captured as a value: its @OTEL_PROPAGATORS@+-- token name, its outbound 'injectBag', and its inbound 'extractBag'. The standard+-- ones are 'w3cBaggage' and 'jaegerBaggage'.+data BaggagePropagator = BaggagePropagator+  { baggageName :: !Text+  -- ^ The @OTEL_PROPAGATORS@ token this propagator is configured by.+  , injectBag :: forall es. BaggageContext :> es => Eff es [(HeaderName, ByteString)]+  -- ^ Serialize the in-scope baggage as outbound headers (@[]@ when empty).+  , extractBag :: [(HeaderName, ByteString)] -> Baggage+  -- ^ Parse baggage from inbound headers (empty when absent).+  }++-- | The W3C Trace Context propagator (@traceparent@ \/ @tracestate@), token+-- @tracecontext@. Wraps "Effectful.Tracing.Propagation".+w3cTraceContext :: TraceContextPropagator+w3cTraceContext =+  TraceContextPropagator+    { traceContextName = "tracecontext"+    , inject = injectContext+    , extract = extractContext+    }++-- | The single-header B3 propagator (@b3@), token @b3@. Wraps+-- "Effectful.Tracing.Propagation.B3". On extract this reads either B3 form, so it+-- also accepts the multi-header encoding.+b3Single :: TraceContextPropagator+b3Single =+  TraceContextPropagator+    { traceContextName = "b3"+    , inject = injectContextB3+    , extract = extractContextB3+    }++-- | The multi-header B3 propagator (@X-B3-*@), token @b3multi@. Wraps+-- "Effectful.Tracing.Propagation.B3"; differs from 'b3Single' only in writing the+-- legacy multi-header form on inject.+b3Multi :: TraceContextPropagator+b3Multi =+  TraceContextPropagator+    { traceContextName = "b3multi"+    , inject = injectContextB3Multi+    , extract = extractContextB3+    }++-- | The Jaeger propagator (@uber-trace-id@), token @jaeger@. Wraps+-- "Effectful.Tracing.Propagation.Jaeger". Jaeger also carries baggage; that side+-- is 'jaegerBaggage'.+jaegerTraceContext :: TraceContextPropagator+jaegerTraceContext =+  TraceContextPropagator+    { traceContextName = "jaeger"+    , inject = injectContextJaeger+    , extract = extractContextJaeger+    }++-- | The W3C Baggage propagator (@baggage@ header), token @baggage@. Wraps+-- "Effectful.Tracing.Propagation.Baggage".+w3cBaggage :: BaggagePropagator+w3cBaggage =+  BaggagePropagator+    { baggageName = "baggage"+    , injectBag = injectBaggage+    , extractBag = extractBaggage+    }++-- | The Jaeger baggage propagator (@uberctx-@ headers), token @jaeger@. Wraps+-- the baggage side of "Effectful.Tracing.Propagation.Jaeger".+jaegerBaggage :: BaggagePropagator+jaegerBaggage =+  BaggagePropagator+    { baggageName = "jaeger"+    , injectBag = injectBaggageJaeger+    , extractBag = extractBaggageJaeger+    }++-- | Resolve an @OTEL_PROPAGATORS@ token to its trace-context propagator, or+-- 'Nothing' for an unknown token (or one, like @baggage@, that has no+-- trace-context side). Recognises @tracecontext@, @b3@, @b3multi@, and @jaeger@.+traceContextByToken :: Text -> Maybe TraceContextPropagator+traceContextByToken token =+  lookup token [(traceContextName p, p) | p <- standardTraceContextPropagators]++-- | Resolve an @OTEL_PROPAGATORS@ token to its baggage propagator, or 'Nothing'+-- for a token with no baggage side. Recognises @baggage@ and @jaeger@.+baggageByToken :: Text -> Maybe BaggagePropagator+baggageByToken token =+  lookup token [(baggageName p, p) | p <- standardBaggagePropagators]++-- | The standard trace-context propagators, in token order.+standardTraceContextPropagators :: [TraceContextPropagator]+standardTraceContextPropagators = [w3cTraceContext, b3Single, b3Multi, jaegerTraceContext]++-- | The standard baggage propagators, in token order.+standardBaggagePropagators :: [BaggagePropagator]+standardBaggagePropagators = [w3cBaggage, jaegerBaggage]++-- | Run every propagator's inject and concatenate the headers, so an outbound+-- request carries all configured formats at once. Returns @[]@ for an empty+-- list (or when there is no active span).+injectContextAll :: Tracer :> es => [TraceContextPropagator] -> Eff es [(HeaderName, ByteString)]+injectContextAll propagators = concat <$> traverse (\p -> inject p) propagators++-- | Try each propagator's extract in order and take the first that parses a+-- context, mirroring OpenTelemetry's composite extract. Returns 'Nothing' when+-- none of them match.+extractContextFirst :: [TraceContextPropagator] -> [(HeaderName, ByteString)] -> Maybe SpanContext+extractContextFirst propagators headers = asum [extract p headers | p <- propagators]++-- | Run every baggage propagator's inject and concatenate the headers. Returns+-- @[]@ for an empty list (or empty baggage).+injectBaggageAll :: BaggageContext :> es => [BaggagePropagator] -> Eff es [(HeaderName, ByteString)]+injectBaggageAll propagators = concat <$> traverse (\p -> injectBag p) propagators++-- | Extract baggage with every propagator and merge the results into one set.+-- Baggage is additive (unlike a single span context), so all formats+-- contribute; on a key present in more than one, the later propagator in the+-- list wins.+extractBaggageAll :: [BaggagePropagator] -> [(HeaderName, ByteString)] -> Baggage+extractBaggageAll propagators headers =+  baggageFromList (concatMap (\p -> baggageToList (extractBag p headers)) propagators)
+ src/Effectful/Tracing/Propagation/Jaeger.hs view
@@ -0,0 +1,218 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.Propagation.Jaeger+-- Description : Jaeger (uber-trace-id) propagation across process boundaries.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+-- Stability   : experimental+--+-- Carry a trace across a network hop using the+-- <https://www.jaegertracing.io/docs/1.21/client-libraries/#propagation-format uber-trace-id>+-- header that older Jaeger client libraries emit, plus the @uberctx-@ baggage+-- headers. This is an alternative to the W3C Trace Context propagator in+-- "Effectful.Tracing.Propagation" and the B3 propagator in+-- "Effectful.Tracing.Propagation.B3"; reach for it when interoperating with+-- infrastructure still instrumented with native Jaeger clients.+--+-- The single @uber-trace-id@ header is+-- @{trace-id}:{span-id}:{parent-span-id}:{flags}@, where the ids are hex (Jaeger+-- strips leading zeros, so they may be shorter than full width), the+-- @parent-span-id@ field is deprecated (carries no information the library+-- needs) but still required by the format, and @flags@ is a one-byte bitmask+-- whose low bit is the sampled decision. 'injectContextJaeger' writes it and+-- 'extractContextJaeger' reads it into a 't:SpanContext' that+-- 'Effectful.Tracing.withRemoteParent' can continue locally.+--+-- Baggage rides on one @uberctx-{key}: {value}@ header per item.+-- 'injectBaggageJaeger' emits those from the ambient+-- 'Effectful.Tracing.Baggage.BaggageContext', and 'extractBaggageJaeger' reads+-- them back into a 'Baggage' set. Jaeger baggage has no metadata concept, so+-- metadata is dropped on the way out and absent on the way in.+--+-- > -- server side: rejoin a Jaeger caller's trace and its baggage+-- > handle req = serveWith (extractBaggageJaeger headers) $+-- >   case extractContextJaeger headers of+-- >     Just parent -> withRemoteParent parent (withSpan "handle" (serve req))+-- >     Nothing     -> withSpan "handle" (serve req)+-- >   where headers = requestHeaders req+-- >+-- > -- client side: propagate to a Jaeger downstream+-- > call = withSpan "call.downstream" $ do+-- >   context <- injectContextJaeger+-- >   bag     <- injectBaggageJaeger+-- >   liftIO (httpGet url (baseHeaders <> context <> bag))+--+-- Like the W3C and B3 propagators, this works directly against the library's own+-- context under any interpreter that maintains an active span, with no+-- dependency on an OpenTelemetry SDK.+module Effectful.Tracing.Propagation.Jaeger+  ( -- * Header names+    uberTraceIdHeader+  , uberBaggagePrefix++    -- * Trace context+  , injectContextJaeger+  , extractContextJaeger++    -- * Baggage+  , injectBaggageJaeger+  , extractBaggageJaeger+  ) where++import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.CaseInsensitive qualified as CI+import Data.Char (digitToInt, isHexDigit)+import Data.Maybe (mapMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding (decodeUtf8', encodeUtf8)+import Network.HTTP.Types.Header (HeaderName)++import Effectful (Eff, (:>))++import Effectful.Tracing.Baggage+  ( Baggage+  , BaggageContext+  , BaggageEntry (BaggageEntry)+  , baggageFromList+  , baggageToList+  , getBaggage+  )+import Effectful.Tracing.Effect (Tracer, getActiveSpan)+import Effectful.Tracing.Internal.Ids+  ( SpanId+  , TraceId+  , isValidSpanId+  , isValidTraceId+  , spanIdFromHex+  , spanIdToHex+  , traceIdFromHex+  , traceIdToHex+  )+import Effectful.Tracing.Internal.Types+  ( SpanContext (..)+  , TraceFlags+  , defaultTraceFlags+  , emptyTraceState+  , isSampled+  , setSampled+  )+import Effectful.Tracing.Propagation.Baggage (maxBaggageEntries)++-- | The @uber-trace-id@ header name (case-insensitive, per HTTP).+uberTraceIdHeader :: HeaderName+uberTraceIdHeader = "uber-trace-id"++-- | The prefix Jaeger puts on each per-item baggage header, @uberctx-@. A header+-- named @uberctx-{key}@ carries the baggage value for @{key}@.+uberBaggagePrefix :: ByteString+uberBaggagePrefix = "uberctx-"++-- | Serialize the active span's context as a single @uber-trace-id@ header for an+-- outbound request, using the full 128-bit trace id and a @0@ parent field.+-- Returns @[]@ when there is no active span, so it composes with a base header+-- list unconditionally.+injectContextJaeger :: Tracer :> es => Eff es [(HeaderName, ByteString)]+injectContextJaeger = maybe [] (\context -> [renderUberTraceId context]) <$> getActiveSpan++-- | Serialize the ambient baggage as @uberctx-{key}@ headers, one per entry+-- (ordered by key). Metadata is dropped, as Jaeger baggage has no equivalent.+-- Returns @[]@ when the baggage is empty.+injectBaggageJaeger :: BaggageContext :> es => Eff es [(HeaderName, ByteString)]+injectBaggageJaeger = map renderItem . baggageToList <$> getBaggage+  where+    renderItem (key, BaggageEntry value _metadata) =+      (CI.mk (uberBaggagePrefix <> encodeUtf8 key), encodeUtf8 value)++-- | The @uber-trace-id@ header for a context.+renderUberTraceId :: SpanContext -> (HeaderName, ByteString)+renderUberTraceId context = (uberTraceIdHeader, encodeUtf8 value)+  where+    value =+      T.intercalate+        ":"+        [ traceIdToHex (spanContextTraceId context)+        , spanIdToHex (spanContextSpanId context)+        , "0"+        , renderFlags (spanContextTraceFlags context)+        ]+    renderFlags flags = if isSampled flags then "1" else "0"++-- | Parse an inbound @uber-trace-id@ header into a 't:SpanContext' marked remote.+-- Returns 'Nothing' when the header is absent, not decodable, or malformed.+-- Jaeger carries no @tracestate@ equivalent, so the trace state is empty.+extractContextJaeger :: [(HeaderName, ByteString)] -> Maybe SpanContext+extractContextJaeger headers =+  lookup uberTraceIdHeader headers >>= eitherToMaybe . decodeUtf8' >>= parseUberTraceId++-- | Read @uberctx-@ baggage headers into a 'Baggage' set, skipping any whose key+-- or value is empty or not decodable, and capping at the W3C entry limit so a+-- flood of headers cannot grow the set without bound. Metadata is always absent.+extractBaggageJaeger :: [(HeaderName, ByteString)] -> Baggage+extractBaggageJaeger = baggageFromList . take maxBaggageEntries . mapMaybe item+  where+    item (name, rawValue) = do+      keyBytes <- BS.stripPrefix uberBaggagePrefix (CI.foldedCase name)+      key <- T.strip <$> eitherToMaybe (decodeUtf8' keyBytes)+      value <- T.strip <$> eitherToMaybe (decodeUtf8' rawValue)+      if T.null key then Nothing else Just (key, BaggageEntry value Nothing)++-- | Parse a decoded @uber-trace-id@ value. The format requires exactly four+-- colon-separated fields; the trace and span ids must be valid hex, the parent+-- field is accepted and ignored, and the flags field's low bit is the sampled+-- decision.+parseUberTraceId :: Text -> Maybe SpanContext+parseUberTraceId raw =+  case T.splitOn ":" (T.strip raw) of+    [tid, sid, _parent, flags] -> do+      traceId <- parseTraceId tid+      spanId <- parseSpanId sid+      traceFlags <- parseFlags flags+      validContext traceId spanId traceFlags+    _ -> Nothing++-- | Parse a Jaeger trace id. Jaeger may strip leading zeros and may use a 64-bit+-- (16-hex) or 128-bit (32-hex) id, so any non-empty hex string up to 32+-- characters is left-padded with zeros to the library's fixed 128-bit width.+parseTraceId :: Text -> Maybe TraceId+parseTraceId t+  | T.null t || T.length t > 32 = Nothing+  | otherwise = traceIdFromHex (T.justifyRight 32 '0' t)++-- | Parse a Jaeger span id, left-padding a leading-zero-stripped value back to+-- the full 64-bit (16-hex) width.+parseSpanId :: Text -> Maybe SpanId+parseSpanId t+  | T.null t || T.length t > 16 = Nothing+  | otherwise = spanIdFromHex (T.justifyRight 16 '0' t)++-- | Parse the one-byte flags field (a hex bitmask) and read its low bit as the+-- sampled decision; the debug and firehose bits have no home in the library's+-- one-bit 'TraceFlags' and are ignored. A non-hex or empty field is rejected.+parseFlags :: Text -> Maybe TraceFlags+parseFlags t+  | T.null t || not (T.all isHexDigit t) = Nothing+  | otherwise =+      let sampled = odd (T.foldl' (\acc c -> acc * 16 + digitToInt c) (0 :: Int) t)+       in Just (if sampled then setSampled True defaultTraceFlags else defaultTraceFlags)++-- | Assemble a remote 't:SpanContext' once the ids are confirmed non-zero and+-- correctly sized.+validContext :: TraceId -> SpanId -> TraceFlags -> Maybe SpanContext+validContext traceId spanId flags+  | isValidTraceId traceId && isValidSpanId spanId =+      Just+        SpanContext+          { spanContextTraceId = traceId+          , spanContextSpanId = spanId+          , spanContextTraceFlags = flags+          , spanContextTraceState = emptyTraceState+          , spanContextIsRemote = True+          }+  | otherwise = Nothing++-- | Collapse a decode 'Either' to 'Maybe', discarding the error.+eitherToMaybe :: Either e a -> Maybe a+eitherToMaybe = either (const Nothing) Just
+ src/Effectful/Tracing/Sampler.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.Sampler+-- Description : Span sampling: decide at span-start whether to record a span.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+-- Stability   : experimental+--+-- A 't:Sampler' decides, when a span starts, whether it is dropped, recorded but+-- not exported, or recorded and exported. The decision is made from the+-- 't:SamplerInput': the parent context, the trace id, and the span's name, kind,+-- initial attributes, and links.+--+-- == Why @shouldSample@ is plain @IO@+--+-- 'shouldSample' returns @'IO' 't:SamplingResult'@ rather than @'Effectful.Eff' es@.+-- The built-in samplers are pure or clock-only, so 'IO' is sufficient, and it+-- keeps 't:Sampler' a plain value that interpreters can hold without threading an+-- effect row through their configuration. The cost is that a user-written+-- sampler cannot use other effects (for example, reading configuration through+-- an effect). If that turns out to matter, the alternative is+-- @SamplerInput -> Eff es SamplingResult@ with the sampler parameterized over a+-- fixed effect row. For now the simpler 'IO' form is the default.+module Effectful.Tracing.Sampler+  ( -- * Decisions+    SamplingDecision (..)+  , SamplingResult (..)+  , simpleResult++    -- * Samplers+  , Sampler (..)+  , SamplerInput (..)++    -- * Built-in samplers+  , alwaysOn+  , alwaysOff+  , traceIdRatioBased+  , parentBased++    -- * Parent-based configuration+  , ParentBasedConfig (..)+  , defaultParentBasedConfig+  ) where++import Data.Bits (shiftL, (.|.))+import Data.ByteString qualified as BS+import Data.Text (Text)+import Data.Text qualified as T+import Data.Word (Word64)++import Effectful.Tracing.Attribute (Attribute)+import Effectful.Tracing.Internal.Ids (TraceId (TraceId))+import Effectful.Tracing.Internal.Types+  ( Link+  , SpanContext (spanContextIsRemote, spanContextTraceFlags)+  , SpanKind+  , TraceState+  , isSampled+  )++-- | What a sampler decides for a span.+data SamplingDecision+  = -- | Do not record the span at all.+    Drop+  | -- | Record the span locally, but do not export it. Useful for debugging.+    -- Interpreters without an export step treat this like 'RecordAndSample'.+    RecordOnly+  | -- | Record the span and export it; the @sampled@ trace flag is set.+    RecordAndSample+  deriving (Eq, Show, Enum, Bounded)++-- | A sampler's verdict: a 'SamplingDecision', any attributes the sampler wants+-- added to the span, and an optional replacement 't:TraceState'.+data SamplingResult = SamplingResult+  { decision :: !SamplingDecision+  , extraAttributes :: ![Attribute]+  , newTraceState :: !(Maybe TraceState)+  }+  deriving (Eq, Show)++-- | A 't:SamplingResult' carrying just a decision: no extra attributes, no+-- trace-state change.+simpleResult :: SamplingDecision -> SamplingResult+simpleResult d =+  SamplingResult {decision = d, extraAttributes = [], newTraceState = Nothing}++-- | The information a sampler sees about a span that is about to start.+data SamplerInput = SamplerInput+  { parentContext :: !(Maybe SpanContext)+  , traceId :: !TraceId+  , spanName :: !Text+  , spanKind :: !SpanKind+  , initialAttributes :: ![Attribute]+  , links :: ![Link]+  }++-- | A named sampling policy. 'shouldSample' is consulted once per span, at+-- start.+data Sampler = Sampler+  { samplerName :: !Text+  , shouldSample :: SamplerInput -> IO SamplingResult+  }++-- | Always record and sample every span.+alwaysOn :: Sampler+alwaysOn =+  Sampler+    { samplerName = "AlwaysOn"+    , shouldSample = \_ -> pure (simpleResult RecordAndSample)+    }++-- | Never record any span.+alwaysOff :: Sampler+alwaysOff =+  Sampler+    { samplerName = "AlwaysOff"+    , shouldSample = \_ -> pure (simpleResult Drop)+    }++-- | Sample a deterministic fraction of traces, keyed on the trace id, so every+-- span in a given trace gets the same decision. A ratio @<= 0@ drops+-- everything; @>= 1@ samples everything.+traceIdRatioBased :: Double -> Sampler+traceIdRatioBased ratio =+  Sampler+    { samplerName = "TraceIdRatioBased{" <> T.pack (show ratio) <> "}"+    , shouldSample = pure . simpleResult . decide . traceId+    }+  where+    decide tid+      | ratio <= 0 = Drop+      | ratio >= 1 = RecordAndSample+      | fromIntegral (traceIdHighBits tid) / twoToThe64 < ratio = RecordAndSample+      | otherwise = Drop+    twoToThe64 = fromIntegral (maxBound :: Word64) + 1 :: Double++-- | The high 8 bytes of a trace id as a big-endian 'Word64'.+traceIdHighBits :: TraceId -> Word64+traceIdHighBits (TraceId bs) =+  BS.foldl' (\acc b -> (acc `shiftL` 8) .|. fromIntegral b) 0 (BS.take 8 bs)++-- | How 'parentBased' decides, given the kind of parent a span has.+data ParentBasedConfig = ParentBasedConfig+  { rootSampler :: !Sampler+  -- ^ Used when the span has no parent.+  , remoteParentSampled :: !Sampler+  , remoteParentNotSampled :: !Sampler+  , localParentSampled :: !Sampler+  , localParentNotSampled :: !Sampler+  }++-- | The usual parent-based configuration: defer to a parent's @sampled@ flag+-- when there is a parent (sampled parent -> sample, unsampled parent -> drop,+-- for both local and remote parents), and use the given root sampler otherwise.+defaultParentBasedConfig :: Sampler -> ParentBasedConfig+defaultParentBasedConfig root =+  ParentBasedConfig+    { rootSampler = root+    , remoteParentSampled = alwaysOn+    , remoteParentNotSampled = alwaysOff+    , localParentSampled = alwaysOn+    , localParentNotSampled = alwaysOff+    }++-- | Follow the parent span's sampling decision when there is a parent,+-- otherwise consult the configured root sampler. This is the recommended+-- default policy: it keeps a trace's spans consistently sampled or dropped.+parentBased :: ParentBasedConfig -> Sampler+parentBased config =+  Sampler+    { samplerName = "ParentBased{" <> samplerName (rootSampler config) <> "}"+    , shouldSample = \input -> case parentContext input of+        Nothing -> shouldSample (rootSampler config) input+        Just pc -> shouldSample (chooseFor pc) input+    }+  where+    chooseFor pc = case (spanContextIsRemote pc, isSampled (spanContextTraceFlags pc)) of+      (True, True) -> remoteParentSampled config+      (True, False) -> remoteParentNotSampled config+      (False, True) -> localParentSampled config+      (False, False) -> localParentNotSampled config
+ src/Effectful/Tracing/SemConv.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.SemConv+-- Description : OpenTelemetry semantic-convention attribute keys.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+-- Stability   : experimental+--+-- Typed constants for the OpenTelemetry semantic-convention attribute keys this+-- library emits, so the instrumentation modules name attributes from one place+-- instead of scattering string literals. The values track the /stable/ HTTP and+-- URL conventions (the @http.request.method@ \/ @url.full@ \/+-- @http.response.status_code@ set), not the older pre-stable names+-- (@http.method@, @http.url@, @http.status_code@) that earlier releases used.+--+-- These are plain 'Text', so you can use them directly with '.=' (from+-- "Effectful.Tracing.Attribute") when recording your own attributes:+--+-- > import Effectful.Tracing (addAttribute)+-- > import Effectful.Tracing.SemConv qualified as SemConv+-- >+-- > addAttribute SemConv.httpRoute ("/users/{id}" :: Text)+--+-- The naming follows the convention namespaces: @http.*@ for protocol-level+-- request and response attributes, @url.*@ for the parts of the request URL,+-- @network.*@ for transport details, @db.*@ for database client calls,+-- @messaging.*@ for message producer \/ consumer operations, and+-- @exception.*@ for recorded errors.+module Effectful.Tracing.SemConv+  ( -- * HTTP attributes+    httpRequestMethod+  , httpResponseStatusCode+  , httpRoute++    -- * URL attributes+  , urlFull+  , urlScheme+  , urlPath+  , urlQuery++    -- * Network attributes+  , networkProtocolVersion++    -- * Database attributes+  , dbSystemName+  , dbQueryText+  , dbOperationName+  , dbCollectionName+  , dbNamespace+  , dbOperationBatchSize++    -- * Messaging attributes+  , messagingSystem+  , messagingOperationType+  , messagingOperationName+  , messagingDestinationName+  , messagingDestinationTemplate+  , messagingMessageId+  , messagingMessageConversationId+  , messagingMessageBodySize+  , messagingBatchMessageCount++    -- * Exception attributes+  , exceptionType+  , exceptionMessage+  ) where++import Data.Text (Text)++-- | @http.request.method@: the HTTP request method, for example @\"GET\"@ or+-- @\"POST\"@. (Stable replacement for the pre-stable @http.method@.)+httpRequestMethod :: Text+httpRequestMethod = "http.request.method"++-- | @http.response.status_code@: the HTTP response status code, for example+-- @200@. (Stable replacement for the pre-stable @http.status_code@.)+httpResponseStatusCode :: Text+httpResponseStatusCode = "http.response.status_code"++-- | @http.route@: the matched route template (low cardinality), for example+-- @\"/users/{id}\"@. Set this only when the routing layer knows the template;+-- never the raw, high-cardinality path.+httpRoute :: Text+httpRoute = "http.route"++-- | @url.full@: the absolute request URL, for example+-- @\"https:\/\/example.com\/widgets?q=cat\"@. (Stable replacement for the+-- pre-stable @http.url@.)+urlFull :: Text+urlFull = "url.full"++-- | @url.scheme@: the URL scheme, for example @\"http\"@ or @\"https\"@. (Stable+-- replacement for the pre-stable @http.scheme@.)+urlScheme :: Text+urlScheme = "url.scheme"++-- | @url.path@: the path component of the request URL, for example+-- @\"/widgets\"@, without any query string. (Half of the stable replacement for+-- the pre-stable @http.target@; see 'urlQuery' for the other half.)+urlPath :: Text+urlPath = "url.path"++-- | @url.query@: the query component of the request URL, for example+-- @\"q=cat\"@, without the leading @?@. (The other half of the stable+-- replacement for the pre-stable @http.target@; see 'urlPath'.)+urlQuery :: Text+urlQuery = "url.query"++-- | @network.protocol.version@: the protocol version, for example @\"1.1\"@ or+-- @\"2\"@. (Stable replacement for the pre-stable @http.flavor@.)+networkProtocolVersion :: Text+networkProtocolVersion = "network.protocol.version"++-- | @db.system.name@: the database management system, for example+-- @\"postgresql\"@ or @\"mysql\"@. (Stable replacement for the pre-stable+-- @db.system@.)+dbSystemName :: Text+dbSystemName = "db.system.name"++-- | @db.query.text@: the database query text, for example+-- @\"SELECT * FROM users WHERE id = $1\"@. Record the /parameterized/ statement+-- (placeholders, not interpolated values) to keep cardinality low and avoid+-- leaking row data. (Stable replacement for the pre-stable @db.statement@.)+dbQueryText :: Text+dbQueryText = "db.query.text"++-- | @db.operation.name@: the name of the operation being executed, for example+-- @\"SELECT\"@ or @\"INSERT\"@. This is the low-cardinality command keyword, not+-- the full statement. (Stable replacement for the pre-stable @db.operation@.)+dbOperationName :: Text+dbOperationName = "db.operation.name"++-- | @db.collection.name@: the primary table (or collection) the operation acts+-- on, for example @\"users\"@. (Stable replacement for the pre-stable+-- @db.sql.table@ \/ @db.mongodb.collection@.)+dbCollectionName :: Text+dbCollectionName = "db.collection.name"++-- | @db.namespace@: the logical database name the connection is scoped to, for+-- example @\"orders\"@. (Stable replacement for the pre-stable @db.name@.)+dbNamespace :: Text+dbNamespace = "db.namespace"++-- | @db.operation.batch.size@: the number of queries in a batch operation, for+-- example the number of parameter rows passed to a multi-row @executeMany@.+dbOperationBatchSize :: Text+dbOperationBatchSize = "db.operation.batch.size"++-- | @messaging.system@: the messaging system, for example @\"kafka\"@,+-- @\"rabbitmq\"@, or @\"aws_sqs\"@.+messagingSystem :: Text+messagingSystem = "messaging.system"++-- | @messaging.operation.type@: the kind of operation, one of @\"create\"@,+-- @\"send\"@, @\"receive\"@, @\"process\"@, or @\"settle\"@. This is the+-- low-cardinality category that also selects the span kind (producer for+-- @send@ \/ @create@, consumer for @receive@ \/ @process@).+messagingOperationType :: Text+messagingOperationType = "messaging.operation.type"++-- | @messaging.operation.name@: the system-specific name of the operation, for+-- example @\"publish\"@, @\"ack\"@, or @\"receive\"@. Lower cardinality than the+-- destination, used as the leading word of the span name.+messagingOperationName :: Text+messagingOperationName = "messaging.operation.name"++-- | @messaging.destination.name@: the message destination, for example a topic+-- or queue name like @\"orders\"@.+messagingDestinationName :: Text+messagingDestinationName = "messaging.destination.name"++-- | @messaging.destination.template@: the low-cardinality template a destination+-- is derived from, for example @\"/users/{id}/notifications\"@. Prefer this over+-- 'messagingDestinationName' in the span name when destinations are dynamic.+messagingDestinationTemplate :: Text+messagingDestinationTemplate = "messaging.destination.template"++-- | @messaging.message.id@: the broker-assigned identifier of a single message.+messagingMessageId :: Text+messagingMessageId = "messaging.message.id"++-- | @messaging.message.conversation_id@: the conversation (or correlation)+-- identifier tying related messages together.+messagingMessageConversationId :: Text+messagingMessageConversationId = "messaging.message.conversation_id"++-- | @messaging.message.body.size@: the size of the message body in bytes.+messagingMessageBodySize :: Text+messagingMessageBodySize = "messaging.message.body.size"++-- | @messaging.batch.message_count@: the number of messages in a batch+-- operation.+messagingBatchMessageCount :: Text+messagingBatchMessageCount = "messaging.batch.message_count"++-- | @exception.type@: the type or class of an exception, for example+-- @\"IOException\"@.+exceptionType :: Text+exceptionType = "exception.type"++-- | @exception.message@: the human-readable exception message. (Already the+-- stable key; included here so all recorded keys live in one module.)+exceptionMessage :: Text+exceptionMessage = "exception.message"
+ src/Effectful/Tracing/SpanLimits.hs view
@@ -0,0 +1,126 @@+-- |+-- Module      : Effectful.Tracing.SpanLimits+-- Description : Per-span caps on attributes, events, links, and value length.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+-- Stability   : experimental+--+-- A span with no upper bound on what it records is a memory hazard: an+-- accidental loop that calls @addEvent@ or @addAttribute@ grows the in-flight+-- span without limit, and a stray multi-megabyte string value rides all the way+-- to the exporter. OpenTelemetry's SDK guards against this with __span limits__,+-- and this module is the same idea: a small 'SpanLimits' record that the+-- span-opening interpreters honour.+--+-- Four caps are modelled, each a @'Maybe' 'Int'@ where 'Nothing' means+-- unlimited:+--+-- * 'attributeCountLimit': the most attributes a span keeps. Attributes past the+--   cap are dropped (the earliest are kept).+-- * 'attributeValueLengthLimit': the most characters a string attribute value+--   keeps; longer values (and the elements of string arrays) are truncated.+-- * 'eventCountLimit': the most events a span keeps (earliest kept).+-- * 'linkCountLimit': the most links a span keeps (earliest kept).+--+-- 'defaultSpanLimits' matches the OpenTelemetry defaults (128 attributes, 128+-- events, 128 links, and no value-length cap); 'unlimitedSpanLimits' disables+-- every cap. The interpreters apply the count caps as a span records, so an+-- in-flight span cannot grow past the limit, and 'applySpanLimits' is the pure+-- transform that produces the final, capped-and-truncated span. Keeping that+-- transform pure is what makes the whole policy testable without running an+-- interpreter.+module Effectful.Tracing.SpanLimits+  ( -- * Limits+    SpanLimits (..)+  , defaultSpanLimits+  , unlimitedSpanLimits++    -- * Applying limits (pure)+  , applySpanLimits+  ) where++import Data.Text qualified as T+import Data.Vector qualified as V++import Effectful.Tracing.Attribute (Attribute (Attribute), AttributeValue (AttrText, AttrTextArray))+import Effectful.Tracing.Internal.Types+  ( Event (eventAttributes)+  , Link (linkAttributes)+  , Span (spanAttributes, spanEvents, spanLinks)+  )++-- | The per-span caps an interpreter enforces. Each count is a @'Maybe' 'Int'@:+-- 'Nothing' disables that cap, @'Just' n@ caps at @n@ (a negative @n@ is treated+-- as @0@).+data SpanLimits = SpanLimits+  { attributeCountLimit :: !(Maybe Int)+  -- ^ The most attributes a span keeps. Once reached, further attributes are+  -- dropped; the earliest-recorded are the ones kept.+  , attributeValueLengthLimit :: !(Maybe Int)+  -- ^ The most characters a string attribute value keeps. Longer 'AttrText'+  -- values, and the elements of 'AttrTextArray' values, are truncated to this+  -- many characters. Non-string values are unaffected.+  , eventCountLimit :: !(Maybe Int)+  -- ^ The most events a span keeps (earliest kept).+  , linkCountLimit :: !(Maybe Int)+  -- ^ The most links a span keeps (earliest kept).+  }+  deriving (Eq, Show)++-- | The OpenTelemetry default limits: 128 attributes, 128 events, 128 links, and+-- no value-length cap.+defaultSpanLimits :: SpanLimits+defaultSpanLimits =+  SpanLimits+    { attributeCountLimit = Just 128+    , attributeValueLengthLimit = Nothing+    , eventCountLimit = Just 128+    , linkCountLimit = Just 128+    }++-- | No caps at all: a span keeps every attribute, event, and link, and never+-- truncates a value. Useful in tests that assert on everything a computation+-- emitted.+unlimitedSpanLimits :: SpanLimits+unlimitedSpanLimits =+  SpanLimits+    { attributeCountLimit = Nothing+    , attributeValueLengthLimit = Nothing+    , eventCountLimit = Nothing+    , linkCountLimit = Nothing+    }++-- | Apply the limits to a completed span: cap its attributes, events, and links+-- to their counts (keeping the earliest), and truncate every string attribute+-- value (on the span, its events, and its links) to the value-length cap. Pure,+-- so it is the unit under test for the limit policy and is what every+-- span-opening interpreter runs as it finalizes a span.+applySpanLimits :: SpanLimits -> Span -> Span+applySpanLimits limits s =+  s+    { spanAttributes = map truncateAttr (capCount (attributeCountLimit limits) (spanAttributes s))+    , spanEvents = map truncateEventAttrs (capCount (eventCountLimit limits) (spanEvents s))+    , spanLinks = map truncateLinkAttrs (capCount (linkCountLimit limits) (spanLinks s))+    }+  where+    truncateAttr = truncateAttribute (attributeValueLengthLimit limits)+    truncateEventAttrs e = e {eventAttributes = map truncateAttr (eventAttributes e)}+    truncateLinkAttrs l = l {linkAttributes = map truncateAttr (linkAttributes l)}++-- | Keep at most @n@ of a list (the first @n@) when a cap is set; a negative cap+-- keeps none. 'Nothing' keeps everything.+capCount :: Maybe Int -> [a] -> [a]+capCount Nothing = id+capCount (Just n) = take (max 0 n)++-- | Truncate a string attribute value to the character cap, if one is set.+-- 'AttrText' is truncated; 'AttrTextArray' has each element truncated; every+-- other value is returned unchanged.+truncateAttribute :: Maybe Int -> Attribute -> Attribute+truncateAttribute Nothing attr = attr+truncateAttribute (Just n) (Attribute key value) = Attribute key (truncateValue (max 0 n) value)++truncateValue :: Int -> AttributeValue -> AttributeValue+truncateValue n (AttrText t) = AttrText (T.take n t)+truncateValue n (AttrTextArray v) = AttrTextArray (V.map (T.take n) v)+truncateValue _ value = value
+ src/Effectful/Tracing/Testing.hs view
@@ -0,0 +1,167 @@+-- |+-- Module      : Effectful.Tracing.Testing+-- Description : Helpers for testing code that uses the 'Effectful.Tracing.Tracer' effect.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+-- Stability   : experimental+--+-- A one-stop module for testing your own instrumentation. It re-exports the+-- in-memory capture interpreter (run a 'Effectful.Tracing.Tracer' computation,+-- collect the completed spans) and adds pure matchers and finders over the+-- captured @['Span']@, so a test can assert on span shape, parent/child+-- structure, attributes, status, events, and kind.+--+-- The matchers are plain predicates ('Bool') and lookups ('Maybe'), with no+-- dependency on any test framework, so they compose with @tasty-hunit@,+-- @hspec@, @hedgehog@, or anything else: pair them with your framework's+-- assertion combinator.+--+-- > import Effectful (runEff)+-- > import Effectful.Tracing (SpanStatus (Ok), withSpan, addAttribute, setStatus)+-- > import Effectful.Tracing.Testing+-- > import Test.Tasty.HUnit (assertBool, (@?=))+-- >+-- > test = do+-- >   captured <- newCapturedSpans+-- >   _ <- runEff . runTracerInMemory captured $+-- >     withSpan "handler" $ do+-- >       addAttribute "http.response.status_code" (200 :: Int)+-- >       setStatus Ok+-- >       withSpan "db.query" (pure ())+-- >   spans <- readCapturedSpans captured+-- >   case (findSpan "handler" spans, findSpan "db.query" spans) of+-- >     (Just handler, Just db) -> do+-- >       assertBool "db.query is a child of handler" (db `isChildOf` handler)+-- >       assertBool "handler is a root" (isRoot handler)+-- >       hasStatus Ok handler @?= True+-- >       lookupAttribute "http.response.status_code" handler+-- >         @?= Just (AttrInt 200)+-- >     _ -> assertBool "both spans were captured" False+module Effectful.Tracing.Testing+  ( -- * Capturing spans+    -- | Re-exported from "Effectful.Tracing.Interpreter.InMemory".+    CapturedSpans+  , newCapturedSpans+  , readCapturedSpans+  , runTracerInMemory+  , runTracerInMemoryWith+  , runTracerInMemoryWithLimits++    -- * Finding spans+  , findSpan+  , findSpans+  , rootSpans+  , childrenOf+  , descendantsOf++    -- * Structure+  , isRoot+  , isChildOf++    -- * Attributes+  , lookupAttribute+  , hasAttribute+  , hasAttributeValue++    -- * Status, events, and kind+  , hasStatus+  , lookupEvent+  , hasEvent+  , hasKind+  ) where++import Data.List (find)+import Data.Maybe (isJust, isNothing)+import Data.Text (Text)++import Effectful.Tracing.Attribute+  ( Attribute (attributeKey, attributeValue)+  , AttributeValue+  )+import Effectful.Tracing.Interpreter.InMemory+  ( CapturedSpans+  , childrenOf+  , findSpan+  , newCapturedSpans+  , readCapturedSpans+  , rootSpans+  , runTracerInMemory+  , runTracerInMemoryWith+  , runTracerInMemoryWithLimits+  )+import Effectful.Tracing.Internal.Types+  ( Event (eventName)+  , Span+      ( spanAttributes+      , spanContext+      , spanEvents+      , spanKind+      , spanParentContext+      , spanStatus+      )+  , SpanContext (spanContextSpanId, spanContextTraceId)+  , SpanKind+  , SpanStatus+  , spanName+  )++-- | All captured spans with the given name, in capture (completion) order.+-- Use this rather than 'findSpan' when a name can repeat (a loop body, a+-- retried operation) and you want every occurrence.+findSpans :: Text -> [Span] -> [Span]+findSpans name = filter ((== name) . spanName)++-- | The spans transitively beneath the given span: its children, their+-- children, and so on. Captured spans form a tree (each has at most one+-- parent), so this terminates and visits each descendant once.+descendantsOf :: Span -> [Span] -> [Span]+descendantsOf parent spans = go (childrenOf parent spans)+  where+    go [] = []+    go (s : rest) = s : go (childrenOf s spans <> rest)++-- | Whether a span is a trace root (it has no parent context).+isRoot :: Span -> Bool+isRoot = isNothing . spanParentContext++-- | @child \`isChildOf\` parent@ holds when @child@'s recorded parent is+-- @parent@'s own context (same trace id and span id).+isChildOf :: Span -> Span -> Bool+isChildOf child parent =+  case spanParentContext child of+    Just pc ->+      spanContextSpanId pc == spanContextSpanId parentContext+        && spanContextTraceId pc == spanContextTraceId parentContext+    Nothing -> False+  where+    parentContext = spanContext parent++-- | Look up a span attribute by key, returning its typed value if present.+lookupAttribute :: Text -> Span -> Maybe AttributeValue+lookupAttribute key s =+  attributeValue <$> find ((== key) . attributeKey) (spanAttributes s)++-- | Whether the span carries an attribute with the given key (any value).+hasAttribute :: Text -> Span -> Bool+hasAttribute key = isJust . lookupAttribute key++-- | Whether the span carries an attribute with the given key /and/ exactly the+-- given value.+hasAttributeValue :: Text -> AttributeValue -> Span -> Bool+hasAttributeValue key value s = lookupAttribute key s == Just value++-- | Whether the span ended with the given status.+hasStatus :: SpanStatus -> Span -> Bool+hasStatus status s = spanStatus s == status++-- | Look up the first event on the span with the given name.+lookupEvent :: Text -> Span -> Maybe Event+lookupEvent name s = find ((== name) . eventName) (spanEvents s)++-- | Whether the span recorded an event with the given name.+hasEvent :: Text -> Span -> Bool+hasEvent name = isJust . lookupEvent name++-- | Whether the span has the given kind.+hasKind :: SpanKind -> Span -> Bool+hasKind kind s = spanKind s == kind
+ test-space-leak/Main.hs view
@@ -0,0 +1,64 @@+-- |+-- Module      : Main+-- Description : Space-leak regression guard for the span lifecycle.+--+-- This is a standalone workload, separate from the main tasty suite, run under+-- a deliberately tiny maximum stack (@-K1K@, set in the cabal stanza). It opens+-- and closes a large number of spans through the in-memory interpreter and then+-- forces every captured span with a strict fold to a scalar.+--+-- The point of the tiny stack is to turn a space leak into a hard failure. If a+-- regression let completed spans accumulate as a chain of thunks (a lazy+-- accumulator, a non-strict sink write, an un-forced field), forcing them here+-- would build an O(n) evaluation stack and overflow @-K1K@, failing the test.+-- The current strict lifecycle (spans forced to WHNF before they reach the+-- sink, a strict 'foldl'' here) runs in O(1) stack regardless of span count.+--+-- It is intentionally tasty-free: the tasty/hedgehog machinery legitimately+-- needs more than a 1K stack, so it cannot share this process's RTS options.+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import Control.Monad (forM_, when)+import System.Exit (exitFailure)+#if !MIN_VERSION_base(4,20,0)+import Data.List (foldl')+#endif++import Effectful (Eff, runEff, (:>))++import Effectful.Tracing (Span (spanAttributes), Tracer, addAttribute, withSpan)+import Effectful.Tracing.Interpreter.InMemory+  ( newCapturedSpans+  , readCapturedSpans+  , runTracerInMemory+  )++-- | How many spans to open, close, and then force. Large enough that an O(n)+-- stack from a thunk chain would blow the 1K limit many times over.+spanCount :: Int+spanCount = 100000++-- | A flat sequence of completed spans, each carrying one attribute.+workload :: (Tracer :> es) => Eff es ()+workload =+  forM_ [1 .. spanCount] $ \i ->+    withSpan "tick" (addAttribute "i" (i :: Int))++main :: IO ()+main = do+  total <- runEff $ do+    captured <- newCapturedSpans+    _ <- runTracerInMemory captured workload+    spans <- readCapturedSpans captured+    -- Strict fold to a scalar. A leaky lazy accumulator (or un-forced span+    -- field) would defer this work into an O(n) thunk chain and overflow the+    -- 1K stack when the result is finally demanded below.+    pure $! foldl' (\acc s -> acc + length (spanAttributes s)) (0 :: Int) spans+  when (total /= spanCount) $ do+    putStrLn ("space-leak guard: expected " <> show spanCount <> " attributes, saw " <> show total)+    exitFailure+  putStrLn ("space-leak guard: forced " <> show spanCount <> " completed spans under -K1K")
+ test/Effectful/Tracing/AsyncExceptionSpec.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- Module      : Effectful.Tracing.AsyncExceptionSpec+-- Description : 'withSpan' finalizes its span even when interrupted.+--+-- Span finalization runs inside 'Effectful.Exception.generalBracket', so it+-- fires on every exit: a normal return, a synchronous exception, a 'timeout'+-- cancellation, or an asynchronous 'killThread'. These tests interrupt a+-- 'withSpan' body each of those abnormal ways and assert the span still reaches+-- the sink with its end time set, an 'Error' status, and an @exception@ event.+-- This is the guarantee callers rely on: an interrupted operation must not+-- silently drop its span or leave it open.+module Effectful.Tracing.AsyncExceptionSpec+  ( tests+  ) where++import Control.Concurrent qualified as Conc+import Control.Exception (ErrorCall (ErrorCall), SomeException)+import Control.Monad.IO.Class (liftIO)+import Data.Text (Text)+import Data.Text qualified as T++import Effectful (Eff, IOE, runEff)+import Effectful.Concurrent (Concurrent, forkIO, killThread, runConcurrent, threadDelay)+import Effectful.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Effectful.Exception (finally, throwIO, try)+import Effectful.Timeout (Timeout, runTimeout, timeout)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++import Effectful.Tracing+  ( Event (eventName)+  , Span+  , SpanStatus (Error)+  , Tracer+  , spanEndTime+  , spanEvents+  , spanStartTime+  , spanStatus+  , withSpan+  )+import Effectful.Tracing.Interpreter.InMemory+  ( findSpan+  , newCapturedSpans+  , readCapturedSpans+  , runTracerInMemory+  )++tests :: TestTree+tests =+  testGroup+    "Async-exception finalization"+    [ testCase "a synchronous exception finalizes the span and re-propagates" $ do+        spans <-+          captureCatching $+            withSpan "boom" (throwIO (ErrorCall "kaboom"))+        s <- expectSpan "boom" spans+        assertErrorWithEvent s+        assertBool+          "the original message survives in the Error status"+          (statusMessageContains "kaboom" (spanStatus s))+    , testCase "a timeout cancellation finalizes the span" $ do+        -- The window between starting the action and the timer firing must be+        -- wide enough that the span is reliably open before the cancellation+        -- arrives, even under a loaded parallel suite; the body then sleeps far+        -- longer than the timeout so the timeout always wins. A tight timeout+        -- here races the span-open and can cancel before any span exists.+        (result, spans) <-+          runTimed $+            timeout 100000 (withSpan "slow" (liftIO (Conc.threadDelay 10000000)))+        result @?= Nothing+        s <- expectSpan "slow" spans+        assertErrorWithEvent s+    , testCase "an asynchronous killThread finalizes the span" $ do+        ((), spans) <-+          runConcurrentCapture $ do+            started <- newEmptyMVar+            done <- newEmptyMVar+            tid <-+              forkIO $+                withSpan "cancelled" (putMVar started () >> threadDelay 1000000)+                  `finally` putMVar done ()+            -- Wait until the span is open, kill the thread mid-flight, then+            -- wait for the bracket cleanup (the @finally@) to have run.+            takeMVar started+            killThread tid+            takeMVar done+        s <- expectSpan "cancelled" spans+        assertErrorWithEvent s+    ]++-- | Assert the span looks like one finalized through the exception path: a+-- non-decreasing end time, an 'Error' status, and a recorded @exception@ event.+assertErrorWithEvent :: Span -> IO ()+assertErrorWithEvent s = do+  assertBool "the end time is not before the start time" (spanEndTime s >= spanStartTime s)+  assertBool "the status is Error" (isError (spanStatus s))+  assertBool+    "an exception event is recorded"+    (any ((== "exception") . eventName) (spanEvents s))++isError :: SpanStatus -> Bool+isError (Error _) = True+isError _ = False++statusMessageContains :: Text -> SpanStatus -> Bool+statusMessageContains needle (Error msg) = needle `T.isInfixOf` msg+statusMessageContains _ _ = False++-- | Run a traced program through the in-memory interpreter, swallowing any+-- synchronous exception it raises, and return the captured spans. The span is+-- emitted during the @generalBracket@ cleanup, before the exception propagates,+-- so it is already in the buffer by the time we read it.+captureCatching :: Eff '[Tracer, IOE] () -> IO [Span]+captureCatching program = runEff $ do+  captured <- newCapturedSpans+  _ <- try @SomeException (runTracerInMemory captured program)+  readCapturedSpans captured++-- | Run a program needing 'timeout', returning its result and captured spans.+runTimed :: Eff '[Tracer, Timeout, IOE] a -> IO (a, [Span])+runTimed program = runEff . runTimeout $ do+  captured <- newCapturedSpans+  result <- runTracerInMemory captured program+  spans <- readCapturedSpans captured+  pure (result, spans)++-- | Run a program needing 'Concurrent', returning its result and captured spans.+runConcurrentCapture :: Eff '[Tracer, Concurrent, IOE] a -> IO (a, [Span])+runConcurrentCapture program = runEff . runConcurrent $ do+  captured <- newCapturedSpans+  result <- runTracerInMemory captured program+  spans <- readCapturedSpans captured+  pure (result, spans)++expectSpan :: Text -> [Span] -> IO Span+expectSpan name spans =+  maybe (assertFailure ("expected a span named " <> show name)) pure (findSpan name spans)
+ test/Effectful/Tracing/AttributeSpec.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.AttributeSpec+-- Description : Tests for the 'ToAttributeValue' conversions and '(.=)'.+--+-- One conversion per instance: scalars map to the matching scalar variant,+-- 'Int' and 'Float' widen to their 64-bit representations, and both list and+-- 'Vector' inputs land on the homogeneous-array variants. '(.=)' is the+-- key/value sugar over 'toAttributeValue'.+module Effectful.Tracing.AttributeSpec+  ( tests+  ) where++import Data.Int (Int64)+import Data.Text (Text)+import Data.Vector qualified as V++import Hedgehog (Gen, Property, forAll, property, (===))+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))+import Test.Tasty.Hedgehog (testProperty)++import Effectful.Tracing.Attribute+  ( Attribute (Attribute)+  , AttributeValue (..)+  , toAttributeValue+  , (.=)+  )++tests :: TestTree+tests =+  testGroup+    "Attribute conversions"+    [ testGroup "scalars" scalarTests+    , testGroup "arrays" arrayTests+    , testGroup "(.=) and identity" sugarTests+    , testGroup "numeric widening" wideningProperties+    ]++scalarTests :: [TestTree]+scalarTests =+  [ testCase "Text maps to AttrText" $+      toAttributeValue ("hello" :: Text) @?= AttrText "hello"+  , testCase "String maps to AttrText" $+      toAttributeValue ("hello" :: String) @?= AttrText "hello"+  , testCase "Bool maps to AttrBool" $+      toAttributeValue True @?= AttrBool True+  , testCase "Int64 maps to AttrInt" $+      toAttributeValue (7 :: Int64) @?= AttrInt 7+  , testCase "Double maps to AttrDouble" $+      toAttributeValue (1.5 :: Double) @?= AttrDouble 1.5+  , testCase "Float widens to AttrDouble" $+      toAttributeValue (0.5 :: Float) @?= AttrDouble 0.5+  ]++arrayTests :: [TestTree]+arrayTests =+  [ testCase "[Text] maps to AttrTextArray" $+      toAttributeValue (["a", "b"] :: [Text]) @?= AttrTextArray (V.fromList ["a", "b"])+  , testCase "[Bool] maps to AttrBoolArray" $+      toAttributeValue [True, False] @?= AttrBoolArray (V.fromList [True, False])+  , testCase "[Int64] maps to AttrIntArray" $+      toAttributeValue ([1, 2] :: [Int64]) @?= AttrIntArray (V.fromList [1, 2])+  , testCase "[Int] widens to AttrIntArray" $+      toAttributeValue ([1, 2] :: [Int]) @?= AttrIntArray (V.fromList [1, 2])+  , testCase "[Double] maps to AttrDoubleArray" $+      toAttributeValue ([1.5, 2.5] :: [Double]) @?= AttrDoubleArray (V.fromList [1.5, 2.5])+  , testCase "[Float] widens to AttrDoubleArray" $+      toAttributeValue ([0.5, 1.5] :: [Float]) @?= AttrDoubleArray (V.fromList [0.5, 1.5])+  , testCase "Vector Text maps to AttrTextArray" $+      toAttributeValue (V.fromList ["a"] :: V.Vector Text) @?= AttrTextArray (V.fromList ["a"])+  , testCase "Vector Bool maps to AttrBoolArray" $+      toAttributeValue (V.fromList [True]) @?= AttrBoolArray (V.fromList [True])+  , testCase "Vector Int64 maps to AttrIntArray" $+      toAttributeValue (V.fromList [9] :: V.Vector Int64) @?= AttrIntArray (V.fromList [9])+  , testCase "Vector Double maps to AttrDoubleArray" $+      toAttributeValue (V.fromList [9.5] :: V.Vector Double) @?= AttrDoubleArray (V.fromList [9.5])+  ]++sugarTests :: [TestTree]+sugarTests =+  [ testCase "AttributeValue maps to itself (identity instance)" $+      toAttributeValue (AttrInt 3) @?= AttrInt 3+  , testCase "(.=) pairs the key with the converted value" $+      ("http.status_code" .= (200 :: Int)) @?= Attribute "http.status_code" (AttrInt 200)+  ]++wideningProperties :: [TestTree]+wideningProperties =+  [ testProperty "Int widens to AttrInt by fromIntegral" prop_intWidening+  , testProperty "Float widens to AttrDouble by realToFrac" prop_floatWidening+  ]++prop_intWidening :: Property+prop_intWidening = property $ do+  n <- forAll (Gen.integral (Range.linearFrom 0 minBound maxBound) :: Gen Int)+  toAttributeValue n === AttrInt (fromIntegral n)++prop_floatWidening :: Property+prop_floatWidening = property $ do+  f <- forAll (Gen.float (Range.linearFracFrom 0 (-1.0e6) 1.0e6))+  toAttributeValue f === AttrDouble (realToFrac f)
+ test/Effectful/Tracing/BaggageSpec.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.BaggageSpec+-- Description : Tests for the baggage value, the ambient effect, and the codec.+--+-- Three areas: the pure 'Baggage' operations (insert / lookup / delete / list),+-- the ambient 'BaggageContext' effect (reading the in-scope baggage and the+-- lexical scoping of 'withBaggageEntry' / 'localBaggage'), and the W3C @baggage@+-- header codec (render / parse, percent-encoding, metadata, whitespace, the+-- entry cap, and skipping malformed members), including 'injectBaggage' /+-- 'extractBaggage' round-trips.+module Effectful.Tracing.BaggageSpec+  ( tests+  ) where++import Data.Text qualified as T++import Effectful (Eff, runPureEff)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import Effectful.Tracing.Baggage+  ( BaggageContext+  , BaggageEntry (BaggageEntry)+  , baggageFromList+  , baggageSize+  , baggageToList+  , deleteBaggage+  , emptyBaggage+  , getBaggage+  , insertBaggage+  , lookupBaggage+  , lookupBaggageValue+  , localBaggage+  , nullBaggage+  , runBaggage+  , runBaggageWith+  , withBaggageEntry+  )+import Effectful.Tracing.Propagation.Baggage+  ( extractBaggage+  , injectBaggage+  , maxBaggageEntries+  , parseBaggage+  , renderBaggage+  )++tests :: TestTree+tests =+  testGroup+    "Baggage"+    [ testGroup "pure operations" pureOps+    , testGroup "ambient effect" effectOps+    , testGroup "codec" codecOps+    ]++pureOps :: [TestTree]+pureOps =+  [ testCase "empty has no entries" $ do+      nullBaggage emptyBaggage @?= True+      baggageSize emptyBaggage @?= 0+  , testCase "insert then lookup" $ do+      let b = insertBaggage "k" "v" emptyBaggage+      lookupBaggageValue "k" b @?= Just "v"+      lookupBaggage "k" b @?= Just (BaggageEntry "v" Nothing)+      lookupBaggageValue "absent" b @?= Nothing+  , testCase "insert replaces an existing key" $ do+      let b = insertBaggage "k" "second" (insertBaggage "k" "first" emptyBaggage)+      lookupBaggageValue "k" b @?= Just "second"+      baggageSize b @?= 1+  , testCase "delete removes a key" $ do+      let b = deleteBaggage "k" (insertBaggage "k" "v" emptyBaggage)+      lookupBaggageValue "k" b @?= Nothing+      nullBaggage b @?= True+  , testCase "toList is ordered by key" $ do+      let b = insertBaggage "b" "2" (insertBaggage "a" "1" (insertBaggage "c" "3" emptyBaggage))+      map fst (baggageToList b) @?= ["a", "b", "c"]+  ]++effectOps :: [TestTree]+effectOps =+  [ testCase "runBaggage starts empty" $+      runPure (nullBaggage <$> getBaggage) @?= True+  , testCase "runBaggageWith seeds the ambient baggage" $+      runPureEff (runBaggageWith seeded (lookupBaggageValue "tenant" <$> getBaggage))+        @?= Just "acme"+  , testCase "withBaggageEntry is lexically scoped" $ do+      let result = runPure $ do+            before <- nullBaggage <$> getBaggage+            inside <- withBaggageEntry "x" "1" (lookupBaggageValue "x" <$> getBaggage)+            after <- lookupBaggageValue "x" <$> getBaggage+            pure (before, inside, after)+      result @?= (True, Just "1", Nothing)+  , testCase "localBaggage nests" $ do+      let result = runPure $+            withBaggageEntry "a" "1" $+              withBaggageEntry "b" "2" $ do+                b <- getBaggage+                pure (lookupBaggageValue "a" b, lookupBaggageValue "b" b)+      result @?= (Just "1", Just "2")+  , testCase "localBaggage can delete for a scope" $ do+      let result = runPure $+            withBaggageEntry "a" "1" $ do+              dropped <- localBaggage (deleteBaggage "a") (lookupBaggageValue "a" <$> getBaggage)+              restored <- lookupBaggageValue "a" <$> getBaggage+              pure (dropped, restored)+      result @?= (Nothing, Just "1")+  ]+  where+    seeded = baggageFromList [("tenant", BaggageEntry "acme" Nothing)]++codecOps :: [TestTree]+codecOps =+  [ testCase "render joins entries ordered by key" $+      renderBaggage (insertBaggage "b" "2" (insertBaggage "a" "1" emptyBaggage))+        @?= "a=1,b=2"+  , testCase "render percent-encodes values" $+      renderBaggage (insertBaggage "city" "New York" emptyBaggage)+        @?= "city=New%20York"+  , testCase "render appends metadata verbatim" $+      renderBaggage (baggageFromList [("k", BaggageEntry "v" (Just "ttl=30"))])+        @?= "k=v;ttl=30"+  , testCase "render of empty is the empty string" $+      renderBaggage emptyBaggage @?= ""+  , testCase "parse reads multiple entries" $ do+      let b = parseBaggage "k1=v1,k2=v2"+      lookupBaggageValue "k1" b @?= Just "v1"+      lookupBaggageValue "k2" b @?= Just "v2"+  , testCase "parse trims surrounding whitespace" $ do+      let b = parseBaggage " k1 = v1 , k2 = v2 "+      lookupBaggageValue "k1" b @?= Just "v1"+      lookupBaggageValue "k2" b @?= Just "v2"+  , testCase "parse percent-decodes values" $+      lookupBaggageValue "city" (parseBaggage "city=New%20York") @?= Just "New York"+  , testCase "parse keeps metadata as opaque text" $+      lookupBaggage "k" (parseBaggage "k=v;ttl=30;public")+        @?= Just (BaggageEntry "v" (Just "ttl=30;public"))+  , testCase "parse skips malformed members" $ do+      let b = parseBaggage "k1=v1,noequals,=novalue,k3=v3"+      map fst (baggageToList b) @?= ["k1", "k3"]+  , testCase "parse caps the entry count" $ do+      let header = T.intercalate "," ["k" <> T.pack (show i) <> "=v" | i <- [1 .. 200 :: Int]]+      baggageSize (parseBaggage header) @?= maxBaggageEntries+  , testCase "round-trip preserves values needing encoding" $ do+      let b = insertBaggage "k" "a b,c;d" emptyBaggage+      parseBaggage (renderBaggage b) @?= b+  , testCase "injectBaggage emits the header from ambient baggage" $+      runPure (withBaggageEntry "k" "v" injectBaggage)+        @?= [("baggage", "k=v")]+  , testCase "injectBaggage emits nothing when empty" $+      runPure injectBaggage @?= []+  , testCase "extractBaggage reads the header" $+      lookupBaggageValue "k" (extractBaggage [("baggage", "k=v")]) @?= Just "v"+  , testCase "extractBaggage on a missing header is empty" $+      nullBaggage (extractBaggage [("other", "x")]) @?= True+  ]++-- | Run a 'BaggageContext' computation that needs no other effects, starting+-- from empty baggage.+runPure :: Eff '[BaggageContext] a -> a+runPure = runPureEff . runBaggage
+ test/Effectful/Tracing/CompileTest.hs view
@@ -0,0 +1,773 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module      : Effectful.Tracing.CompileTest+-- Description : Compile-only checks that the public API and the documented+--               examples still typecheck.+--+-- Two compile-only checks, both of which turn the test suite red if the public+-- surface stops typechecking. Neither runs.+--+-- * @smart-constructor API typechecks@ pins the core emit/lifecycle surface to+--   a concrete effect stack.+-- * @documentation examples typecheck@ mirrors the code blocks in @README.md@,+--   @docs/tutorial.md@, and @docs/cookbook.md@. Those blocks are deliberately+--   pedagogical fragments (undefined placeholder names, scattered imports, bare+--   expressions), so they cannot be compiled in place by cabal-docspec or+--   markdown-unlit. Instead each is reproduced here against the real API: a+--   renamed export or changed signature breaks this module, flagging the docs+--   as stale. The placeholder types and effects are stubbed once below. This+--   checks the API shapes the docs use, not the literal doc bytes, so prose+--   edits that change a call still need the matching mirror updated here.+module Effectful.Tracing.CompileTest+  ( tests+  ) where++import Control.Exception (ErrorCall (ErrorCall), toException)+import Data.Text (Text)++import Effectful (Dispatch (Dynamic), DispatchOf, Eff, Effect, IOE, runEff, (:>))+import Effectful.Concurrent (Concurrent)+import Effectful.Dispatch.Dynamic (send)+import Network.HTTP.Types (Header)+import System.IO (hIsTerminalDevice, stderr)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import Effectful.Tracing+  ( Span+  , SpanArguments (attributes, kind)+  , SpanContext+  , SpanKind (Client)+  , SpanStatus (Error, Ok)+  , Tracer+  , addAttribute+  , addAttributes+  , addEvent+  , alwaysOn+  , defaultParentBasedConfig+  , defaultSpanArguments+  , extractContext+  , getActiveSpan+  , parentBased+  , recordException+  , setStatus+  , traceIdRatioBased+  , withRemoteParent+  , withSpan+  , withSpan'+  , (.=)+  )+import Effectful.Tracing.Attribute (Attribute (Attribute), AttributeValue (AttrBool, AttrInt))+import Effectful.Tracing.EnvConfig+  ( EnvConfig (resourceAttributes, serviceName, traceContextPropagators, tracesSampler)+  , readEnvConfig+  )+import Effectful.Tracing.Baggage+  ( BaggageContext+  , getBaggage+  , lookupBaggageValue+  , runBaggageWith+  , withBaggageEntry+  )+import Control.Monad.IO.Class (liftIO)+import Effectful.Tracing.Instrumentation.Database+  ( DatabaseQuery (queryCollection, queryOperation, queryText)+  , databaseQuery+  , withQuerySpan+  )+import Effectful.Tracing.Instrumentation.Messaging+  ( MessagingOperation (messagingDestination)+  , MessagingOperationType (Process, Send)+  , injectMessageHeaders+  , messagingOperation+  , withConsumerSpan+  , withMessagingSpan+  )+import Effectful.Tracing.Propagation.B3 (extractContextB3, injectContextB3)+import Effectful.Tracing.Propagation.Baggage (extractBaggage, injectBaggage)+import Effectful.Tracing.Propagation.Composite+  ( BaggagePropagator+  , TraceContextPropagator+  , b3Single+  , extractBaggageAll+  , extractContextFirst+  , injectBaggageAll+  , injectContextAll+  , jaegerBaggage+  , w3cBaggage+  , w3cTraceContext+  )+import Effectful.Tracing.Log (activeCorrelationFields)+import Effectful.Tracing.Propagation.Jaeger+  ( extractBaggageJaeger+  , extractContextJaeger+  , injectContextJaeger+  )+import Effectful.Tracing.Testing+  ( findSpan+  , hasStatus+  , isChildOf+  , isRoot+  , lookupAttribute+  , runTracerInMemory+  )+import Effectful.Tracing.Concurrent (concurrentlyInstrumented, forkLinked)+import Effectful.Tracing.Interpreter.InMemory+  ( newCapturedSpans+  , readCapturedSpans+  , runTracerInMemoryWith+  , runTracerInMemoryWithLimits+  )+import Effectful.Tracing.Interpreter.NoOp (runTracerNoOp)+import Effectful.Tracing.Interpreter.PrettyPrint+  ( PrettyPrintConfig (showEvents, timeFormat, useColor)+  , TimeFormat (RelativeToTraceStart)+  , defaultPrettyPrintConfig+  , runTracerPretty+  )+import Effectful.Tracing.Sampler+  ( Sampler (Sampler, samplerName, shouldSample)+  , SamplerInput (initialAttributes)+  , SamplingDecision (RecordAndSample)+  , simpleResult+  )+import Effectful.Tracing.SpanLimits+  ( SpanLimits (attributeValueLengthLimit, eventCountLimit)+  , defaultSpanLimits+  )++#ifdef WAI+import Data.Text.Encoding (decodeUtf8Lenient)+import Network.Wai (Application, Request, rawPathInfo, requestMethod)+import Effectful.Tracing.Instrumentation.Wai (traceMiddleware, traceMiddlewareWith)+#endif++#ifdef HTTP_CLIENT+import Network.HTTP.Client (Manager, Response, parseRequest)+import Data.ByteString.Lazy (ByteString)+import Effectful.Tracing.Instrumentation.HttpClient (httpLbsTraced)+#endif++#ifdef POSTGRESQL_SIMPLE+import Database.PostgreSQL.Simple (Connection, Only (..))+import Effectful.Tracing.Instrumentation.PostgresqlSimple qualified as Pg+#endif++#ifdef SQLITE_SIMPLE+import Database.SQLite.Simple qualified as SqliteDb+import Effectful.Tracing.Instrumentation.SqliteSimple qualified as Sqlite+#endif++#ifdef VALIANT+import Data.Int (Int64)+import Valiant (Statement, mkStatement)+import Valiant.Effectful (Valiant)+import Effectful.Tracing.Instrumentation.Valiant qualified as ValiantT+#endif++#ifdef AMQP_BINDING+import Network.AMQP (Ack (Ack), Channel, Message (msgBody), newMsg)+import Effectful.Tracing.Instrumentation.Amqp qualified as Amqp+#endif++#ifdef SERVANT+import Data.Proxy (Proxy (Proxy))+#ifndef WAI+import Network.Wai (Application)+#endif+import Servant (Capture, Get, PlainText, Server, serve, type (:<|>) ((:<|>)))+import Servant qualified as Sv+import Effectful.Tracing.Instrumentation.Servant (WithSpanName, traceServantMiddleware)+#endif++#ifdef OTEL+import Effectful.Tracing.Interpreter.OpenTelemetry (OtelConfig (..), runTracerOTel)+#endif++tests :: TestTree+tests =+  testGroup+    "Compile-only checks"+    [ testCase "smart-constructor API typechecks" (compiles @?= ())+    , testCase "documentation examples typecheck" (docExamples @?= ())+    ]++-- | Forcing the example programs to a concrete effect stack references them+-- (so @-Wunused-top-binds@ stays quiet) and pins their otherwise-polymorphic+-- types, without running them.+compiles :: ()+compiles =+  (nestedSpans :: Eff '[Tracer, IOE] Int)+    `seq` (spanWithArguments :: Eff '[Tracer] ())+    `seq` ()++-- | Nested spans with attribute, event, and status annotations.+nestedSpans :: Tracer :> es => Eff es Int+nestedSpans = withSpan "outer" $ do+  addAttribute "user.id" ("u123" :: Text)+  result <- withSpan "inner" $ do+    addEvent "fetching" []+    pure (42 :: Int)+  setStatus Ok+  pure result++-- | Exercises 'withSpan'' with explicit arguments, the remaining emit+-- operations, and 'getActiveSpan'.+spanWithArguments :: Tracer :> es => Eff es ()+spanWithArguments =+  withSpan' "http.get" defaultSpanArguments {kind = Client} $ do+    addAttributes ["http.method" .= ("GET" :: Text), "http.status_code" .= (200 :: Int)]+    recordException (toException (userError "transient"))+    setStatus (Error "upstream timeout")+    active <- getActiveSpan+    case active :: Maybe SpanContext of+      Nothing -> pure ()+      Just _ -> pure ()++-- ---------------------------------------------------------------------------+-- Documentation examples+--+-- One binding per code block in the docs, named for its source. References to+-- application-specific types and effects (a database, a job queue, an order+-- record) are stubbed once here so the library calls keep their documented+-- shapes.+-- ---------------------------------------------------------------------------++-- | References every doc mirror at a concrete type so the block must typecheck.+-- Flag-gated interpreters and instrumentation are folded in conditionally.+docExamples :: ()+docExamples =+  (cbLoadUser :: UserId -> Eff '[Database, Tracer] User)+    `seq` (cbHandleOrder :: Order -> Eff '[Tracer] ())+    `seq` (cbPublishOrder :: Eff '[Tracer] [(Text, Text)])+    `seq` (cbConsumeOrder :: [(Text, Text)] -> Eff '[Tracer] () -> Eff '[Tracer] ())+    `seq` samplerName cbPriorityOr1Percent+    `seq` (cbRiskyCharge :: Eff '[Tracer] ())+    `seq` (cbPrioritySampledRun :: Eff '[Tracer, IOE] () -> IO [Span])+    `seq` (cbConsume :: [Header] -> Eff '[Tracer] () -> Eff '[Tracer] ())+    `seq` (cbB3Consume :: [Header] -> Eff '[Tracer] () -> Eff '[Tracer] ())+    `seq` (cbB3Forward :: Eff '[Tracer] [Header])+    `seq` (cbJaegerConsume :: [Header] -> Eff '[BaggageContext, Tracer] () -> Eff '[Tracer] ())+    `seq` (cbJaegerForward :: Eff '[Tracer] [Header])+    `seq` (cbCompositeConsume :: [Header] -> Eff '[Tracer] () -> Eff '[Tracer] ())+    `seq` (cbCompositeForward :: Eff '[Tracer] [Header])+    `seq` (cbCompositeServe :: [Header] -> Eff '[BaggageContext] () -> Eff '[] ())+    `seq` (cbCompositeBaggageForward :: Eff '[BaggageContext] [Header])+    `seq` (cbEnvConfigMain :: IO ())+    `seq` (cbServeWithBaggage :: [Header] -> Eff '[BaggageContext, Tracer] () -> Eff '[Tracer] ())+    `seq` (cbPriorityOf :: Eff '[BaggageContext] (Maybe Text))+    `seq` (cbHandleBaggage :: Eff '[BaggageContext, Tracer] [Header])+    `seq` (cbCheckHandlerTrace :: IO ())+    `seq` (cbLogEvent :: (Text -> [(Text, Text)] -> Eff '[Tracer] ()) -> Text -> Eff '[Tracer] ())+    `seq` (cbHandleRequest :: (Text -> [(Text, Text)] -> Eff '[Tracer] ()) -> Eff '[Tracer] ())+    `seq` (cbFetchActiveUsers :: Eff '[Tracer, IOE] [(Int, Text)])+    `seq` (cbWorker :: Eff '[Queue, Tracer] ())+    `seq` (cbEnqueueBackground :: Eff '[Tracer, Concurrent] ())+    `seq` (cbPrettyRun :: Eff '[Tracer, IOE] () -> IO ())+    `seq` (cbBoundedRun :: Eff '[Tracer, IOE] () -> IO [Span])+    `seq` (tutCheckout :: Eff '[Tracer] Int)+    `seq` (tutAnnotated :: Eff '[Tracer] ())+    `seq` (tutSampledRun :: Eff '[Tracer, IOE] () -> IO [Span])+    `seq` (tutFanOut :: Eff '[Tracer, Concurrent] (Int, Int))+    `seq` (readmeCompute :: Eff '[Tracer] Int)+    `seq` (readmeNoOpMain :: IO ())+    `seq` (readmePrettyMain :: IO ())+    `seq` stubConstructors+    `seq` waiExamples+    `seq` httpClientExamples+    `seq` postgresqlSimpleExamples+    `seq` sqliteSimpleExamples+    `seq` valiantExamples+    `seq` amqpExamples+    `seq` servantExamples+    `seq` otelExamples+    `seq` ()++-- Stub application types/effects the docs reference.++-- | The docs use only the field selectors of the stub types, never their+-- constructors, so reference the constructors here to keep @-Wunused-top-binds@+-- quiet. Never evaluated beyond WHNF.+stubConstructors :: (UserId, User, Job, Order)+stubConstructors = (UserId "", User, Job "", Order "" 0 "" False 0)++newtype UserId = UserId Text++data User = User++newtype Job = Job {jobId :: Text}++data Order = Order+  { orderId :: Text+  , totalCents :: Int+  , tierName :: Text+  , isExpress :: Bool+  , lineCount :: Int+  }++data Database :: Effect where+  QueryUser :: UserId -> Database m User++type instance DispatchOf Database = Dynamic++queryUser :: Database :> es => UserId -> Eff es User+queryUser = send . QueryUser++data Queue :: Effect where+  TakeJob :: Queue m Job++type instance DispatchOf Queue = Dynamic++takeJob :: Queue :> es => Eff es Job+takeJob = send TakeJob++-- cookbook: "Trace an existing function"+cbLoadUser :: (Database :> es, Tracer :> es) => UserId -> Eff es User+cbLoadUser uid = withSpan "loadUser" $ queryUser uid++-- cookbook: "Attach structured fields"+cbHandleOrder :: Tracer :> es => Order -> Eff es ()+cbHandleOrder order = withSpan "handleOrder" $ do+  addAttribute "order.id" (orderId order)+  addAttribute "order.total_cents" (totalCents order)+  addAttributes+    [ "customer.tier" .= tierName order+    , "order.express" .= isExpress order+    , "order.line_count" .= lineCount order+    ]+  addEvent "payment.authorized" ["gateway" .= ("stripe" :: Text)]++-- cookbook: "Trace a message producer and consumer" (producer)+cbPublishOrder :: (Tracer :> es) => Eff es [(Text, Text)]+cbPublishOrder =+  withMessagingSpan+    (messagingOperation "kafka" Send) {messagingDestination = Just "orders"}+    injectMessageHeaders++-- cookbook: "Trace a message producer and consumer" (consumer)+cbConsumeOrder :: (Tracer :> es) => [(Text, Text)] -> Eff es a -> Eff es a+cbConsumeOrder headers =+  withConsumerSpan headers (messagingOperation "kafka" Process) {messagingDestination = Just "orders"}++-- cookbook: "Sample but keep what matters" (custom sampler)+cbPriorityOr1Percent :: Sampler+cbPriorityOr1Percent =+  Sampler+    { samplerName = "PriorityOr1Percent"+    , shouldSample = \input ->+        if flagged (initialAttributes input)+          then pure (simpleResult RecordAndSample)+          else shouldSample (traceIdRatioBased 0.01) input+    }+  where+    flagged = any (\(Attribute k v) -> k == "sampling.priority" && v == AttrBool True)++-- cookbook: "Sample but keep what matters" (flag a span)+cbRiskyCharge :: Tracer :> es => Eff es ()+cbRiskyCharge =+  withSpan' "charge" defaultSpanArguments {attributes = ["sampling.priority" .= True]} $+    pure ()++-- cookbook: "Sample but keep what matters" (run with the custom sampler)+cbPrioritySampledRun :: Eff '[Tracer, IOE] a -> IO [Span]+cbPrioritySampledRun action = runEff $ do+  captured <- newCapturedSpans+  _ <- runTracerInMemoryWith cbPriorityOr1Percent captured action+  readCapturedSpans captured++-- cookbook: "Connect inbound and outbound HTTP traces" (continue a remote parent)+cbConsume :: Tracer :> es => [Header] -> Eff es a -> Eff es a+cbConsume headers =+  maybe id withRemoteParent (extractContext headers)++-- cookbook: "Interoperate with B3 (Zipkin) headers" (continue a B3 remote parent)+cbB3Consume :: Tracer :> es => [Header] -> Eff es a -> Eff es a+cbB3Consume headers =+  maybe id withRemoteParent (extractContextB3 headers)++-- cookbook: "Interoperate with B3 (Zipkin) headers" (forward as a single b3 header)+cbB3Forward :: Tracer :> es => Eff es [Header]+cbB3Forward = injectContextB3++-- cookbook: "Interoperate with Jaeger (uber-trace-id) headers" (continue + baggage)+cbJaegerConsume :: Tracer :> es => [Header] -> Eff (BaggageContext : es) a -> Eff es a+cbJaegerConsume headers =+  runBaggageWith (extractBaggageJaeger headers)+    . maybe id withRemoteParent (extractContextJaeger headers)++-- cookbook: "Interoperate with Jaeger (uber-trace-id) headers" (forward uber-trace-id)+cbJaegerForward :: Tracer :> es => Eff es [Header]+cbJaegerForward = injectContextJaeger++-- cookbook: "Combine several propagators" (the configured trace-context list)+cbPropagators :: [TraceContextPropagator]+cbPropagators = [w3cTraceContext, b3Single]++-- cookbook: "Combine several propagators" (continue the first matching format)+cbCompositeConsume :: Tracer :> es => [Header] -> Eff es a -> Eff es a+cbCompositeConsume headers =+  maybe id withRemoteParent (extractContextFirst cbPropagators headers)++-- cookbook: "Combine several propagators" (emit every configured format)+cbCompositeForward :: Tracer :> es => Eff es [Header]+cbCompositeForward = injectContextAll cbPropagators++-- cookbook: "Combine several propagators" (merge baggage from every format)+cbCompositeServe :: [Header] -> Eff (BaggageContext : es) a -> Eff es a+cbCompositeServe headers =+  runBaggageWith (extractBaggageAll cbBaggagePropagators headers)++-- cookbook: "Combine several propagators" (forward baggage in every format)+cbCompositeBaggageForward :: BaggageContext :> es => Eff es [Header]+cbCompositeBaggageForward = injectBaggageAll cbBaggagePropagators++-- cookbook: "Combine several propagators" (the configured baggage list)+cbBaggagePropagators :: [BaggagePropagator]+cbBaggagePropagators = [w3cBaggage, jaegerBaggage]++-- cookbook: "Configure tracing from OTEL_ environment variables"+cbEnvConfigMain :: IO ()+cbEnvConfigMain = do+  env <- readEnvConfig+  let _name = serviceName env+      _attrs = resourceAttributes env+      _propagators = traceContextPropagators env+      _sampler = tracesSampler env+  pure ()++-- cookbook: "Stamp logs with the active trace and span"+cbLogEvent :: Tracer :> es => (Text -> [(Text, Text)] -> Eff es ()) -> Text -> Eff es ()+cbLogEvent emit message = do+  fields <- activeCorrelationFields+  emit message fields++cbHandleRequest :: Tracer :> es => (Text -> [(Text, Text)] -> Eff es ()) -> Eff es ()+cbHandleRequest emit = withSpan "handle" $ cbLogEvent emit "handling request"++-- cookbook: "Trace a database query" (framework-agnostic withQuerySpan)+cbFetchActiveUsers :: (IOE :> es, Tracer :> es) => Eff es [(Int, Text)]+cbFetchActiveUsers =+  withQuerySpan+    (databaseQuery "postgresql")+      { queryText = Just "SELECT id, name FROM users WHERE active = $1"+      , queryOperation = Just "SELECT"+      , queryCollection = Just "users"+      }+    (liftIO rawSelectActiveUsers)++-- | Stands in for a driver's own query call in the database cookbook mirror;+-- only forced to WHNF, never run.+rawSelectActiveUsers :: IO [(Int, Text)]+rawSelectActiveUsers = error "compile-only: doc mirror is never run"++-- cookbook: "Carry application context as baggage" (seed inbound baggage)+cbServeWithBaggage :: [Header] -> Eff (BaggageContext : es) a -> Eff es a+cbServeWithBaggage headers = runBaggageWith (extractBaggage headers)++-- cookbook: "Carry application context as baggage" (read a value in scope)+cbPriorityOf :: BaggageContext :> es => Eff es (Maybe Text)+cbPriorityOf = lookupBaggageValue "request.priority" <$> getBaggage++-- cookbook: "Carry application context as baggage" (scope an entry, forward it)+cbHandleBaggage :: (BaggageContext :> es, Tracer :> es) => Eff es [Header]+cbHandleBaggage = withBaggageEntry "request.priority" "high" $ withSpan "handle" injectBaggage++-- cookbook: "Assert on traces in your tests"+cbCheckHandlerTrace :: IO ()+cbCheckHandlerTrace = do+  spans <- runEff $ do+    captured <- newCapturedSpans+    runTracerInMemory captured $+      withSpan "handler" $ do+        setStatus Ok+        withSpan "db.query" (addAttribute "db.rows" (1 :: Int))+    readCapturedSpans captured+  case (findSpan "handler" spans, findSpan "db.query" spans) of+    (Just handler, Just db) -> do+      isRoot handler @?= True+      (db `isChildOf` handler) @?= True+      hasStatus Ok handler @?= True+      lookupAttribute "db.rows" db @?= Just (AttrInt 1)+    _ -> pure ()++-- cookbook: "Instrument a long-running worker"+cbWorker :: (Tracer :> es, Queue :> es) => Eff es ()+cbWorker = do+  job <- takeJob+  withSpan "worker.handleJob" $ do+    addAttribute "job.id" (jobId job)+    pure ()++-- cookbook: "Instrument a long-running worker" (linked background work)+cbEnqueueBackground :: (Tracer :> es, Concurrent :> es) => Eff es ()+cbEnqueueBackground = withSpan "request" $ do+  _ <- forkLinked (withSpan "background.reindex" (pure ()))+  pure ()++-- cookbook: pretty-print configuration+cbPrettyRun :: Eff '[Tracer, IOE] a -> IO a+cbPrettyRun action = do+  color <- hIsTerminalDevice stderr+  let config =+        (defaultPrettyPrintConfig stderr)+          { useColor = color+          , showEvents = False+          , timeFormat = RelativeToTraceStart+          }+  runEff (runTracerPretty config action)++-- cookbook: "Bound what a span records"+cbBoundedRun :: Eff '[Tracer, IOE] a -> IO [Span]+cbBoundedRun action = runEff $ do+  captured <- newCapturedSpans+  let limits = defaultSpanLimits {attributeValueLengthLimit = Just 1024, eventCountLimit = Just 64}+  _ <- runTracerInMemoryWithLimits limits alwaysOn captured action+  readCapturedSpans captured++-- tutorial: first traced computation+tutCheckout :: Tracer :> es => Eff es Int+tutCheckout = withSpan "checkout" $ do+  addAttribute "cart.items" (3 :: Int)+  total <- withSpan "price.total" (pure 4200)+  setStatus Ok+  pure total++-- tutorial: annotating a span+tutAnnotated :: Tracer :> es => Eff es ()+tutAnnotated = withSpan "handle.order" $ do+  addAttribute "order.id" ("o-9921" :: Text)+  addAttributes ["http.method" .= ("POST" :: Text), "http.status_code" .= (200 :: Int)]+  addEvent "inventory.reserved" ["sku" .= ("widget-1" :: Text)]+  recordException (toException (ErrorCall "downstream slow"))+  setStatus (Error "downstream slow")++-- tutorial: deterministic ratio sampling+tutSampledRun :: Eff '[Tracer, IOE] a -> IO [Span]+tutSampledRun action = runEff $ do+  captured <- newCapturedSpans+  _ <- runTracerInMemoryWith (traceIdRatioBased 0.1) captured action+  readCapturedSpans captured++-- tutorial: concurrent fan-out under one parent+tutFanOut :: (Tracer :> es, Concurrent :> es) => Eff es (Int, Int)+tutFanOut = withSpan "fan.out" $+  concurrentlyInstrumented+    (withSpan "left" (pure 1))+    (withSpan "right" (pure 2))++-- README: tracing without committing to a backend+readmeCompute :: Tracer :> es => Eff es Int+readmeCompute = withSpan "outer" $ do+  addAttribute "user.id" ("u123" :: Text)+  total <- withSpan "inner" $ do+    addEvent "fetching" []+    pure 42+  setStatus Ok+  pure total++-- README: no-op interpreter+readmeNoOpMain :: IO ()+readmeNoOpMain = do+  result <- runEff (runTracerNoOp readmeCompute)+  print result++-- README: pretty-print interpreter+readmePrettyMain :: IO ()+readmePrettyMain = do+  result <- runEff (runTracerPretty (defaultPrettyPrintConfig stderr) readmeCompute)+  print result++-- WAI middleware examples (only when built with +wai).+waiExamples :: ()+#ifdef WAI+waiExamples =+  (cbRouteName :: Request -> Text)+    `seq` (waiWrap stubRunInIO stubApp :: Application)+    `seq` (waiWrapNamed stubRunInIO stubApp :: Application)+    `seq` ()+  where+    -- Stubs let the rank-2 mirrors be referenced as a plain 'Application'; both+    -- are only forced to WHNF (a partial application), so neither is evaluated.+    stubRunInIO :: Eff '[IOE, Tracer] a -> IO a+    stubRunInIO = error "compile-only: doc mirror is never run"+    stubApp :: Application+    stubApp = error "compile-only: doc mirror is never run"++-- cookbook: name a server span after the matched route+cbRouteName :: Request -> Text+cbRouteName req =+  decodeUtf8Lenient (requestMethod req) <> " " <> decodeUtf8Lenient (rawPathInfo req)++-- README / tutorial: wrap a WAI app with the tracing middleware+waiWrap :: (IOE :> es, Tracer :> es) => (forall a. Eff es a -> IO a) -> Application -> Application+waiWrap runInIO app = traceMiddleware runInIO app++-- cookbook: middleware with a custom span name+waiWrapNamed :: (IOE :> es, Tracer :> es) => (forall a. Eff es a -> IO a) -> Application -> Application+waiWrapNamed runInIO app = traceMiddlewareWith cbRouteName runInIO app+#else+waiExamples = ()+#endif++-- http-client examples (only when built with +http-client).+httpClientExamples :: ()+#ifdef HTTP_CLIENT+httpClientExamples =+  (cbFetchProfile :: Manager -> Eff '[Tracer, IOE] (Response ByteString))+    `seq` ()++-- README / cookbook / tutorial: traced outbound request+cbFetchProfile :: (IOE :> es, Tracer :> es) => Manager -> Eff es (Response ByteString)+cbFetchProfile manager = withSpan "load.profile" $ do+  req <- liftIO (parseRequest "http://users.internal/profile")+  httpLbsTraced req manager+#else+httpClientExamples = ()+#endif++-- postgresql-simple examples (only when built with +postgresql-simple).+postgresqlSimpleExamples :: ()+#ifdef POSTGRESQL_SIMPLE+postgresqlSimpleExamples =+  (cbActiveUserNames :: Connection -> Eff '[Tracer, IOE] [Only Text])+    `seq` ()++-- cookbook: traced postgresql-simple query+cbActiveUserNames :: (IOE :> es, Tracer :> es) => Connection -> Eff es [Only Text]+cbActiveUserNames conn =+  Pg.query conn "SELECT name FROM users WHERE active = ?" (Only True)+#else+postgresqlSimpleExamples = ()+#endif++-- sqlite-simple examples (only when built with +sqlite-simple).+sqliteSimpleExamples :: ()+#ifdef SQLITE_SIMPLE+sqliteSimpleExamples =+  (cbSqliteActiveUserNames :: SqliteDb.Connection -> Eff '[Tracer, IOE] [SqliteDb.Only Text])+    `seq` (cbSqliteSeedUsers :: SqliteDb.Connection -> Eff '[Tracer, IOE] ())+    `seq` ()++-- cookbook: traced sqlite-simple query+cbSqliteActiveUserNames :: (IOE :> es, Tracer :> es) => SqliteDb.Connection -> Eff es [SqliteDb.Only Text]+cbSqliteActiveUserNames conn =+  Sqlite.query conn "SELECT name FROM users WHERE active = ?" (SqliteDb.Only True)++-- cookbook: traced sqlite-simple batch insert+cbSqliteSeedUsers :: (IOE :> es, Tracer :> es) => SqliteDb.Connection -> Eff es ()+cbSqliteSeedUsers conn =+  Sqlite.executeMany conn "INSERT INTO users (name) VALUES (?)" [SqliteDb.Only ("a" :: Text), SqliteDb.Only "b"]+#else+sqliteSimpleExamples = ()+#endif++-- valiant examples (only when built with +valiant).+valiantExamples :: ()+#ifdef VALIANT+valiantExamples =+  (cbValiantActiveUsers :: Eff '[Valiant, Tracer] [Text])+    `seq` (cbValiantSeedUsers :: Eff '[Valiant, Tracer] Int64)+    `seq` ()++-- cookbook: traced valiant query+cbValiantActiveUsers :: (Valiant :> es, Tracer :> es) => Eff es [Text]+cbValiantActiveUsers = ValiantT.fetchAllEff listActiveUsers ()++-- cookbook: traced valiant batch insert+cbValiantSeedUsers :: (Valiant :> es, Tracer :> es) => Eff es Int64+cbValiantSeedUsers = ValiantT.executeBatchEff insertUser ["a", "b"]++-- | Stand-in statements for the valiant mirror. The plugin would normally+-- build these from validated SQL; 'mkStatement' constructs them directly so+-- the mirror needs no plugin or database. Never run.+listActiveUsers :: Statement () Text+listActiveUsers = mkStatement "SELECT name FROM users WHERE active = true" [] ["name"] "inline"++insertUser :: Statement Text ()+insertUser = mkStatement "INSERT INTO users (name) VALUES ($1)" [25] [] "inline"+#else+valiantExamples = ()+#endif++-- amqp examples (only when built with +amqp).+amqpExamples :: ()+#ifdef AMQP_BINDING+amqpExamples =+  (cbAmqpPublishOrder :: Channel -> Eff '[Tracer, IOE] (Maybe Int))+    `seq` (cbAmqpHandleOrder :: Channel -> Eff '[Tracer, IOE] ())+    `seq` ()++-- cookbook: traced amqp publish+cbAmqpPublishOrder :: (IOE :> es, Tracer :> es) => Channel -> Eff es (Maybe Int)+cbAmqpPublishOrder chan =+  Amqp.publishMsgTraced chan "orders" "orders.created" newMsg {msgBody = "{}"}++-- cookbook: traced amqp receive then process+cbAmqpHandleOrder :: (IOE :> es, Tracer :> es) => Channel -> Eff es ()+cbAmqpHandleOrder chan = do+  received <- Amqp.getMsgTraced chan Ack "orders"+  case received of+    Nothing -> pure ()+    Just (msg, env) -> Amqp.withProcessSpan msg env (pure ())+#else+amqpExamples = ()+#endif++-- servant examples (only when built with +servant).+servantExamples :: ()+#ifdef SERVANT+servantExamples =+  (servantServer :: Server ServantApi)+    `seq` (servantWrap stubRunInIOS (serve (Proxy :: Proxy ServantApi) servantServer) :: Application)+    `seq` ()+  where+    stubRunInIOS :: Eff '[IOE, Tracer] a -> IO a+    stubRunInIOS = error "compile-only: doc mirror is never run"++-- cookbook: name server spans from the matched route with Servant+type ServantApi =+  WithSpanName "/users/{id}" Sv.:> "users" Sv.:> Capture "id" Int Sv.:> Get '[PlainText] Text+    :<|> WithSpanName "/health" Sv.:> "health" Sv.:> Get '[PlainText] Text++servantServer :: Server ServantApi+servantServer = (\_ -> pure "user") :<|> pure "ok"++servantWrap+  :: (IOE :> es, Tracer :> es)+  => (forall a. Eff es a -> IO a)+  -> Application+  -> Application+servantWrap runInIO app = traceServantMiddleware runInIO app+#else+servantExamples = ()+#endif++-- OpenTelemetry export example (only when built with +otel). The exporter and+-- batch processor in the doc come from the SDK packages, which are not test+-- dependencies; the library surface (the 'OtelConfig' record and+-- 'runTracerOTel') is what this mirror pins, with an empty processor list.+otelExamples :: ()+#ifdef OTEL+otelExamples =+  (tutOtelRun :: Eff '[Tracer, IOE] Int -> IO Int)+    `seq` ()++tutOtelRun :: Eff '[Tracer, IOE] a -> IO a+tutOtelRun action = do+  let config =+        OtelConfig+          { spanProcessors = []+          , instrumentationScope = "checkout-service"+          , sampler = parentBased (defaultParentBasedConfig alwaysOn)+          , spanLimits = defaultSpanLimits+          }+  runEff (runTracerOTel config action)+#else+otelExamples = parentBased (defaultParentBasedConfig alwaysOn) `seq` ()+#endif
+ test/Effectful/Tracing/ConcurrentSpec.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.ConcurrentSpec+-- Description : Tests for span propagation across forked and concurrent work.+--+-- These exercise the helpers in "Effectful.Tracing.Concurrent" through the+-- in-memory interpreter: the inheriting wrappers must make forked spans+-- children of the launching span regardless of completion order, an exception+-- in one concurrent branch must be recorded on that branch and propagate, and+-- 'forkLinked' must start a detached root that links back to the caller. A+-- stress test confirms many concurrent spans are all captured with the right+-- parent and nothing is lost.+module Effectful.Tracing.ConcurrentSpec+  ( tests+  ) where++import Control.Exception (Exception, try)+import Data.List (sort)+import Data.Text (Text)+import Data.Text qualified as T++import Effectful (Eff, IOE, runEff)+import Effectful.Concurrent (Concurrent, runConcurrent, threadDelay)+import Effectful.Concurrent.Async (wait)+import Effectful.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Effectful.Exception (throwIO)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++import Effectful.Tracing+  ( Span (spanContext, spanLinks, spanName, spanParentContext, spanStatus)+  , SpanContext (spanContextTraceId)+  , SpanStatus (Error)+  , Tracer+  , withSpan+  )+import Effectful.Tracing.Concurrent+  ( asyncInstrumented+  , concurrentlyInstrumented+  , forConcurrentlyInstrumented+  , forkLinked+  )+import Effectful.Tracing.Internal.Types (Link (linkContext))+import Effectful.Tracing.Interpreter.InMemory+  ( CapturedSpans+  , childrenOf+  , findSpan+  , newCapturedSpans+  , readCapturedSpans+  , runTracerInMemory+  )++tests :: TestTree+tests =+  testGroup+    "Concurrent propagation"+    [ testCase "asyncInstrumented nests under the launching span" $ do+        spans <- run $+          withSpan "parent" $ do+            a <- asyncInstrumented (withSpan "child" (pure ()))+            wait a+        parent <- expectSpan "parent" spans+        child <- expectSpan "child" spans+        childrenOf parent spans @?= [child]+    , testCase "concurrentlyInstrumented makes both branches siblings under the launcher" $ do+        spans <- run $+          withSpan "parent" $+            concurrentlyInstrumented (withSpan "a" (pure ())) (withSpan "b" (pure ()))+        parent <- expectSpan "parent" spans+        assertBool+          "both branches are children of the launching span"+          (sort (map spanName (childrenOf parent spans)) == ["a", "b"])+    , testCase "completion order does not change the parent relationships" $ do+        -- "slow" finishes well after "fast", so it is captured last; the+        -- parent/child links must not depend on that order.+        spans <- run $+          withSpan "parent" $+            concurrentlyInstrumented+              (withSpan "slow" (threadDelay 20000))+              (withSpan "fast" (pure ()))+        parent <- expectSpan "parent" spans+        assertBool+          "slow and fast are both children regardless of completion order"+          (sort (map spanName (childrenOf parent spans)) == ["fast", "slow"])+    , testCase "an exception in one branch is recorded there and propagates" $ do+        captured <- runEff newCapturedSpans+        result <-+          try . runEff . runConcurrent . runTracerInMemory captured $+            withSpan "parent" $+              concurrentlyInstrumented+                (withSpan "ok" (threadDelay 50000))+                (withSpan "boom" (throwIO Boom))+        case result of+          Right _ -> assertFailure "expected the exception to propagate out of concurrentlyInstrumented"+          Left Boom -> pure ()+        spans <- runEff (readCapturedSpans captured)+        boom <- expectSpan "boom" spans+        case spanStatus boom of+          Error msg -> assertBool "error message mentions the exception" ("Boom" `T.isInfixOf` msg)+          other -> assertFailure ("expected Error status on the throwing span, got " <> show other)+    , testCase "forkLinked starts a detached root linked back to the caller" $ do+        captured <- runEff newCapturedSpans+        runEff . runConcurrent . runTracerInMemory captured $ do+          signal <- newEmptyMVar+          withSpan "caller" $ do+            _ <- forkLinked (withSpan "background" (pure ()) >> putMVar signal ())+            takeMVar signal+        spans <- runEff (readCapturedSpans captured)+        caller <- expectSpan "caller" spans+        background <- expectSpan "background" spans+        spanParentContext background @?= Nothing+        assertBool+          "the linked root is in a different trace than the caller"+          (spanContextTraceId (spanContext background) /= spanContextTraceId (spanContext caller))+        assertBool+          "the linked root carries a link back to the caller span"+          (spanContext caller `elem` map linkContext (spanLinks background))+    , testCase "1000 concurrent traced actions are all captured under the launcher" $ do+        let n = 1000+        spans <- run $+          withSpan "fanout" $+            forConcurrentlyInstrumented [1 .. n] $ \i ->+              withSpan ("task-" <> T.pack (show i)) (pure i)+        parent <- expectSpan "fanout" spans+        let kids = childrenOf parent spans+        length kids @?= n+        assertBool+          "every captured task is a child of the launcher and named distinctly"+          (sort (map spanName kids) == sort [T.pack ("task-" <> show i) | i <- [1 .. n]])+    ]++-- | Run a traced, concurrent program through the in-memory interpreter and+-- return the captured spans.+run :: Eff '[Tracer, Concurrent, IOE] a -> IO [Span]+run prog = do+  captured <- runEff newCapturedSpans+  _ <- runEff . runConcurrent . runTracerInMemory captured $ prog+  collect captured++collect :: CapturedSpans -> IO [Span]+collect = runEff . readCapturedSpans++-- | Look up a captured span by name, failing the test if it is absent.+expectSpan :: Text -> [Span] -> IO Span+expectSpan name spans =+  maybe (assertFailure ("no captured span named " <> show name)) pure (findSpan name spans)++-- | A trivial exception with a recognizable message.+data Boom = Boom+  deriving (Show)++instance Exception Boom
+ test/Effectful/Tracing/EnvConfigSpec.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.EnvConfigSpec+-- Description : Tests for reading OTel configuration from the environment.+--+-- The parse is pure (a lookup function), so every case is exercised with a stub+-- environment built from an association list. The four readers each get their+-- own group: service-name resolution and its fallback into resource attributes,+-- resource-attribute decoding, propagator-token resolution (including the+-- defaults, @none@, and a token that feeds both lists), and the sampler name and+-- ratio handling.+module Effectful.Tracing.EnvConfigSpec+  ( tests+  ) where++import Data.Text (Text)++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import Effectful.Tracing.Attribute (Attribute (Attribute), AttributeValue (AttrText))+import Effectful.Tracing.EnvConfig+  ( EnvConfig (baggagePropagators, resourceAttributes, serviceName, traceContextPropagators, tracesSampler)+  , defaultEnvConfig+  , parseEnvConfig+  , parsePropagators+  , parseSampler+  , parseServiceName+  )+import Effectful.Tracing.Propagation.Composite (baggageName, traceContextName)+import Effectful.Tracing.Sampler (samplerName)++-- | Build a lookup function from an association list of variable name to value.+stubEnv :: [(Text, Text)] -> (Text -> Maybe Text)+stubEnv entries name = lookup name entries++tests :: TestTree+tests =+  testGroup+    "EnvConfig"+    [ testGroup "serviceName" serviceNameTests+    , testGroup "resourceAttributes" resourceAttributeTests+    , testGroup "propagators" propagatorTests+    , testGroup "sampler" samplerTests+    , testGroup "defaults" defaultTests+    ]++serviceNameTests :: [TestTree]+serviceNameTests =+  [ testCase "reads OTEL_SERVICE_NAME" $+      parseServiceName (stubEnv [("OTEL_SERVICE_NAME", "checkout")]) @?= Just "checkout"+  , testCase "trims surrounding whitespace" $+      parseServiceName (stubEnv [("OTEL_SERVICE_NAME", "  checkout  ")]) @?= Just "checkout"+  , testCase "an empty value is treated as unset" $+      parseServiceName (stubEnv [("OTEL_SERVICE_NAME", "   ")]) @?= Nothing+  , testCase "falls back to service.name in OTEL_RESOURCE_ATTRIBUTES" $+      parseServiceName (stubEnv [("OTEL_RESOURCE_ATTRIBUTES", "service.name=billing,team=core")])+        @?= Just "billing"+  , testCase "OTEL_SERVICE_NAME wins over the resource attribute" $+      parseServiceName+        ( stubEnv+            [ ("OTEL_SERVICE_NAME", "checkout")+            , ("OTEL_RESOURCE_ATTRIBUTES", "service.name=billing")+            ]+        )+        @?= Just "checkout"+  , testCase "absent everywhere is Nothing" $+      parseServiceName (stubEnv []) @?= Nothing+  ]++resourceAttributeTests :: [TestTree]+resourceAttributeTests =+  [ testCase "decodes comma-separated key=value pairs" $+      resourceAttributes (parseEnvConfig (stubEnv [("OTEL_RESOURCE_ATTRIBUTES", "team=core,region=us-east-1")]))+        @?= [Attribute "region" (AttrText "us-east-1"), Attribute "team" (AttrText "core")]+  , testCase "percent-decodes values" $+      resourceAttributes (parseEnvConfig (stubEnv [("OTEL_RESOURCE_ATTRIBUTES", "note=a%20b")]))+        @?= [Attribute "note" (AttrText "a b")]+  , testCase "absent yields no attributes" $+      resourceAttributes (parseEnvConfig (stubEnv [])) @?= []+  ]++propagatorTests :: [TestTree]+propagatorTests =+  [ testCase "unset defaults to tracecontext + baggage" $ do+      let (traces, baggages) = parsePropagators (stubEnv [])+      map traceContextName traces @?= ["tracecontext"]+      map baggageName baggages @?= ["baggage"]+  , testCase "splits and resolves a token list in order" $ do+      let (traces, baggages) = parsePropagators (stubEnv [("OTEL_PROPAGATORS", "b3, tracecontext, baggage")])+      map traceContextName traces @?= ["b3", "tracecontext"]+      map baggageName baggages @?= ["baggage"]+  , testCase "jaeger contributes to both lists" $ do+      let (traces, baggages) = parsePropagators (stubEnv [("OTEL_PROPAGATORS", "jaeger")])+      map traceContextName traces @?= ["jaeger"]+      map baggageName baggages @?= ["jaeger"]+  , testCase "none disables all propagators" $ do+      let (traces, baggages) = parsePropagators (stubEnv [("OTEL_PROPAGATORS", "tracecontext,none")])+      map traceContextName traces @?= []+      map baggageName baggages @?= []+  , testCase "unrecognised tokens are ignored" $ do+      let (traces, baggages) = parsePropagators (stubEnv [("OTEL_PROPAGATORS", "nonsense,b3multi")])+      map traceContextName traces @?= ["b3multi"]+      map baggageName baggages @?= []+  ]++samplerTests :: [TestTree]+samplerTests =+  [ testCase "always_on" $+      samplerName (parseSampler (stubEnv [("OTEL_TRACES_SAMPLER", "always_on")])) @?= "AlwaysOn"+  , testCase "always_off" $+      samplerName (parseSampler (stubEnv [("OTEL_TRACES_SAMPLER", "always_off")])) @?= "AlwaysOff"+  , testCase "traceidratio uses the arg" $+      samplerName+        ( parseSampler+            ( stubEnv+                [ ("OTEL_TRACES_SAMPLER", "traceidratio")+                , ("OTEL_TRACES_SAMPLER_ARG", "0.25")+                ]+            )+        )+        @?= "TraceIdRatioBased{0.25}"+  , testCase "traceidratio defaults the ratio to 1.0 when the arg is absent" $+      samplerName (parseSampler (stubEnv [("OTEL_TRACES_SAMPLER", "traceidratio")]))+        @?= "TraceIdRatioBased{1.0}"+  , testCase "parentbased_traceidratio wraps the ratio sampler" $+      samplerName+        ( parseSampler+            ( stubEnv+                [ ("OTEL_TRACES_SAMPLER", "parentbased_traceidratio")+                , ("OTEL_TRACES_SAMPLER_ARG", "0.1")+                ]+            )+        )+        @?= "ParentBased{TraceIdRatioBased{0.1}}"+  , testCase "an unrecognised name degrades to parentbased_always_on" $+      samplerName (parseSampler (stubEnv [("OTEL_TRACES_SAMPLER", "made_up")]))+        @?= "ParentBased{AlwaysOn}"+  , testCase "unset degrades to parentbased_always_on" $+      samplerName (parseSampler (stubEnv [])) @?= "ParentBased{AlwaysOn}"+  ]++defaultTests :: [TestTree]+defaultTests =+  [ testCase "defaultEnvConfig has no service name" $+      serviceName defaultEnvConfig @?= Nothing+  , testCase "defaultEnvConfig has the default propagators" $ do+      map traceContextName (traceContextPropagators defaultEnvConfig) @?= ["tracecontext"]+      map baggageName (baggagePropagators defaultEnvConfig) @?= ["baggage"]+  , testCase "defaultEnvConfig has the default sampler" $+      samplerName (tracesSampler defaultEnvConfig) @?= "ParentBased{AlwaysOn}"+  ]
+ test/Effectful/Tracing/FuzzSpec.hs view
@@ -0,0 +1,313 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module      : Effectful.Tracing.FuzzSpec+-- Description : Robustness / totality fuzzing for the wire-format parsers.+--+-- The propagation and id parsers all consume untrusted input from the network,+-- so the contract that matters is total: on any 'ByteString' or 'Text' they+-- must terminate and return a value (never loop, never throw). These properties+-- feed both uniformly random input and structurally-plausible-but-malformed+-- input (right shape, adversarial content) and assert the parser produces a+-- well-formed result.+--+-- Each property reduces the parser output to a 'Bool' through 'eval', which+-- forces evaluation and reports any bottom as a failure rather than letting it+-- escape. Because the library types are records of strict fields backed by+-- strict 'ByteString's, evaluating that 'Bool' walks the whole result, so+-- "didn't throw" is a real check rather than a WHNF formality.+module Effectful.Tracing.FuzzSpec+  ( tests+  ) where++import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding (encodeUtf8)++import Hedgehog (Gen, Property, assert, eval, forAll, property)+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Hedgehog (testProperty)++import Effectful.Tracing.Internal.Ids+  ( SpanId (..)+  , TraceId (..)+  , isValidSpanId+  , isValidTraceId+  , spanIdFromHex+  , traceIdFromHex+  )+import Effectful.Tracing.Internal.Types+  ( SpanContext (..)+  , TraceFlags (..)+  , maxTraceStateEntries+  , traceStateEntries+  , traceStateFromHeader+  )+import Effectful.Tracing.Propagation+  ( extractContext+  , traceparentHeader+  , tracestateHeader+  )+import Effectful.Tracing.Propagation.B3+  ( b3FlagsHeader+  , b3Header+  , b3SampledHeader+  , b3SpanIdHeader+  , b3TraceIdHeader+  , extractContextB3+  )+import Effectful.Tracing.Baggage+  ( Baggage+  , BaggageEntry (BaggageEntry)+  , baggageSize+  , baggageToList+  )+import Effectful.Tracing.Propagation.Baggage+  ( baggageHeader+  , extractBaggage+  , maxBaggageEntries+  , parseBaggage+  )+import Effectful.Tracing.Propagation.Jaeger+  ( extractContextJaeger+  , uberTraceIdHeader+  )++tests :: TestTree+tests =+  testGroup+    "Parser robustness (fuzz)"+    [ testProperty "extractContext is total on arbitrary headers" prop_extractContextTotal+    , testProperty "extractContext is total on traceparent-shaped input" prop_extractContextShaped+    , testProperty "extractContextB3 is total on arbitrary headers" prop_extractB3Total+    , testProperty "extractContextB3 is total on b3-shaped input" prop_extractB3Shaped+    , testProperty "extractContextJaeger is total on arbitrary headers" prop_extractJaegerTotal+    , testProperty "extractContextJaeger is total on uber-trace-id-shaped input" prop_extractJaegerShaped+    , testProperty "extractBaggage is total on arbitrary headers" prop_extractBaggageTotal+    , testProperty "parseBaggage is total on baggage-shaped input" prop_parseBaggageShaped+    , testProperty "traceIdFromHex is total on arbitrary text" prop_traceIdFromHexTotal+    , testProperty "spanIdFromHex is total on arbitrary text" prop_spanIdFromHexTotal+    , testProperty "traceStateFromHeader is total and capped" prop_traceStateFromHeaderTotal+    ]++-- | Whatever 'extractContext' returns, it is either a clean rejection or a+-- context whose ids satisfy the validity invariant. 'eval' on the fully-forcing+-- predicate turns a loop into a timeout and a hidden bottom into a failure here.+prop_extractContextTotal :: Property+prop_extractContextTotal = property $ do+  tp <- forAll genFuzzBytes+  ts <- forAll genFuzzBytes+  ok <- eval (validContext (extractContext [(traceparentHeader, tp), (tracestateHeader, ts)]))+  assert ok++-- | The same totality check, but biased toward input that looks like a+-- @traceparent@ (hyphen-joined hex-ish fields), to actually exercise the parse+-- branches rather than bouncing off the first malformed byte.+prop_extractContextShaped :: Property+prop_extractContextShaped = property $ do+  tp <- forAll genTraceparentish+  ok <- eval (validContext (extractContext [(traceparentHeader, tp)]))+  assert ok++-- | 'extractContextB3' is likewise total: feeding random bytes to the single+-- @b3@ header and the multi-header fields together must yield a clean rejection+-- or a context whose ids satisfy the validity invariant.+prop_extractB3Total :: Property+prop_extractB3Total = property $ do+  single <- forAll genFuzzBytes+  tid <- forAll genFuzzBytes+  sid <- forAll genFuzzBytes+  samp <- forAll genFuzzBytes+  flags <- forAll genFuzzBytes+  ok <-+    eval+      ( validContext+          ( extractContextB3+              [ (b3Header, single)+              , (b3TraceIdHeader, tid)+              , (b3SpanIdHeader, sid)+              , (b3SampledHeader, samp)+              , (b3FlagsHeader, flags)+              ]+          )+      )+  assert ok++-- | The same totality check biased toward @b3@-shaped single-header input+-- (hyphen-joined hex-ish fields), so the field-count, id, and sampling branches+-- are exercised rather than bounced off the first malformed byte.+prop_extractB3Shaped :: Property+prop_extractB3Shaped = property $ do+  single <- forAll genB3ish+  ok <- eval (validContext (extractContextB3 [(b3Header, single)]))+  assert ok++-- | 'extractContextJaeger' is total: feeding random bytes to the+-- @uber-trace-id@ header must yield a clean rejection or a context whose ids+-- satisfy the validity invariant.+prop_extractJaegerTotal :: Property+prop_extractJaegerTotal = property $ do+  raw <- forAll genFuzzBytes+  ok <- eval (validContext (extractContextJaeger [(uberTraceIdHeader, raw)]))+  assert ok++-- | The same totality check biased toward @uber-trace-id@-shaped input+-- (colon-joined hex-ish fields), so the field-count, id, and flags branches are+-- exercised rather than bounced off the first malformed byte.+prop_extractJaegerShaped :: Property+prop_extractJaegerShaped = property $ do+  raw <- forAll genJaegerish+  ok <- eval (validContext (extractContextJaeger [(uberTraceIdHeader, raw)]))+  assert ok++-- | 'extractBaggage' is total: feeding random bytes to the @baggage@ header must+-- yield a baggage set whose entries are all forceable and whose size respects+-- the W3C cap.+prop_extractBaggageTotal :: Property+prop_extractBaggageTotal = property $ do+  raw <- forAll genFuzzBytes+  ok <- eval (validBaggage (extractBaggage [(baggageHeader, raw)]))+  assert ok++-- | The same totality check biased toward baggage-shaped text (comma-joined+-- @key=value@ members with partial percent escapes, delimiters, and metadata),+-- so the member-split, percent-decode, and metadata branches are exercised.+prop_parseBaggageShaped :: Property+prop_parseBaggageShaped = property $ do+  t <- forAll genBaggageish+  ok <- eval (validBaggage (parseBaggage t))+  assert ok++-- | A parsed baggage set is well-formed: every key, value, and metadata string+-- forces without bottom (summing their lengths walks them), and the entry count+-- never exceeds the cap.+validBaggage :: Baggage -> Bool+validBaggage b =+  let n =+        sum+          [ T.length k + T.length v + maybe 0 T.length meta+          | (k, BaggageEntry v meta) <- baggageToList b+          ]+   in n `seq` baggageSize b <= maxBaggageEntries++-- | Baggage-shaped text: 0 to 6 comma-joined members, each a token-ish key, an+-- @=@, a value mixing spaces, delimiters, and partial percent escapes, and an+-- optional metadata segment.+genBaggageish :: Gen Text+genBaggageish = do+  members <- Gen.list (Range.linear 0 6) genMember+  pure (T.intercalate "," members)+  where+    genMember = do+      k <- Gen.text (Range.linear 0 8) (Gen.element ("abcXYZ-._09" :: String))+      v <- Gen.text (Range.linear 0 12) (Gen.element ("ab %20%2New,York;x" :: String))+      meta <- Gen.element ["", ";ttl=30", ";public"]+      pure (k <> "=" <> v <> meta)++-- | 'traceIdFromHex' returns 'Nothing' or a 16-byte id; nothing else, and never+-- a bottom.+prop_traceIdFromHexTotal :: Property+prop_traceIdFromHexTotal = property $ do+  t <- forAll genFuzzText+  ok <- eval (maybe True (\(TraceId bs) -> BS.length bs == 16) (traceIdFromHex t))+  assert ok++-- | 'spanIdFromHex' returns 'Nothing' or an 8-byte id.+prop_spanIdFromHexTotal :: Property+prop_spanIdFromHexTotal = property $ do+  t <- forAll genFuzzText+  ok <- eval (maybe True (\(SpanId bs) -> BS.length bs == 8) (spanIdFromHex t))+  assert ok++-- | 'traceStateFromHeader' never throws and never returns more than the W3C+-- entry cap, no matter how malformed the header.+prop_traceStateFromHeaderTotal :: Property+prop_traceStateFromHeaderTotal = property $ do+  t <- forAll genFuzzText+  n <- eval (length (traceStateEntries (traceStateFromHeader t)))+  assert (n <= maxTraceStateEntries)++-- | A context that survived extraction must carry valid (right-length,+-- non-zero) trace and span ids; rejection is also acceptable. The leading+-- 'seq's force the flags byte, the trace-state spine, and the remote flag so the+-- whole value is walked, while the returned conjunction is the real invariant.+validContext :: Maybe SpanContext -> Bool+validContext Nothing = True+validContext (Just ctx) =+  let TraceFlags w = spanContextTraceFlags ctx+      stateLen = length (traceStateEntries (spanContextTraceState ctx))+   in w `seq` stateLen `seq` spanContextIsRemote ctx `seq`+        (isValidTraceId (spanContextTraceId ctx) && isValidSpanId (spanContextSpanId ctx))++-- | Uniformly random bytes, including bytes that are not valid UTF-8, so the+-- @decodeUtf8'@ guard in 'extractContext' is exercised as well as the parser.+genFuzzBytes :: Gen ByteString+genFuzzBytes = Gen.bytes (Range.linear 0 80)++-- | Arbitrary text spanning the structural delimiters the parser cares about+-- and arbitrary Unicode.+genFuzzText :: Gen Text+genFuzzText =+  Gen.choice+    [ Gen.text (Range.linear 0 80) Gen.unicode+    , Gen.text (Range.linear 0 80) (Gen.element ("-=,; \t0123456789abcdefABCDEFxyz" :: String))+    ]++-- | A @b3@-shaped single-header value: 1 to 4 hyphen-joined fields, each a+-- hex-ish token (occasionally a known-good id or a real sampling token), so the+-- generator reaches the id and sampling branches of the B3 parser.+genB3ish :: Gen ByteString+genB3ish = do+  fields <- Gen.list (Range.linear 1 4) genField+  pure (encodeUtf8 (T.intercalate "-" fields))+  where+    genField =+      Gen.choice+        [ Gen.text (Range.linear 0 34) (Gen.element ("0123456789abcdef" :: String))+        , pure "4bf92f3577b34da6a3ce929d0e0e4736"+        , pure "a3ce929d0e0e4736"+        , pure "00f067aa0ba902b7"+        , Gen.element ["0", "1", "d", ""]+        ]++-- | An @uber-trace-id@-shaped value: 1 to 5 colon-joined fields, each a hex-ish+-- token of varying length (occasionally a known-good id, a parent placeholder,+-- or a real flags value). This reaches the field-count, id, and flags branches+-- of the Jaeger parser.+genJaegerish :: Gen ByteString+genJaegerish = do+  fields <- Gen.list (Range.linear 1 5) genField+  pure (encodeUtf8 (T.intercalate ":" fields))+  where+    genField =+      Gen.choice+        [ Gen.text (Range.linear 0 34) (Gen.element ("0123456789abcdef" :: String))+        , pure "4bf92f3577b34da6a3ce929d0e0e4736"+        , pure "00f067aa0ba902b7"+        , Gen.element ["0", "1", "3", "d", ""]+        ]++-- | A @traceparent@-shaped value: 1 to 6 hyphen-joined fields, each a hex-ish+-- token of varying length (occasionally a known-good id or version, occasionally+-- empty). This reaches the field-count, version, id, and flags branches of the+-- parser, where uniformly random bytes would almost always be rejected up front.+genTraceparentish :: Gen ByteString+genTraceparentish = do+  fields <- Gen.list (Range.linear 1 6) genField+  pure (encodeUtf8 (T.intercalate "-" fields))+  where+    genField =+      Gen.choice+        [ Gen.text (Range.linear 0 34) (Gen.element ("0123456789abcdef" :: String))+        , Gen.text (Range.linear 0 6) Gen.alphaNum+        , pure "4bf92f3577b34da6a3ce929d0e0e4736"+        , pure "00f067aa0ba902b7"+        , pure "00"+        , pure "ff"+        , pure ""+        ]
+ test/Effectful/Tracing/Gen.hs view
@@ -0,0 +1,181 @@+-- |+-- Module      : Effectful.Tracing.Gen+-- Description : Hedgehog generators for the core data model.+--+-- Generators for every public type in the core data model, used by the+-- property tests.+module Effectful.Tracing.Gen+  ( genTraceId+  , genSpanId+  , genAttributeKey+  , genAttributeValue+  , genAttribute+  , genTraceFlags+  , genTraceState+  , genTimestamp+  , genSpanContext+  , genSpanKind+  , genSpanStatus+  , genEvent+  , genLink+  , genSpan+  ) where++import Data.Int (Int64)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Vector qualified as V+import Data.Time.Clock (addUTCTime)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)++import Hedgehog (Gen)+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range++import Effectful.Tracing.Attribute (Attribute (..), AttributeValue (..))+import Effectful.Tracing.Internal.Clock (Timestamp (..))+import Effectful.Tracing.Internal.Ids (SpanId (..), TraceId (..))+import Effectful.Tracing.Internal.Types+  ( Event (..)+  , Link (..)+  , Span (..)+  , SpanContext (..)+  , SpanKind+  , SpanStatus (..)+  , TraceFlags (..)+  , TraceState+  , emptyTraceState+  , insertTraceState+  )++-- | A 16-byte trace identifier (may be all-zero, which is fine for the codec+-- properties).+genTraceId :: Gen TraceId+genTraceId = TraceId <$> Gen.bytes (Range.singleton 16)++-- | An 8-byte span identifier.+genSpanId :: Gen SpanId+genSpanId = SpanId <$> Gen.bytes (Range.singleton 8)++genText :: Gen Text+genText = Gen.text (Range.linear 0 16) Gen.alphaNum++-- | A non-empty attribute key.+genAttributeKey :: Gen Text+genAttributeKey = Gen.text (Range.linear 1 24) Gen.alphaNum++genInt64 :: Gen Int64+genInt64 = Gen.integral (Range.linearFrom 0 minBound maxBound)++genDouble :: Gen Double+genDouble = Gen.double (Range.linearFracFrom 0 (-1.0e9) 1.0e9)++-- | Any attribute value, scalar or homogeneous array.+genAttributeValue :: Gen AttributeValue+genAttributeValue =+  Gen.choice+    [ AttrText <$> genText+    , AttrBool <$> Gen.bool+    , AttrInt <$> genInt64+    , AttrDouble <$> genDouble+    , AttrTextArray . V.fromList <$> Gen.list (Range.linear 0 4) genText+    , AttrBoolArray . V.fromList <$> Gen.list (Range.linear 0 4) Gen.bool+    , AttrIntArray . V.fromList <$> Gen.list (Range.linear 0 4) genInt64+    , AttrDoubleArray . V.fromList <$> Gen.list (Range.linear 0 4) genDouble+    ]++genAttribute :: Gen Attribute+genAttribute = Attribute <$> genAttributeKey <*> genAttributeValue++genTraceFlags :: Gen TraceFlags+genTraceFlags = TraceFlags <$> Gen.word8 Range.constantBounded++-- | A valid trace state, built through 'insertTraceState' so all entries+-- satisfy the W3C key/value constraints and the entry cap.+genTraceState :: Gen TraceState+genTraceState = do+  pairs <- Gen.list (Range.linear 0 10) ((,) <$> genStateKey <*> genStateValue)+  pure (foldr addEntry emptyTraceState pairs)+  where+    addEntry (key, value) st = fromMaybe st (insertTraceState key value st)++genStateKey :: Gen Text+genStateKey = do+  start <- Gen.element keyStartChars+  rest <- Gen.list (Range.linear 0 8) (Gen.element keyChars)+  pure (mkText (start : rest))+  where+    keyStartChars = ['a' .. 'z'] <> ['0' .. '9']+    keyChars = keyStartChars <> "_-*/@"++genStateValue :: Gen Text+genStateValue = mkText <$> Gen.list (Range.linear 1 12) (Gen.element valueChars)+  where+    valueChars = [c | c <- [' ' .. '~'], c /= ' ', c /= ',', c /= '=']++mkText :: String -> Text+mkText = T.pack++genTimestamp :: Gen Timestamp+genTimestamp = do+  secs <- Gen.integral (Range.linear 0 2_000_000_000)+  pure (Timestamp (posixSecondsToUTCTime (fromInteger (secs :: Integer))))++genSpanContext :: Gen SpanContext+genSpanContext =+  SpanContext+    <$> genTraceId+    <*> genSpanId+    <*> genTraceFlags+    <*> genTraceState+    <*> Gen.bool++genSpanKind :: Gen SpanKind+genSpanKind = Gen.enumBounded++genSpanStatus :: Gen SpanStatus+genSpanStatus =+  Gen.choice+    [ pure Unset+    , pure Ok+    , Error <$> genText+    ]++genEvent :: Gen Event+genEvent =+  Event+    <$> genText+    <*> genTimestamp+    <*> Gen.list (Range.linear 0 4) genAttribute++genLink :: Gen Link+genLink = Link <$> genSpanContext <*> Gen.list (Range.linear 0 4) genAttribute++-- | A completed span with @start <= end@ by construction.+genSpan :: Gen Span+genSpan = do+  context <- genSpanContext+  parent <- Gen.maybe genSpanContext+  name <- genText+  kind <- genSpanKind+  Timestamp start <- genTimestamp+  durationSecs <- Gen.integral (Range.linear 0 100_000)+  let end = addUTCTime (fromInteger (durationSecs :: Integer)) start+  attributes <- Gen.list (Range.linear 0 6) genAttribute+  events <- Gen.list (Range.linear 0 4) genEvent+  links <- Gen.list (Range.linear 0 4) genLink+  status <- genSpanStatus+  pure+    Span+      { spanContext = context+      , spanParentContext = parent+      , spanName = name+      , spanKind = kind+      , spanStartTime = Timestamp start+      , spanEndTime = Timestamp end+      , spanAttributes = attributes+      , spanEvents = events+      , spanLinks = links+      , spanStatus = status+      }
+ test/Effectful/Tracing/IdGenSpec.hs view
@@ -0,0 +1,77 @@+-- |+-- Module      : Effectful.Tracing.IdGenSpec+-- Description : Tests for the id generators (newTraceId / newSpanId).+--+-- "Effectful.Tracing.IdsSpec" pins the codec and validity edges, and the+-- round-trip over arbitrary bytes lives in "Effectful.Tracing.PropertySpec".+-- Neither exercises the generators themselves, which draw real bytes from the+-- configured entropy source. This module does: it asserts that a freshly+-- generated id is valid, round-trips through hex, and that a large batch is+-- collision-free.+--+-- The same assertions run whichever byte source the library was built with, so+-- building the suite with the @secure-ids@ cabal flag turns this into coverage+-- of the @crypton@ system-entropy path (otherwise it covers the default+-- splitmix PRNG). The group label reflects which source is under test.+{-# LANGUAGE CPP #-}++module Effectful.Tracing.IdGenSpec+  ( tests+  ) where++import Control.Monad (replicateM)+import Data.Set qualified as Set++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase, (@?=))++import Effectful.Tracing+  ( isValidSpanId+  , isValidTraceId+  , newSpanId+  , newTraceId+  , spanIdFromHex+  , spanIdToHex+  , traceIdFromHex+  , traceIdToHex+  )++-- | Which entropy source these assertions are exercising, decided by the+-- @secure-ids@ cabal flag (which sets @-DSECURE_IDS@ on this suite).+sourceName :: String+#ifdef SECURE_IDS+sourceName = "crypton system entropy (secure-ids)"+#else+sourceName = "splitmix PRNG (default)"+#endif++-- | How many ids to mint when checking for collisions. Large enough that a+-- broken (constant or low-entropy) source would almost certainly repeat: even+-- the 8-byte span id has a birthday-collision probability here on the order of+-- 1e-12.+batchSize :: Int+batchSize = 10000++tests :: TestTree+tests =+  testGroup+    ("Id generation: " <> sourceName)+    [ testCase "a generated trace id is valid" $ do+        tid <- newTraceId+        assertBool "valid trace id" (isValidTraceId tid)+    , testCase "a generated span id is valid" $ do+        sid <- newSpanId+        assertBool "valid span id" (isValidSpanId sid)+    , testCase "a generated trace id round-trips through hex" $ do+        tid <- newTraceId+        traceIdFromHex (traceIdToHex tid) @?= Just tid+    , testCase "a generated span id round-trips through hex" $ do+        sid <- newSpanId+        spanIdFromHex (spanIdToHex sid) @?= Just sid+    , testCase (show batchSize <> " generated trace ids are all distinct") $ do+        ids <- replicateM batchSize newTraceId+        Set.size (Set.fromList ids) @?= batchSize+    , testCase (show batchSize <> " generated span ids are all distinct") $ do+        ids <- replicateM batchSize newSpanId+        Set.size (Set.fromList ids) @?= batchSize+    ]
+ test/Effectful/Tracing/IdsSpec.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.IdsSpec+-- Description : Edge-case tests for the identifier hex codec and validity checks.+--+-- The round-trip property lives in "Effectful.Tracing.PropertySpec"; this file+-- pins the rejection and acceptance boundaries that round-trips never reach:+-- odd-length and non-hex input, wrong-length byte arrays, uppercase hex, the+-- all-zero sentinel, and lowercase rendering.+module Effectful.Tracing.IdsSpec+  ( tests+  ) where++import Data.ByteString qualified as BS+import Data.Maybe (isJust, isNothing)+import Data.Text (Text)+import Data.Text qualified as T++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase, (@?=))++import Effectful.Tracing.Internal.Ids+  ( SpanId (SpanId)+  , TraceId (TraceId)+  , isValidSpanId+  , isValidTraceId+  , spanIdFromBytes+  , spanIdFromHex+  , traceIdFromBytes+  , traceIdFromHex+  , traceIdToHex+  )++tests :: TestTree+tests =+  testGroup+    "Identifiers"+    [ testGroup "hex parsing" hexTests+    , testGroup "byte construction" byteTests+    , testGroup "validity" validityTests+    ]++hexTests :: [TestTree]+hexTests =+  [ testCase "an odd-length string is rejected" $+      assertBool "odd length" (isNothing (traceIdFromHex (hexDigits 31)))+  , testCase "a too-short even-length string is rejected" $+      -- 30 hex chars decode to 15 bytes, one short of a trace id.+      assertBool "15 bytes" (isNothing (traceIdFromHex (hexDigits 30)))+  , testCase "a non-hex character is rejected" $+      assertBool "non-hex" (isNothing (traceIdFromHex "zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz"))+  , testCase "uppercase hex is accepted and renders back lowercase" $ do+      let upper = "4BF92F3577B34DA6A3CE929D0E0E4736"+          lower = "4bf92f3577b34da6a3ce929d0e0e4736"+      traceIdFromHex upper @?= traceIdFromHex lower+      fmap traceIdToHex (traceIdFromHex upper) @?= Just lower+  , testCase "a span id parses from exactly 16 hex characters" $+      assertBool "valid span hex" (isJust (spanIdFromHex "00f067aa0ba902b7"))+  , testCase "an odd-length span id string is rejected" $+      assertBool "odd span length" (isNothing (spanIdFromHex "00f067aa0ba902b"))+  ]++byteTests :: [TestTree]+byteTests =+  [ testCase "16 bytes makes a trace id" $+      assertBool "16 bytes" (isJust (traceIdFromBytes (BS.replicate 16 1)))+  , testCase "15 or 17 bytes is rejected as a trace id" $ do+      assertBool "15 bytes" (isNothing (traceIdFromBytes (BS.replicate 15 1)))+      assertBool "17 bytes" (isNothing (traceIdFromBytes (BS.replicate 17 1)))+  , testCase "8 bytes makes a span id" $+      assertBool "8 bytes" (isJust (spanIdFromBytes (BS.replicate 8 1)))+  , testCase "7 or 9 bytes is rejected as a span id" $ do+      assertBool "7 bytes" (isNothing (spanIdFromBytes (BS.replicate 7 1)))+      assertBool "9 bytes" (isNothing (spanIdFromBytes (BS.replicate 9 1)))+  ]++validityTests :: [TestTree]+validityTests =+  [ testCase "a correctly-sized but all-zero trace id is invalid" $+      isValidTraceId (TraceId (BS.replicate 16 0)) @?= False+  , testCase "a non-zero, correctly-sized trace id is valid" $+      isValidTraceId (TraceId (BS.replicate 16 1)) @?= True+  , testCase "a wrong-length trace id is invalid" $+      isValidTraceId (TraceId (BS.replicate 15 1)) @?= False+  , testCase "a correctly-sized but all-zero span id is invalid" $+      isValidSpanId (SpanId (BS.replicate 8 0)) @?= False+  , testCase "a non-zero, correctly-sized span id is valid" $+      isValidSpanId (SpanId (BS.replicate 8 1)) @?= True+  , testCase "a wrong-length span id is invalid" $+      isValidSpanId (SpanId (BS.replicate 7 1)) @?= False+  ]++-- | A string of @n@ copies of the hex digit @a@.+hexDigits :: Int -> Text+hexDigits n = T.replicate n "a"
+ test/Effectful/Tracing/InMemorySpec.hs view
@@ -0,0 +1,231 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module      : Effectful.Tracing.InMemorySpec+-- Description : Behavioural and property tests for the in-memory interpreter.+module Effectful.Tracing.InMemorySpec+  ( tests+  ) where++import Control.Concurrent (threadDelay)+import Control.Exception (ErrorCall (ErrorCall), SomeException, throwIO, try)+import Control.Monad.IO.Class (liftIO)+import Data.Set qualified as Set+import Data.Text (Text)+import System.Timeout (timeout)++import Effectful (Eff, IOE, runEff, (:>))+import Hedgehog (Gen, Property, assert, evalIO, forAll, property, (===))+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))+import Test.Tasty.Hedgehog (testProperty)++import Effectful.Tracing+  ( Event (eventName)+  , Span+  , SpanStatus (Error, Ok)+  , Tracer+  , addAttribute+  , addEvent+  , attributeKey+  , setStatus+  , spanAttributes+  , spanContext+  , spanContextSpanId+  , spanContextTraceId+  , spanEndTime+  , spanEvents+  , spanName+  , spanParentContext+  , spanStartTime+  , spanStatus+  , updateName+  , withSpan+  )+import Effectful.Tracing.Interpreter.InMemory+  ( CapturedSpans+  , childrenOf+  , findSpan+  , newCapturedSpans+  , readCapturedSpans+  , rootSpans+  , runTracerInMemory+  )++tests :: TestTree+tests =+  testGroup+    "In-memory interpreter"+    [ testCase "single span is captured with name, ordered timing, and status" $ do+        spans <- captureSpans (withSpan "solo" (setStatus Ok))+        case spans of+          [s] -> do+            spanName s @?= "solo"+            spanStatus s @?= Ok+            assertBool "start <= end" (spanStartTime s <= spanEndTime s)+          _ -> assertBool "expected exactly one span" False+    , testCase "nested spans record the parent relationship" $ do+        spans <- captureSpans (withSpan "outer" (withSpan "inner" (pure ())))+        outer <- expectSpan "outer" spans+        inner <- expectSpan "inner" spans+        -- inner's parent is outer's context+        (spanContextSpanId . spanContext <$> Just outer)+          @?= (spanContextSpanId <$> spanParentContext inner)+        childrenOf outer spans @?= [inner]+        rootSpans spans @?= [outer]+    , testCase "sequential spans are siblings, not parent and child" $ do+        spans <-+          captureSpans+            (withSpan "parent" (withSpan "a" (pure ()) >> withSpan "b" (pure ())))+        parent <- expectSpan "parent" spans+        a <- expectSpan "a" spans+        b <- expectSpan "b" spans+        childrenOf parent spans @?= [a, b]+        childrenOf a spans @?= []+    , testCase "exception sets Error status, records an event, and re-raises" $ do+        (outcome, spans) <-+          withCapture $ \captured ->+            try (runEff (runTracerInMemory captured throwingSpan))+        case outcome :: Either SomeException () of+          Left _ -> pure ()+          Right () -> assertBool "expected the exception to propagate" False+        s <- expectSpan "boom" spans+        case spanStatus s of+          Error msg -> assertBool "error carries a message" (msg /= "")+          other -> assertBool ("expected Error status, got " <> show other) False+        assertBool+          "an exception event is recorded"+          (any ((== "exception") . eventName) (spanEvents s))+    , testCase "a span killed by an async exception is still closed exactly once" $ do+        (result, spans) <-+          withCapture $ \captured ->+            timeout 50_000 (runEff (runTracerInMemory captured slowSpan))+        result @?= Nothing+        case spans of+          [s] -> do+            assertBool "end time recorded" (spanStartTime s <= spanEndTime s)+            case spanStatus s of+              Error _ -> pure ()+              other -> assertBool ("expected Error status, got " <> show other) False+          _ -> assertBool "expected exactly one closed span" False+    , testCase "emit operations land on the lexically-current span" $ do+        spans <- captureSpans lexicalProgram+        outer <- expectSpan "outer" spans+        inner <- expectSpan "inner" spans+        assertBool "outer has its own attribute" (hasAttribute "o" outer)+        assertBool "outer does not have inner's attribute" (not (hasAttribute "i" outer))+        assertBool "inner has its own attribute" (hasAttribute "i" inner)+        assertBool "inner does not have outer's attribute" (not (hasAttribute "o" inner))+    , testCase "emit operations with no active span are silent no-ops" $ do+        spans <-+          captureSpans $ do+            addAttribute "orphan" ("x" :: Text)+            addEvent "orphan.event" []+            setStatus Ok+            withSpan "real" (addAttribute "k" ("v" :: Text))+        s <- expectSpan "real" spans+        length spans @?= 1+        assertBool "the real span kept its attribute" (hasAttribute "k" s)+        assertBool "no orphan attribute leaked onto the real span" (not (hasAttribute "orphan" s))+    , testCase "updateName replaces the active span's name" $ do+        spans <- captureSpans (withSpan "provisional" (updateName "GET /users/{id}"))+        case spans of+          [s] -> spanName s @?= "GET /users/{id}"+          _ -> assertBool "expected exactly one span" False+    , testCase "updateName only renames the lexically-current span" $ do+        spans <-+          captureSpans $+            withSpan "outer" $ do+              withSpan "inner" (updateName "renamed-inner")+              updateName "renamed-outer"+        outer <- expectSpan "renamed-outer" spans+        inner <- expectSpan "renamed-inner" spans+        childrenOf outer spans @?= [inner]+    , testCase "updateName with no active span is a silent no-op" $ do+        spans <-+          captureSpans $ do+            updateName "orphan"+            withSpan "real" (pure ())+        _ <- expectSpan "real" spans+        length spans @?= 1+    , testProperty "captured spans form a valid forest" prop_validForest+    ]++-- Programs under test -------------------------------------------------------++throwingSpan :: (Tracer :> es, IOE :> es) => Eff es ()+throwingSpan = withSpan "boom" $ do+  addAttribute "before.throw" ("set" :: Text)+  liftIO (throwIO (ErrorCall "deliberate failure"))++slowSpan :: (Tracer :> es, IOE :> es) => Eff es ()+slowSpan = withSpan "slow" (liftIO (threadDelay 1_000_000))++lexicalProgram :: Tracer :> es => Eff es ()+lexicalProgram = withSpan "outer" $ do+  addAttribute "o" ("outer" :: Text)+  withSpan "inner" (addAttribute "i" ("inner" :: Text))++-- Forest property -----------------------------------------------------------++-- | A span-tree shape: each node opens a span and runs its children inside it.+newtype Shape = Shape [Shape]+  deriving stock (Show)++genForest :: Gen [Shape]+genForest = Gen.list (Range.linear 0 3) (genShape 3)++genShape :: Int -> Gen Shape+genShape depth+  | depth <= 0 = pure (Shape [])+  | otherwise = Shape <$> Gen.list (Range.linear 0 3) (genShape (depth - 1))++shapeProgram :: Tracer :> es => Shape -> Eff es ()+shapeProgram (Shape children) = withSpan "node" (mapM_ shapeProgram children)++countNodes :: Shape -> Int+countNodes (Shape children) = 1 + sum (map countNodes children)++prop_validForest :: Property+prop_validForest = property $ do+  forest <- forAll genForest+  spans <- evalIO (captureSpans (mapM_ shapeProgram forest))+  -- every opened span is captured+  length spans === sum (map countNodes forest)+  -- every non-root span's parent is itself a captured span+  let identifier s = (spanContextTraceId (spanContext s), spanContextSpanId (spanContext s))+      captured = Set.fromList (map identifier spans)+      parents =+        [ (spanContextTraceId pc, spanContextSpanId pc)+        | s <- spans+        , Just pc <- [spanParentContext s]+        ]+  assert (all (`Set.member` captured) parents)++-- Helpers -------------------------------------------------------------------++-- | Run a traced program against a fresh buffer and return the captured spans.+captureSpans :: Eff '[Tracer, IOE] a -> IO [Span]+captureSpans program = snd <$> withCapture (\captured -> runEff (runTracerInMemory captured program))++-- | Provide a fresh buffer to an IO action, then return its result alongside+-- the spans captured into the buffer (read even if the action threw, as long+-- as the caller handled the exception).+withCapture :: (CapturedSpans -> IO a) -> IO (a, [Span])+withCapture k = do+  captured <- runEff newCapturedSpans+  a <- k captured+  spans <- runEff (readCapturedSpans captured)+  pure (a, spans)++expectSpan :: Text -> [Span] -> IO Span+expectSpan name spans =+  maybe (assertFailure ("expected a span named " <> show name)) pure (findSpan name spans)++hasAttribute :: Text -> Span -> Bool+hasAttribute key s = any ((== key) . attributeKey) (spanAttributes s)
+ test/Effectful/Tracing/Instrumentation/AmqpSpec.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.Instrumentation.AmqpSpec+-- Description : Tests for the broker-free helpers in the RabbitMQ binding.+--+-- The RabbitMQ wrappers ('Effectful.Tracing.Instrumentation.Amqp.publishMsgTraced',+-- 'Effectful.Tracing.Instrumentation.Amqp.getMsgTraced', and+-- 'Effectful.Tracing.Instrumentation.Amqp.withProcessSpan') all need a live+-- broker @Channel@ (or an @Envelope@ that embeds one), so they are covered by the+-- compile-only mirror in "Effectful.Tracing.CompileTest". 'messageHeaders' is the+-- one piece that is pure and broker-free: it decodes the trace-context headers a+-- consumer reads back, so it is exercised here directly.+--+-- Only present when built with @+amqp@.+module Effectful.Tracing.Instrumentation.AmqpSpec+  ( tests+  ) where++import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8)++import Hedgehog (Gen, forAll, property, (===))+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Hedgehog (testProperty)+import Test.Tasty.HUnit (testCase, (@?=))++import Network.AMQP (Message (msgHeaders), newMsg)+import Network.AMQP.Types+  ( FieldTable (FieldTable)+  , FieldValue (FVBool, FVInt32, FVString)+  )++import Effectful.Tracing.Instrumentation.Amqp (messageHeaders)++tests :: TestTree+tests =+  testGroup+    "Effectful.Tracing.Instrumentation.Amqp"+    [ testGroup+        "messageHeaders"+        [ testCase "a message with no headers yields no pairs" $+            messageHeaders newMsg @?= []+        , testCase "an empty header table yields no pairs" $+            messageHeaders (withHeaders []) @?= []+        , testCase "string-valued headers are decoded to text pairs" $+            messageHeaders+              (withHeaders [("traceparent", str traceparent), ("tracestate", str "k=v")])+              @?= [("traceparent", traceparent), ("tracestate", "k=v")]+        , testCase "non-string field values are dropped" $+            messageHeaders+              ( withHeaders+                  [ ("traceparent", str traceparent)+                  , ("priority", FVInt32 5)+                  , ("redelivered", FVBool True)+                  ]+              )+              @?= [("traceparent", traceparent)]+        , testProperty "every string header round-trips through messageHeaders" $+            property $ do+              entries <- forAll genStringEntries+              let fields = [(name, str value) | (name, value) <- entries]+              -- Map keying dedupes and orders by key, so compare as sorted maps.+              Map.fromList (messageHeaders (withHeaders fields))+                === Map.fromList entries+        ]+    ]+  where+    traceparent = "00-4bf92f3577b34da6a3ce929d0e0e4736-00f067aa0ba902b7-01"++-- | A 'Message' carrying the given AMQP header table.+withHeaders :: [(Text, FieldValue)] -> Message+withHeaders fields = newMsg {msgHeaders = Just (FieldTable (Map.fromList fields))}++-- | A string-valued AMQP header from UTF-8 text, the way the binding writes them.+str :: Text -> FieldValue+str = FVString . encodeUtf8++-- | Header entries with distinct ASCII keys and arbitrary text values. ASCII+-- keys keep the generator from colliding on UTF-8 normalization while still+-- exercising decoding of arbitrary text values.+genStringEntries :: Gen [(Text, Text)]+genStringEntries =+  Gen.list (Range.linear 0 8) $+    (,)+      <$> Gen.text (Range.linear 1 12) Gen.alphaNum+      <*> Gen.text (Range.linear 0 24) Gen.unicode
+ test/Effectful/Tracing/Instrumentation/DatabaseSpec.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.Instrumentation.DatabaseSpec+-- Description : Tests for the framework-agnostic database span helpers.+--+-- These exercise the pure helpers ('inferOperationName', 'querySpanName',+-- 'queryAttributes') directly and run 'withQuerySpan' through the in-memory+-- interpreter, asserting the emitted span is @client@-kind, named by the+-- convention, and carries exactly the @db.*@ attributes for the fields that were+-- set. No live database is involved: the @postgresql-simple@ wrappers are thin+-- delegations to this core, which is what needs covering.+module Effectful.Tracing.Instrumentation.DatabaseSpec+  ( tests+  ) where++import Effectful (Eff, IOE, runEff)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import Effectful.Tracing (Tracer, withSpan)+import Effectful.Tracing.Attribute (Attribute (attributeKey, attributeValue), AttributeValue (AttrText))+import Effectful.Tracing.Instrumentation.Database+  ( DatabaseQuery (queryCollection, queryNamespace, queryOperation, queryText)+  , databaseQuery+  , inferOperationName+  , queryAttributes+  , querySpanName+  , withQuerySpan+  )+import Effectful.Tracing.Internal.Types (Span, SpanKind (Client), spanAttributes, spanKind, spanName)+import Effectful.Tracing.Interpreter.InMemory+  ( newCapturedSpans+  , readCapturedSpans+  , runTracerInMemory+  )++tests :: TestTree+tests =+  testGroup+    "Instrumentation.Database"+    [ testGroup "inferOperationName" inferOperationCases+    , testGroup "querySpanName" spanNameCases+    , testGroup "queryAttributes" attributeCases+    , testGroup "withQuerySpan" withQuerySpanCases+    ]++inferOperationCases :: [TestTree]+inferOperationCases =+  [ testCase "upper-cases the leading keyword" $+      inferOperationName "select * from users" @?= Just "SELECT"+  , testCase "keeps an already-upper keyword" $+      inferOperationName "INSERT INTO orders VALUES (?)" @?= Just "INSERT"+  , testCase "ignores leading whitespace" $+      inferOperationName "  \n  delete from sessions" @?= Just "DELETE"+  , testCase "blank statement yields Nothing" $+      inferOperationName "   " @?= Nothing+  , testCase "empty statement yields Nothing" $+      inferOperationName "" @?= Nothing+  ]++spanNameCases :: [TestTree]+spanNameCases =+  [ testCase "operation and collection" $+      querySpanName+        (databaseQuery "postgresql") {queryOperation = Just "SELECT", queryCollection = Just "users"}+        @?= "SELECT users"+  , testCase "operation only" $+      querySpanName (databaseQuery "postgresql") {queryOperation = Just "SELECT"} @?= "SELECT"+  , testCase "falls back to the system name" $+      querySpanName (databaseQuery "postgresql") @?= "postgresql"+  , testCase "collection without operation falls back to the system name" $+      querySpanName (databaseQuery "postgresql") {queryCollection = Just "users"} @?= "postgresql"+  ]++attributeCases :: [TestTree]+attributeCases =+  [ testCase "system only when nothing else is set" $+      keys (databaseQuery "postgresql") @?= ["db.system.name"]+  , testCase "includes every set optional field in convention order" $+      keys+        (databaseQuery "postgresql")+          { queryText = Just "SELECT 1"+          , queryOperation = Just "SELECT"+          , queryCollection = Just "users"+          , queryNamespace = Just "app"+          }+        @?= [ "db.system.name"+            , "db.query.text"+            , "db.operation.name"+            , "db.collection.name"+            , "db.namespace"+            ]+  , testCase "omits unset optional fields" $+      keys (databaseQuery "postgresql") {queryOperation = Just "SELECT"}+        @?= ["db.system.name", "db.operation.name"]+  , testCase "records the system name value" $+      lookup "db.system.name" (pairs (databaseQuery "mysql")) @?= Just (AttrText "mysql")+  ]+  where+    keys = map attributeKey . queryAttributes+    pairs = map (\a -> (attributeKey a, attributeValue a)) . queryAttributes++withQuerySpanCases :: [TestTree]+withQuerySpanCases =+  [ testCase "emits a client-kind span named by the convention" $ do+      spans <-+        run $+          withQuerySpan+            (databaseQuery "postgresql") {queryOperation = Just "SELECT", queryCollection = Just "users"}+            (pure ())+      case spans of+        [s] -> do+          spanName s @?= "SELECT users"+          spanKind s @?= Client+        other -> fail ("expected exactly one captured span, got " <> show (length other))+  , testCase "annotates the span with the db.* attributes" $ do+      spans <-+        run $+          withQuerySpan+            (databaseQuery "postgresql") {queryText = Just "SELECT 1", queryOperation = Just "SELECT"}+            (pure ())+      case spans of+        [s] ->+          map attributeKey (spanAttributes s)+            @?= ["db.system.name", "db.query.text", "db.operation.name"]+        other -> fail ("expected exactly one captured span, got " <> show (length other))+  , testCase "nests under an enclosing span" $ do+      spans <- run (withSpan "outer" (withQuerySpan (databaseQuery "postgresql") (pure ())))+      map spanName spans @?= ["postgresql", "outer"]+  ]++-- | Run a 'Tracer' computation through the in-memory interpreter, returning the+-- captured spans (innermost first, as the interpreter records them on close).+run :: Eff '[Tracer, IOE] a -> IO [Span]+run action = runEff $ do+  captured <- newCapturedSpans+  _ <- runTracerInMemory captured action+  readCapturedSpans captured
+ test/Effectful/Tracing/Instrumentation/HttpClientSpec.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.Instrumentation.HttpClientSpec+-- Description : Tests for the http-client tracing wrapper.+--+-- These run against a real loopback server (a tiny WAI app served by Warp on an+-- ephemeral port via 'Warp.testWithApplication') so the wrapper exercises an+-- actual request/response. The server records the headers it received, which+-- lets us assert that the wrapper injected a @traceparent@ carrying the client+-- span's trace id (propagation end to end), and the captured spans let us assert+-- the @client@ kind, the stable HTTP \/ URL attributes, and the status mapping.+module Effectful.Tracing.Instrumentation.HttpClientSpec+  ( tests+  ) where++import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar)+import Control.Monad (void)+import Data.List (find, isInfixOf)+import Data.Text qualified as T++import Network.HTTP.Client+  ( Manager+  , Request+  , defaultManagerSettings+  , newManager+  , parseRequest+  )+import Network.HTTP.Types (Status, status200, status500)+import Network.HTTP.Types.Header (RequestHeaders)+import Network.Wai (Application, requestHeaders, responseLBS)+import Network.Wai.Handler.Warp (Port)+import Network.Wai.Handler.Warp qualified as Warp++import Effectful (Eff, IOE, runEff, (:>))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++import Effectful.Tracing+  ( Span (spanAttributes, spanContext, spanKind, spanStatus)+  , SpanContext (spanContextTraceId)+  , SpanKind (Client)+  , SpanStatus (Error, Unset)+  , Tracer+  , extractContext+  , traceIdToHex+  , withSpan+  )+import Effectful.Tracing.Attribute (Attribute (Attribute), AttributeValue (AttrInt, AttrText))+import Effectful.Tracing.Instrumentation.HttpClient (httpLbsTraced)+import Effectful.Tracing.Interpreter.InMemory+  ( newCapturedSpans+  , readCapturedSpans+  , runTracerInMemory+  )++tests :: TestTree+tests =+  testGroup+    "Instrumentation.HttpClient"+    [ testCase "opens a client span and records http attributes" $+        withEchoServer status200 $ \captured port -> do+          (spans, _) <- runClient port "/widgets"+          s <- clientSpan spans+          lookupText "http.request.method" s @?= Just "GET"+          assertBool+            "url.full contains the request path"+            (maybe False (("/widgets" `isInfixOf`) . T.unpack) (lookupText "url.full" s))+          lookupInt "http.response.status_code" s @?= Just 200+          spanStatus s @?= Unset+          -- The server received our traceparent, carrying the client span's trace.+          headers <- readMVar captured+          remote <- maybe (assertFailure "server saw no traceparent") pure (extractContext headers)+          traceIdToHex (spanContextTraceId remote)+            @?= traceIdToHex (spanContextTraceId (spanContext s))+    , testCase "a >= 400 response sets the span status to error" $+        withEchoServer status500 $ \_ port -> do+          (spans, _) <- runClient port "/boom"+          s <- clientSpan spans+          lookupInt "http.response.status_code" s @?= Just 500+          case spanStatus s of+            Error _ -> pure ()+            other -> assertFailure ("expected Error status, got " <> show other)+    ]++-- | Serve a tiny app on an ephemeral port that records the inbound headers and+-- replies with the given status, then run the continuation against it.+withEchoServer :: Status -> (MVar RequestHeaders -> Port -> IO a) -> IO a+withEchoServer responseStatus k = do+  captured <- newMVar []+  let app :: Application+      app req respond = do+        modifyMVar_ captured (const (pure (requestHeaders req)))+        respond (responseLBS responseStatus [] "ok")+  Warp.testWithApplication (pure app) (k captured)++-- | Send a traced GET to the loopback server, returning the captured spans.+runClient :: Port -> String -> IO ([Span], ())+runClient port path = do+  manager <- newManager defaultManagerSettings+  req <- parseRequest ("http://localhost:" <> show port <> path)+  spans <- runEff $ do+    cap <- newCapturedSpans+    _ <- runTracerInMemory cap (call manager req)+    readCapturedSpans cap+  pure (spans, ())+  where+    call :: (Tracer :> es, IOE :> es) => Manager -> Request -> Eff es ()+    call manager req = withSpan "outer" (void (httpLbsTraced req manager))++-- | The single @client@-kind span among the captured spans.+clientSpan :: [Span] -> IO Span+clientSpan spans =+  maybe (assertFailure "expected a client span") pure (find ((== Client) . spanKind) spans)++lookupText :: T.Text -> Span -> Maybe T.Text+lookupText key s =+  case findAttr key s of+    Just (AttrText t) -> Just t+    _ -> Nothing++lookupInt :: T.Text -> Span -> Maybe Int+lookupInt key s =+  case findAttr key s of+    Just (AttrInt n) -> Just (fromIntegral n)+    _ -> Nothing++findAttr :: T.Text -> Span -> Maybe AttributeValue+findAttr key s =+  fmap (\(Attribute _ v) -> v) (find (\(Attribute k _) -> k == key) (spanAttributes s))
+ test/Effectful/Tracing/Instrumentation/MessagingSpec.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.Instrumentation.MessagingSpec+-- Description : Tests for the framework-agnostic messaging span helpers.+--+-- These exercise the pure helpers ('operationTypeText', 'messagingSpanKind',+-- 'messagingSpanName', 'messagingAttributes') directly and run+-- 'withMessagingSpan' \/ 'withConsumerSpan' through the in-memory interpreter,+-- asserting the emitted span carries the producer \/ consumer kind, the+-- convention name, and exactly the @messaging.*@ attributes for the fields that+-- were set. The propagation round-trip ('injectMessageHeaders' \/+-- 'extractMessageHeaders') and the consumer continuing a remote parent are+-- covered too, since carrying the trace across the broker is the distinguishing+-- messaging behaviour. No live broker is involved.+module Effectful.Tracing.Instrumentation.MessagingSpec+  ( tests+  ) where++import Data.Maybe (isJust)+import Data.Text (Text)++import Effectful (Eff, IOE, runEff)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase, (@?=))++import Effectful.Tracing (Tracer, withSpan)+import Effectful.Tracing.Attribute+  ( Attribute (attributeKey, attributeValue)+  , AttributeValue (AttrInt, AttrText)+  )+import Effectful.Tracing.Instrumentation.Messaging+  ( MessagingOperation+      ( messagingBatchCount+      , messagingBodySize+      , messagingConversationId+      , messagingDestination+      , messagingDestinationTemplate+      , messagingMessageId+      , messagingOperationName+      )+  , MessagingOperationType (Create, Process, Receive, Send, Settle)+  , extractMessageHeaders+  , injectMessageHeaders+  , messagingAttributes+  , messagingOperation+  , messagingSpanKind+  , messagingSpanName+  , operationTypeText+  , withConsumerSpan+  , withMessagingSpan+  )+import Effectful.Tracing.Internal.Ids (traceIdToHex)+import Effectful.Tracing.Internal.Types+  ( Span+  , SpanContext (spanContextTraceId)+  , SpanKind (Client, Consumer, Producer)+  , spanAttributes+  , spanContext+  , spanKind+  , spanName+  )+import Effectful.Tracing.Interpreter.InMemory+  ( newCapturedSpans+  , readCapturedSpans+  , runTracerInMemory+  )++tests :: TestTree+tests =+  testGroup+    "Instrumentation.Messaging"+    [ testGroup "operationTypeText" operationTypeCases+    , testGroup "messagingSpanKind" spanKindCases+    , testGroup "messagingSpanName" spanNameCases+    , testGroup "messagingAttributes" attributeCases+    , testGroup "withMessagingSpan" withMessagingSpanCases+    , testGroup "propagation" propagationCases+    ]++operationTypeCases :: [TestTree]+operationTypeCases =+  [ testCase "create" $ operationTypeText Create @?= "create"+  , testCase "send" $ operationTypeText Send @?= "send"+  , testCase "receive" $ operationTypeText Receive @?= "receive"+  , testCase "process" $ operationTypeText Process @?= "process"+  , testCase "settle" $ operationTypeText Settle @?= "settle"+  ]++spanKindCases :: [TestTree]+spanKindCases =+  [ testCase "create is a producer" $ messagingSpanKind Create @?= Producer+  , testCase "send is a producer" $ messagingSpanKind Send @?= Producer+  , testCase "receive is a consumer" $ messagingSpanKind Receive @?= Consumer+  , testCase "process is a consumer" $ messagingSpanKind Process @?= Consumer+  , testCase "settle is a client" $ messagingSpanKind Settle @?= Client+  ]++spanNameCases :: [TestTree]+spanNameCases =+  [ testCase "operation name and destination" $+      messagingSpanName+        (messagingOperation "kafka" Send) {messagingOperationName = Just "publish", messagingDestination = Just "orders"}+        @?= "publish orders"+  , testCase "falls back to the operation type for the leading word" $+      messagingSpanName (messagingOperation "kafka" Send) {messagingDestination = Just "orders"}+        @?= "send orders"+  , testCase "prefers the destination template over the destination name" $+      messagingSpanName+        (messagingOperation "kafka" Send)+          { messagingDestination = Just "orders-42"+          , messagingDestinationTemplate = Just "orders-{shard}"+          }+        @?= "send orders-{shard}"+  , testCase "operation type only when no destination is known" $+      messagingSpanName (messagingOperation "kafka" Receive) @?= "receive"+  ]++attributeCases :: [TestTree]+attributeCases =+  [ testCase "system and operation type when nothing else is set" $+      keys (messagingOperation "kafka" Send)+        @?= ["messaging.system", "messaging.operation.type"]+  , testCase "includes every set optional field in convention order" $+      keys+        (messagingOperation "kafka" Send)+          { messagingOperationName = Just "publish"+          , messagingDestination = Just "orders"+          , messagingDestinationTemplate = Just "orders-{shard}"+          , messagingMessageId = Just "m-1"+          , messagingConversationId = Just "c-1"+          , messagingBodySize = Just 128+          , messagingBatchCount = Just 4+          }+        @?= [ "messaging.system"+            , "messaging.operation.type"+            , "messaging.operation.name"+            , "messaging.destination.name"+            , "messaging.destination.template"+            , "messaging.message.id"+            , "messaging.message.conversation_id"+            , "messaging.message.body.size"+            , "messaging.batch.message_count"+            ]+  , testCase "records the system name and operation type values" $ do+      let ps = pairs (messagingOperation "rabbitmq" Process)+      lookup "messaging.system" ps @?= Just (AttrText "rabbitmq")+      lookup "messaging.operation.type" ps @?= Just (AttrText "process")+  , testCase "records integer sizes as integer attributes" $ do+      let ps = pairs (messagingOperation "kafka" Send) {messagingBatchCount = Just 4}+      lookup "messaging.batch.message_count" ps @?= Just (AttrInt 4)+  ]+  where+    keys = map attributeKey . messagingAttributes+    pairs = map (\a -> (attributeKey a, attributeValue a)) . messagingAttributes++withMessagingSpanCases :: [TestTree]+withMessagingSpanCases =+  [ testCase "emits a producer-kind span named by the convention" $ do+      spans <-+        run $+          withMessagingSpan+            (messagingOperation "kafka" Send) {messagingDestination = Just "orders"}+            (pure ())+      case spans of+        [s] -> do+          spanName s @?= "send orders"+          spanKind s @?= Producer+        other -> fail ("expected exactly one captured span, got " <> show (length other))+  , testCase "emits a consumer-kind span for a process operation" $ do+      spans <- run (withMessagingSpan (messagingOperation "kafka" Process) (pure ()))+      map spanKind spans @?= [Consumer]+  , testCase "annotates the span with the messaging.* attributes" $ do+      spans <-+        run $+          withMessagingSpan+            (messagingOperation "kafka" Send) {messagingDestination = Just "orders"}+            (pure ())+      case spans of+        [s] ->+          map attributeKey (spanAttributes s)+            @?= ["messaging.system", "messaging.operation.type", "messaging.destination.name"]+        other -> fail ("expected exactly one captured span, got " <> show (length other))+  , testCase "nests under an enclosing span" $ do+      spans <- run (withSpan "outer" (withMessagingSpan (messagingOperation "kafka" Send) (pure ())))+      map spanName spans @?= ["send", "outer"]+  ]++propagationCases :: [TestTree]+propagationCases =+  [ testCase "inject emits a lowercase traceparent header for the active span" $ do+      headers <- runResult (withSpan "outbound" injectMessageHeaders)+      assertBool "a traceparent header is present" ("traceparent" `elem` map fst headers)+  , testCase "inject emits no headers when there is no active span" $ do+      headers <- runResult injectMessageHeaders+      headers @?= []+  , testCase "inject then extract round-trips to a remote context" $ do+      headers <- runResult (withSpan "outbound" injectMessageHeaders)+      assertBool "round-trips to a context" (isJust (extractMessageHeaders headers))+  , testCase "consumer span continues the remote trace from the message headers" $ do+      spans <-+        run (withConsumerSpan remoteHeaders (messagingOperation "kafka" Process) (pure ()))+      case spans of+        [s] -> traceIdToHex (spanContextTraceId (spanContext s)) @?= remoteTraceIdHex+        other -> fail ("expected exactly one captured span, got " <> show (length other))+  , testCase "consumer span opens a fresh trace when headers carry no context" $ do+      spans <-+        run (withConsumerSpan [] (messagingOperation "kafka" Process) (pure ()))+      case spans of+        [s] ->+          assertBool+            "trace id is not the remote one"+            (traceIdToHex (spanContextTraceId (spanContext s)) /= remoteTraceIdHex)+        other -> fail ("expected exactly one captured span, got " <> show (length other))+  ]++-- | A canonical W3C @traceparent@ as a text message header, plus its trace id,+-- standing in for context a producer attached to a message.+remoteHeaders :: [(Text, Text)]+remoteHeaders =+  [("traceparent", "00-" <> remoteTraceIdHex <> "-00f067aa0ba902b7-01")]++remoteTraceIdHex :: Text+remoteTraceIdHex = "4bf92f3577b34da6a3ce929d0e0e4736"++-- | Run a 'Tracer' computation through the in-memory interpreter, returning the+-- captured spans (innermost first, as the interpreter records them on close).+run :: Eff '[Tracer, IOE] a -> IO [Span]+run action = runEff $ do+  captured <- newCapturedSpans+  _ <- runTracerInMemory captured action+  readCapturedSpans captured++-- | Run a 'Tracer' computation through the in-memory interpreter, discarding the+-- captured spans and returning the computation's result.+runResult :: Eff '[Tracer, IOE] a -> IO a+runResult action = runEff $ do+  captured <- newCapturedSpans+  runTracerInMemory captured action
+ test/Effectful/Tracing/Instrumentation/ServantSpec.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}++-- |+-- Module      : Effectful.Tracing.Instrumentation.ServantSpec+-- Description : Tests for the Servant route-aware tracing middleware.+--+-- A tiny two-endpoint Servant API is served and driven through+-- 'traceServantMiddleware' with hand-built requests, run through the in-memory+-- interpreter so the resulting span can be inspected. We assert that an endpoint+-- annotated with 'WithSpanName' renames its server span to @\"{method} {route}\"@+-- and records the route template as @http.route@, while an unannotated endpoint+-- keeps the default method name and carries no route.+module Effectful.Tracing.Instrumentation.ServantSpec+  ( tests+  ) where++import Control.Monad (void)+import Data.List (find)+import Data.Maybe (isNothing)+import Data.Proxy (Proxy (Proxy))+import Data.Text (Text)+import Data.Text qualified as T++import Network.Wai (Application, Request (pathInfo, requestMethod), defaultRequest)+import Network.Wai.Internal (ResponseReceived (ResponseReceived))++import Servant+  ( Capture+  , Get+  , Handler+  , PlainText+  , Server+  , serve+  , type (:<|>) ((:<|>))+  , type (:>)+  )++import Effectful (Eff, IOE, UnliftStrategy (SeqUnlift), runEff, withEffToIO)+import Effectful qualified as E+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++import Effectful.Tracing+  ( Span (spanAttributes, spanKind, spanName)+  , SpanKind (Server)+  , Tracer+  )+import Effectful.Tracing.Attribute (Attribute (Attribute), AttributeValue (AttrText))+import Effectful.Tracing.Instrumentation.Servant (WithSpanName, traceServantMiddleware)+import Effectful.Tracing.Interpreter.InMemory+  ( newCapturedSpans+  , readCapturedSpans+  , runTracerInMemory+  )++-- | A two-endpoint API: an annotated, parameterized route and an unannotated+-- one. 'PlainText' avoids an @aeson@ dependency in the test.+type API =+  WithSpanName "/users/{id}" :> "users" :> Capture "id" Int :> Get '[PlainText] Text+    :<|> "health" :> Get '[PlainText] Text++server :: Server API+server = handleUser :<|> handleHealth+  where+    handleUser :: Int -> Handler Text+    handleUser uid = pure ("user " <> T.pack (show uid))++    handleHealth :: Handler Text+    handleHealth = pure "ok"++app :: Application+app = serve (Proxy :: Proxy API) server++tests :: TestTree+tests =+  testGroup+    "Instrumentation.Servant"+    [ testCase "an annotated endpoint is renamed to {method} {route}" $ do+        spans <- runServant (get ["users", "42"])+        s <- single spans+        spanName s @?= "GET /users/{id}"+        spanKind s @?= Server+        lookupText "http.route" s @?= Just "/users/{id}"+    , testCase "an unannotated endpoint keeps the default method name" $ do+        spans <- runServant (get ["health"])+        s <- single spans+        spanName s @?= "GET"+        assertBool "no http.route on an unannotated endpoint" (isNothing (lookupText "http.route" s))+    ]++-- | Serve the API around 'traceServantMiddleware' for one request, returning the+-- captured spans.+runServant :: Request -> IO [Span]+runServant req = runEff $ do+  cap <- newCapturedSpans+  runTracerInMemory cap (runOnce req)+  readCapturedSpans cap+  where+    runOnce :: (Tracer E.:> es, IOE E.:> es) => Request -> Eff es ()+    runOnce r =+      withEffToIO SeqUnlift $ \runInIO ->+        void (traceServantMiddleware runInIO app r discardResponse)++discardResponse :: a -> IO ResponseReceived+discardResponse _ = pure ResponseReceived++-- | A GET request for the given decoded path segments. Servant routes on+-- 'pathInfo'.+get :: [Text] -> Request+get segments =+  defaultRequest+    { requestMethod = "GET"+    , pathInfo = segments+    }++single :: [a] -> IO a+single [x] = pure x+single other = assertFailure ("expected exactly one span, got " <> show (length other))++lookupText :: Text -> Span -> Maybe Text+lookupText key s =+  case fmap (\(Attribute _ v) -> v) (find (\(Attribute k _) -> k == key) (spanAttributes s)) of+    Just (AttrText t) -> Just t+    _ -> Nothing
+ test/Effectful/Tracing/Instrumentation/WaiSpec.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.Instrumentation.WaiSpec+-- Description : Tests for the WAI tracing middleware.+--+-- The middleware is exercised against a hand-built 'Request' and a trivial+-- 'Application', run through the in-memory interpreter so the resulting spans+-- can be inspected directly. We assert the shape a server span should have: a+-- @server@ kind, a name and the stable HTTP \/ URL attributes from the request,+-- the response status code, a 5xx mapped to an error status, an inbound+-- @traceparent@ continued as the parent trace, and an exception in the handler+-- recorded and re-raised.+module Effectful.Tracing.Instrumentation.WaiSpec+  ( tests+  ) where++import Control.Exception (SomeException, throwIO)+import Control.Monad (void)+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as LBS+import Data.List (find)+import Data.Maybe (isNothing)+import Data.Text (Text)++import Network.HTTP.Types (Status, status200, status404, status503)+import Network.Wai+  ( Application+  , Request (rawPathInfo, rawQueryString, requestHeaders, requestMethod)+  , defaultRequest+  , responseLBS+  )+import Network.Wai.Internal (ResponseReceived (ResponseReceived))++import Effectful (Eff, IOE, UnliftStrategy (SeqUnlift), runEff, withEffToIO, (:>))+import Effectful.Exception qualified as Exc+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++import Effectful.Tracing+  ( Span (spanAttributes, spanContext, spanKind, spanName, spanParentContext, spanStatus)+  , SpanContext (spanContextSpanId, spanContextTraceId)+  , SpanKind (Server)+  , SpanStatus (Error, Unset)+  , Tracer+  , spanIdToHex+  , traceIdToHex+  )+import Effectful.Tracing.Attribute (Attribute (Attribute), AttributeValue (AttrInt, AttrText))+import Effectful.Tracing.Instrumentation.Wai (traceMiddleware)+import Effectful.Tracing.Interpreter.InMemory+  ( newCapturedSpans+  , readCapturedSpans+  , runTracerInMemory+  )++tests :: TestTree+tests =+  testGroup+    "Instrumentation.Wai"+    [ testCase "opens a server span named for the method, with http attributes" $ do+        (spans, outcome) <- runWai (get "/users") (ok "hi")+        assertRight outcome+        s <- single spans+        spanName s @?= "GET"+        spanKind s @?= Server+        lookupText "http.request.method" s @?= Just "GET"+        lookupText "url.path" s @?= Just "/users"+        lookupText "url.scheme" s @?= Just "http"+        lookupInt "http.response.status_code" s @?= Just 200+        spanStatus s @?= Unset+    , testCase "with no query string url.query is omitted" $ do+        (spans, _) <- runWai (get "/users") (ok "hi")+        s <- single spans+        lookupText "url.query" s @?= Nothing+    , testCase "records path and query in url.path and url.query" $ do+        (spans, _) <- runWai (get "/search?q=cat") (ok "hi")+        s <- single spans+        lookupText "url.path" s @?= Just "/search"+        lookupText "url.query" s @?= Just "q=cat"+    , testCase "a 4xx leaves the span status unset" $ do+        (spans, _) <- runWai (get "/missing") (respondWith status404 "nope")+        s <- single spans+        lookupInt "http.response.status_code" s @?= Just 404+        spanStatus s @?= Unset+    , testCase "a 5xx marks the span as an error" $ do+        (spans, _) <- runWai (get "/boom") (respondWith status503 "down")+        s <- single spans+        lookupInt "http.response.status_code" s @?= Just 503+        assertError (spanStatus s)+    , testCase "with no inbound traceparent the span is a root" $ do+        (spans, _) <- runWai (get "/") (ok "hi")+        s <- single spans+        assertBool "server span is a root" (isNothing (spanParentContext s))+    , testCase "continues an inbound distributed trace" $ do+        let req = withTraceparent traceparentValue (get "/users")+        (spans, _) <- runWai req (ok "hi")+        s <- single spans+        -- The server span joins the remote trace and points at the remote span.+        traceIdToHex (spanContextTraceId (spanContext s)) @?= remoteTraceHex+        case spanParentContext s of+          Just parent -> spanIdToHex (spanContextSpanId parent) @?= remoteSpanHex+          Nothing -> assertFailure "expected the server span to have a remote parent"+    , testCase "records and re-raises an exception thrown by the handler" $ do+        (spans, outcome) <- runWai (get "/throws") boom+        case outcome of+          Left _ -> pure ()+          Right () -> assertFailure "expected the handler exception to propagate"+        s <- single spans+        assertError (spanStatus s)+    ]++-- W3C traceparent vector: version 00, a known trace id and span id, sampled.+traceparentValue :: ByteString+traceparentValue = "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01"++remoteTraceHex :: Text+remoteTraceHex = "0af7651916cd43dd8448eb211c80319c"++remoteSpanHex :: Text+remoteSpanHex = "b7ad6b7169203331"++-- | Run the middleware around an application for one request, returning the+-- captured spans and whether the request completed or threw.+runWai :: Request -> Application -> IO ([Span], Either SomeException ())+runWai req app = runEff $ do+  cap <- newCapturedSpans+  outcome <- Exc.try (runTracerInMemory cap (runOnce req app))+  spans <- readCapturedSpans cap+  pure (spans, outcome)+  where+    runOnce :: (Tracer :> es, IOE :> es) => Request -> Application -> Eff es ()+    runOnce r a =+      withEffToIO SeqUnlift $ \runInIO ->+        void (traceMiddleware runInIO a r discardResponse)++-- | A responder that ignores the response (we read what we need from the span).+discardResponse :: a -> IO ResponseReceived+discardResponse _ = pure ResponseReceived++-- Request builders ----------------------------------------------------------++-- | Build a GET request, splitting any query string off the path the way WAI+-- does: @rawPathInfo@ holds the path and @rawQueryString@ holds the query+-- (including its leading @?@).+get :: ByteString -> Request+get raw =+  defaultRequest+    { requestMethod = "GET"+    , rawPathInfo = path+    , rawQueryString = query+    }+  where+    (path, query) = BS.break (== qMark) raw+    qMark = 63 -- '?'++withTraceparent :: ByteString -> Request -> Request+withTraceparent value req =+  req {requestHeaders = ("traceparent", value) : requestHeaders req}++-- Application builders -------------------------------------------------------++ok :: LBS.ByteString -> Application+ok = respondWith status200++respondWith :: Status -> LBS.ByteString -> Application+respondWith st body _ respond = respond (responseLBS st [] body)++boom :: Application+boom _ _ = throwIO (userError "handler exploded")++-- Assertions / lookups -------------------------------------------------------++single :: [a] -> IO a+single [x] = pure x+single other = assertFailure ("expected exactly one span, got " <> show (length other))++assertRight :: Either SomeException () -> IO ()+assertRight (Right ()) = pure ()+assertRight (Left err) = assertFailure ("expected success, got exception: " <> show err)++assertError :: SpanStatus -> IO ()+assertError (Error _) = pure ()+assertError other = assertFailure ("expected Error status, got " <> show other)++lookupText :: Text -> Span -> Maybe Text+lookupText key s =+  case findAttr key s of+    Just (AttrText t) -> Just t+    _ -> Nothing++lookupInt :: Text -> Span -> Maybe Int+lookupInt key s =+  case findAttr key s of+    Just (AttrInt n) -> Just (fromIntegral n)+    _ -> Nothing++findAttr :: Text -> Span -> Maybe AttributeValue+findAttr key s =+  fmap (\(Attribute _ v) -> v) (find (\(Attribute k _) -> k == key) (spanAttributes s))
+ test/Effectful/Tracing/LifecycleSpec.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.LifecycleSpec+-- Description : Tests for the shared span lifecycle in "Internal.Live".+--+-- These exercise the parts of the shared lifecycle that the per-interpreter+-- specs do not: continuing a remote trace under 'withRemoteParent', starting a+-- detached root in-thread under 'withLinkedRoot', honoring an explicit start+-- time, the 'setStatus' transition rules end to end, and the fact that+-- 'recordException' records an event without changing the status. They run+-- through the in-memory interpreter, which shares this lifecycle with the+-- pretty-print and OpenTelemetry interpreters.+module Effectful.Tracing.LifecycleSpec+  ( tests+  ) where++import Control.Exception (ErrorCall (ErrorCall), toException)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Time.Clock (UTCTime)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)++import Effectful (Eff, IOE, runEff)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++import Effectful.Tracing+  ( Event (eventName)+  , Link (Link, linkContext)+  , Span+  , SpanArguments (startTime)+  , SpanContext (..)+  , SpanStatus (Error, Ok, Unset)+  , Timestamp (Timestamp)+  , Tracer+  , defaultSpanArguments+  , defaultTraceFlags+  , emptyTraceState+  , getActiveSpan+  , recordException+  , setSampled+  , setStatus+  , spanContext+  , spanEvents+  , spanLinks+  , spanParentContext+  , spanStartTime+  , spanStatus+  , spanIdFromHex+  , traceIdFromHex+  , withLinkedRoot+  , withRemoteParent+  , withSpan+  , withSpan'+  )+import Effectful.Tracing.Interpreter.InMemory+  ( findSpan+  , newCapturedSpans+  , readCapturedSpans+  , runTracerInMemory+  )++tests :: TestTree+tests =+  testGroup+    "Span lifecycle"+    [ testCase "withRemoteParent continues the remote trace and parents to it" $ do+        spans <- captureSpans (withRemoteParent remoteContext (withSpan "child" (pure ())))+        child <- expectSpan "child" spans+        spanContextTraceId (spanContext child) @?= spanContextTraceId remoteContext+        fmap spanContextSpanId (spanParentContext child)+          @?= Just (spanContextSpanId remoteContext)+        assertBool+          "the child's parent is marked remote"+          (fmap spanContextIsRemote (spanParentContext child) == Just True)+    , testCase "withLinkedRoot starts a new trace in-thread and links back" $ do+        spans <-+          captureSpans $+            withSpan "outer" $ do+              parent <- getActiveSpan+              case parent of+                Just ctx -> withLinkedRoot [Link ctx []] (withSpan "root" (pure ()))+                Nothing -> pure ()+        outer <- expectSpan "outer" spans+        root <- expectSpan "root" spans+        spanParentContext root @?= Nothing+        assertBool+          "the linked root is a new trace, not the outer one"+          (spanContextTraceId (spanContext root) /= spanContextTraceId (spanContext outer))+        assertBool+          "the linked root carries a link back to the outer span"+          (spanContext outer `elem` map linkContext (spanLinks root))+    , testCase "an explicit start time is used verbatim" $ do+        let fixedStart = posixSecondsToUTCTime 1000 :: UTCTime+        spans <-+          captureSpans+            (withSpan' "timed" defaultSpanArguments {startTime = Just fixedStart} (pure ()))+        s <- expectSpan "timed" spans+        spanStartTime s @?= Timestamp fixedStart+    , testCase "Ok is terminal: a later Error does not override it" $ do+        spans <- captureSpans (withSpan "s" (setStatus Ok >> setStatus (Error "late")))+        s <- expectSpan "s" spans+        spanStatus s @?= Ok+    , testCase "an Error is overridden by a later Ok" $ do+        spans <- captureSpans (withSpan "s" (setStatus (Error "early") >> setStatus Ok))+        s <- expectSpan "s" spans+        spanStatus s @?= Ok+    , testCase "recordException records an event but leaves the status Unset" $ do+        spans <-+          captureSpans+            (withSpan "s" (recordException (toException (ErrorCall "noted, not fatal"))))+        s <- expectSpan "s" spans+        spanStatus s @?= Unset+        assertBool+          "an exception event is recorded"+          (any ((== "exception") . eventName) (spanEvents s))+    ]++-- | A remote span context, as if extracted from an inbound request.+remoteContext :: SpanContext+remoteContext =+  SpanContext+    { spanContextTraceId = unsafeHex traceIdFromHex "4bf92f3577b34da6a3ce929d0e0e4736"+    , spanContextSpanId = unsafeHex spanIdFromHex "00f067aa0ba902b7"+    , spanContextTraceFlags = setSampled True defaultTraceFlags+    , spanContextTraceState = emptyTraceState+    , spanContextIsRemote = True+    }++unsafeHex :: (Text -> Maybe a) -> Text -> a+unsafeHex parse raw = fromMaybe (error "bad fixture id") (parse raw)++captureSpans :: Eff '[Tracer, IOE] a -> IO [Span]+captureSpans program = runEff $ do+  captured <- newCapturedSpans+  _ <- runTracerInMemory captured program+  readCapturedSpans captured++expectSpan :: Text -> [Span] -> IO Span+expectSpan name spans =+  maybe (assertFailure ("expected a span named " <> show name)) pure (findSpan name spans)
+ test/Effectful/Tracing/LogSpec.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.LogSpec+-- Description : Tests for log correlation against the active span.+--+-- The accessors are exercised through the in-memory interpreter, where an active+-- span exists, and compared against the captured span's own context so the+-- correlation is verified to name the right trace and span (not just any+-- well-formed ids). The no-active-span cases assert the clean empty / 'Nothing'+-- result.+module Effectful.Tracing.LogSpec+  ( tests+  ) where++import Effectful (Eff, IOE, runEff)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import Effectful.Tracing (Tracer, withSpan)+import Effectful.Tracing.Internal.Ids (spanIdToHex, traceIdToHex)+import Effectful.Tracing.Internal.Types (Span, SpanContext (..), isSampled, spanContext)+import Effectful.Tracing.Interpreter.InMemory+  ( newCapturedSpans+  , readCapturedSpans+  , runTracerInMemory+  )+import Effectful.Tracing.Log+  ( Correlation (..)+  , activeCorrelation+  , activeCorrelationFields+  , activeSpanId+  , activeTraceId+  , correlationFields+  )++tests :: TestTree+tests =+  testGroup+    "Log"+    [ testCase "active correlation names the active span" $ do+        (correlation, spans) <- run (withSpan "op" activeCorrelation)+        case spans of+          [s] ->+            correlation+              @?= Just+                Correlation+                  { correlationTraceId = traceIdToHex (spanContextTraceId (spanContext s))+                  , correlationSpanId = spanIdToHex (spanContextSpanId (spanContext s))+                  , correlationSampled = isSampled (spanContextTraceFlags (spanContext s))+                  }+          other -> fail ("expected exactly one captured span, got " <> show (length other))+    , testCase "active ids match the correlation" $ do+        ((tid, sid, correlation), _) <-+          run (withSpan "op" ((,,) <$> activeTraceId <*> activeSpanId <*> activeCorrelation))+        tid @?= fmap correlationTraceId correlation+        sid @?= fmap correlationSpanId correlation+    , testCase "nested spans share the trace id but differ in span id" $ do+        ((outer, inner), _) <-+          run $+            withSpan "outer" $ do+              o <- activeCorrelation+              i <- withSpan "inner" activeCorrelation+              pure (o, i)+        fmap correlationTraceId outer @?= fmap correlationTraceId inner+        (fmap correlationSpanId outer == fmap correlationSpanId inner) @?= False+    , testCase "fields use the OpenTelemetry log keys" $ do+        let correlation = Correlation "abc" "def" True+        map fst (correlationFields correlation) @?= ["trace_id", "span_id", "trace_flags"]+        lookup "trace_flags" (correlationFields correlation) @?= Just "01"+    , testCase "unsampled renders trace_flags 00" $+        lookup "trace_flags" (correlationFields (Correlation "abc" "def" False)) @?= Just "00"+    , testCase "no active span yields Nothing" $ do+        (correlation, _) <- run activeCorrelation+        correlation @?= Nothing+    , testCase "no active span yields no fields" $ do+        (fields, _) <- run activeCorrelationFields+        fields @?= []+    ]++-- | Run a 'Tracer' computation through the in-memory interpreter, returning both+-- the computation's result and the captured spans.+run :: Eff '[Tracer, IOE] a -> IO (a, [Span])+run action = runEff $ do+  captured <- newCapturedSpans+  result <- runTracerInMemory captured action+  spans <- readCapturedSpans captured+  pure (result, spans)
+ test/Effectful/Tracing/NoOpSpec.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.NoOpSpec+-- Description : Behavioural tests for the no-op interpreter.+module Effectful.Tracing.NoOpSpec+  ( tests+  ) where++import Control.Exception (ErrorCall (ErrorCall), throwIO, toException, try)+import Control.Monad.IO.Class (liftIO)+import Data.Text (Text)++import Effectful (Eff, IOE, runEff, (:>))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase, (@?=))++import Effectful.Tracing+  ( SpanStatus (Ok)+  , Tracer+  , addAttribute+  , addAttributes+  , addEvent+  , getActiveSpan+  , recordException+  , runTracerNoOp+  , setStatus+  , withSpan+  , (.=)+  )++tests :: TestTree+tests =+  testGroup+    "No-op interpreter"+    [ testCase "nested withSpan returns the inner value" $ do+        result <- runEff (runTracerNoOp nestedValue)+        result @?= 42+    , testCase "exception inside withSpan propagates" $ do+        outcome <- try (runEff (runTracerNoOp throwing))+        case outcome of+          Left (ErrorCall msg) -> msg @?= "boom"+          Right () -> assertBool "expected the exception to propagate" False+    , testCase "emit operations are silent and getActiveSpan is Nothing" $ do+        result <- runEff (runTracerNoOp emitsEverything)+        result @?= 7+    ]++-- | Nested spans thread their inner values through untouched.+nestedValue :: Tracer :> es => Eff es Int+nestedValue = withSpan "outer" $ do+  x <- withSpan "left" (pure 20)+  y <- withSpan "right" (pure 22)+  pure (x + y)++-- | An exception raised inside a span must not be swallowed by the interpreter.+throwing :: (Tracer :> es, IOE :> es) => Eff es ()+throwing = withSpan "outer" $ do+  addAttribute "before.throw" (1 :: Int)+  liftIO (throwIO (ErrorCall "boom"))++-- | Every emit operation runs without effect, and with no active span+-- 'getActiveSpan' is 'Nothing' (so this returns 7, not 0).+emitsEverything :: Tracer :> es => Eff es Int+emitsEverything = do+  addAttribute "user.id" ("u123" :: Text)+  addAttributes ["http.method" .= ("GET" :: Text)]+  addEvent "fetching" []+  setStatus Ok+  recordException (toException (ErrorCall "ignored"))+  maybe 7 (const 0) <$> getActiveSpan
+ test/Effectful/Tracing/OpenTelemetrySpec.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.OpenTelemetrySpec+-- Description : Tests for the OpenTelemetry export interpreter.+--+-- Two angles. 'toImmutableSpan' is tested directly (the translation is the whole+-- contract: our ids, name, kind, status, and attributes must survive the+-- crossing into @hs-opentelemetry@'s representation). And 'runTracerOTel' is+-- tested end to end through a capturing 'SpanProcessor', confirming that a small+-- traced program drives well-formed spans, carrying our ids and parent linkage,+-- all the way to a processor. This is the runnable stand-in for the manual Jaeger+-- smoke test, which needs a live collector.+--+-- The processor is a synchronous one built straight from the @hs-opentelemetry@+-- API: it records each span in 'spanProcessorOnEnd' as the span finishes. The+-- SDK's @simpleProcessor@ exports on a worker thread whose shutdown races an+-- in-flight export, which drops spans nondeterministically; a synchronous+-- processor removes that race while exercising exactly the interface+-- 'runTracerOTel' drives.+module Effectful.Tracing.OpenTelemetrySpec+  ( tests+  ) where++import Control.Concurrent.Async (async)+import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar)+import Data.ByteString (ByteString)+import Data.IORef (readIORef)+import Data.List (find, nub, sort)+import Data.Maybe (isNothing)+import Data.Text qualified as T++import OpenTelemetry.Attributes qualified as OtelAttr+import OpenTelemetry.Processor.Span+  ( ShutdownResult (ShutdownSuccess)+  , SpanProcessor (..)+  )+import OpenTelemetry.Trace.Core qualified as OTel+import OpenTelemetry.Trace.Id qualified as OtelId++import Effectful (Eff, IOE, runEff, (:>))+import Hedgehog (Property, evalEither, evalIO, forAll, property, (===))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))+import Test.Tasty.Hedgehog (testProperty)++import Effectful.Tracing+  ( SpanArguments (kind)+  , Tracer+  , addAttribute+  , defaultSpanArguments+  , withSpan+  , withSpan'+  )+import Effectful.Tracing.Attribute (Attribute (attributeKey))+import Effectful.Tracing.Gen (genSpan)+import Effectful.Tracing.Internal.Ids (SpanId (SpanId), TraceId (TraceId))+import Effectful.Tracing.Internal.Types+  ( Span (..)+  , SpanContext (..)+  , SpanKind (Server)+  , SpanStatus (Error, Ok, Unset)+  )+import Effectful.Tracing.Interpreter.InMemory+  ( newCapturedSpans+  , readCapturedSpans+  , runTracerInMemory+  )+import Effectful.Tracing.Interpreter.OpenTelemetry+  ( OtelConfig (OtelConfig, instrumentationScope, sampler, spanLimits, spanProcessors)+  , runTracerOTel+  , toImmutableSpan+  )+import Effectful.Tracing.Sampler (alwaysOn)+import Effectful.Tracing.SpanLimits (defaultSpanLimits)++tests :: TestTree+tests =+  testGroup+    "OpenTelemetry"+    [ testGroup "toImmutableSpan" translationTests+    , testGroup "toImmutableSpan (property)" translationProperties+    , testGroup "runTracerOTel (end to end)" endToEndTests+    ]++-- A small traced program: a parent span with an attribute, wrapping a child.+program :: Tracer :> es => Eff es ()+program =+  withSpan "parent" $ do+    addAttribute "service.name" ("checkout" :: String)+    withSpan "child" (pure ())++translationTests :: [TestTree]+translationTests =+  [ testCase "preserves ids, name, status, and attributes" $ do+      spans <- runInMemory (withSpan "root" (addAttribute "k" ("v" :: String)))+      tracer <- makeTestTracer+      completed <- single spans+      case toImmutableSpan tracer completed of+        Left err -> fail ("translation failed: " <> err)+        Right immutable -> do+          OTel.spanName immutable @?= "root"+          let TraceId ourTrace = spanContextTraceId (spanContext completed)+              SpanId ourSpan = spanContextSpanId (spanContext completed)+          OtelId.traceIdBytes (OTel.traceId (OTel.spanContext immutable)) @?= ourTrace+          OtelId.spanIdBytes (OTel.spanId (OTel.spanContext immutable)) @?= ourSpan+          OTel.spanStatus immutable @?= OTel.Unset+          OtelAttr.getCount (OTel.spanAttributes immutable) @?= 1+  , testCase "maps span kind" $ do+      spans <- runInMemory (withSpan' "srv" defaultSpanArguments {kind = Server} (pure ()))+      tracer <- makeTestTracer+      completed <- single spans+      case toImmutableSpan tracer completed of+        Left err -> fail err+        Right immutable -> case OTel.spanKind immutable of+          OTel.Server -> pure ()+          other -> assertFailure ("expected Server kind, got " <> show other)+  ]++translationProperties :: [TestTree]+translationProperties =+  [ testProperty "preserves ids, name, kind, status, and attribute count" prop_translationPreserves+  ]++-- | For any generated span, the crossing into @hs-opentelemetry@ must be+-- lossless on the fields that identify and classify the span: our trace and+-- span id bytes, the name, the kind, the status, and the number of distinct+-- attribute keys. (The OTel attribute set is a keyed map, so the count it+-- reports is the number of distinct keys, which is what we compare against.)+prop_translationPreserves :: Property+prop_translationPreserves = property $ do+  completed <- forAll genSpan+  tracer <- evalIO makeTestTracer+  immutable <- evalEither (toImmutableSpan tracer completed)+  let TraceId ourTrace = spanContextTraceId (spanContext completed)+      SpanId ourSpan = spanContextSpanId (spanContext completed)+  OtelId.traceIdBytes (OTel.traceId (OTel.spanContext immutable)) === ourTrace+  OtelId.spanIdBytes (OTel.spanId (OTel.spanContext immutable)) === ourSpan+  OTel.spanName immutable === spanName completed+  -- Our 'SpanKind' and OpenTelemetry's share constructor names, so comparing+  -- their 'Show' output sidesteps the missing 'Eq' on OTel's 'SpanKind'.+  show (OTel.spanKind immutable) === show (spanKind completed)+  OTel.spanStatus immutable === expectedStatus (spanStatus completed)+  OtelAttr.getCount (OTel.spanAttributes immutable)+    === length (nub (map attributeKey (spanAttributes completed)))++-- | The expected OpenTelemetry status for one of ours.+expectedStatus :: SpanStatus -> OTel.SpanStatus+expectedStatus Unset = OTel.Unset+expectedStatus Ok = OTel.Ok+expectedStatus (Error message) = OTel.Error message++endToEndTests :: [TestTree]+endToEndTests =+  [ testCase "drives well-formed spans to a processor, parent linkage intact" $ do+      (processor, captured) <- capturingProcessor+      let config =+            OtelConfig+              { spanProcessors = [processor]+              , instrumentationScope = "effectful-tracing-test"+              , sampler = alwaysOn+              , spanLimits = defaultSpanLimits+              }+      runEff (runTracerOTel config program)+      exported <- readMVar captured++      sort (map (T.unpack . OTel.spanName) exported) @?= ["child", "parent"]+      parentSpan <- requireSpan "parent" exported+      childSpan <- requireSpan "child" exported++      -- Same trace.+      OtelId.traceIdBytes (OTel.traceId (OTel.spanContext childSpan))+        @?= OtelId.traceIdBytes (OTel.traceId (OTel.spanContext parentSpan))+      -- The child's parent is the parent span.+      childParent <- parentSpanId childSpan+      childParent @?= Just (OtelId.spanIdBytes (OTel.spanId (OTel.spanContext parentSpan)))+      -- The parent is a root (no parent of its own).+      assertBool "parent span is a root" (isNothing (OTel.spanParent parentSpan))+  ]++-- | A synchronous 'SpanProcessor' that records every span it sees in+-- 'spanProcessorOnEnd' into an 'MVar', in finish order.+capturingProcessor :: IO (SpanProcessor, MVar [OTel.ImmutableSpan])+capturingProcessor = do+  captured <- newMVar []+  let processor =+        SpanProcessor+          { spanProcessorOnStart = \_ _ -> pure ()+          , spanProcessorOnEnd = \ref -> do+              immutable <- readIORef ref+              modifyMVar_ captured (\acc -> pure (acc <> [immutable]))+          , spanProcessorShutdown = async (pure ShutdownSuccess)+          , spanProcessorForceFlush = pure ()+          }+  pure (processor, captured)++-- | The OTel span id of an immutable span's parent, if any.+parentSpanId :: OTel.ImmutableSpan -> IO (Maybe ByteString)+parentSpanId immutable =+  case OTel.spanParent immutable of+    Nothing -> pure Nothing+    Just p -> do+      context <- OTel.getSpanContext p+      pure (Just (OtelId.spanIdBytes (OTel.spanId context)))++requireSpan :: String -> [OTel.ImmutableSpan] -> IO OTel.ImmutableSpan+requireSpan name spans =+  maybe (fail ("no span named " <> name)) pure (find ((== name) . T.unpack . OTel.spanName) spans)++-- | Build an OTel tracer with no processors, just to satisfy translation.+makeTestTracer :: IO OTel.Tracer+makeTestTracer = do+  provider <- OTel.createTracerProvider [] OTel.emptyTracerProviderOptions+  pure (OTel.makeTracer provider "effectful-tracing-test" OTel.tracerOptions)++single :: [a] -> IO a+single [x] = pure x+single other = fail ("expected exactly one span, got " <> show (length other))++runInMemory :: Eff '[Tracer, IOE] a -> IO [Span]+runInMemory action = runEff $ do+  captured <- newCapturedSpans+  _ <- runTracerInMemory captured action+  readCapturedSpans captured
+ test/Effectful/Tracing/PrettyPrintLeakSpec.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.PrettyPrintLeakSpec+-- Description : The pretty-print interpreter's in-flight buffer drains to empty.+--+-- The pretty-print interpreter buffers the spans of each in-flight trace in a+-- @'TVar' ('Map' 'TraceId' ['Span'])@ and flushes a trace (rendering it and+-- deleting its entry) the moment its root span closes. If a finished trace were+-- ever left behind, that map would grow without bound over the lifetime of a+-- long-running process: a slow memory leak.+--+-- This test drives a program through the buffer-observing seam+-- ('runTracerPrettyWith') and checks two things: while a root span is still open+-- its already-closed children are held in the buffer (so the buffering is real,+-- not a no-op), and once every root has closed the buffer is empty again (so+-- nothing is retained). It also confirms every trace was actually rendered.+module Effectful.Tracing.PrettyPrintLeakSpec+  ( tests+  ) where++import Control.Concurrent.STM (TVar, newTVarIO, readTVarIO)+import Control.Monad.IO.Class (liftIO)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Text qualified as T+import Data.Text.Encoding qualified as TE+import Data.ByteString.Lazy qualified as BL++import System.IO (hClose)+import System.IO.Temp (withSystemTempFile)++import Effectful (Eff, IOE, runEff)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import Effectful.Tracing (Tracer, withSpan)+import Effectful.Tracing.Internal.Ids (TraceId)+import Effectful.Tracing.Internal.Types (Span)+import Effectful.Tracing.Interpreter.PrettyPrint+  ( defaultPrettyPrintConfig+  , runTracerPrettyWith+  )++tests :: TestTree+tests =+  testGroup+    "Pretty-print interpreter buffer"+    [ testCase "the in-flight buffer accumulates and then drains to empty" $ do+        (mid, finalSize, headerCount) <- runWithBuffer+        -- While "root-1" is open, its two already-closed children are buffered+        -- under one trace id, so the buffer holds one trace of two spans.+        mid @?= (1, 2)+        -- Once every root has closed, the buffer retains nothing.+        finalSize @?= 0+        -- All three independent root traces were flushed (rendered) exactly once.+        headerCount @?= 3+    ]++-- | Run a program with three independent root traces through the+-- buffer-observing interpreter seam, returning: the buffer snapshot taken while+-- the first root is still open (number of in-flight traces, total spans+-- buffered across them), the buffer size after the whole program finishes, and+-- the number of rendered trace headers in the output.+runWithBuffer :: IO ((Int, Int), Int, Int)+runWithBuffer =+  withSystemTempFile "pretty-leak.txt" $ \path h -> do+    traces <- newTVarIO Map.empty+    mid <- runEff (runTracerPrettyWith traces (defaultPrettyPrintConfig h) (program traces))+    finalSize <- Map.size <$> readTVarIO traces+    hClose h+    rendered <- TE.decodeUtf8 . BL.toStrict <$> BL.readFile path+    let headerCount = length (filter ("trace " `T.isPrefixOf`) (T.lines rendered))+    pure (mid, finalSize, headerCount)++-- | Three root traces. The first opens two children that close (and so are+-- buffered) before the root does; in that window we snapshot the buffer. The+-- next two roots simply exercise another insert/delete cycle each.+program :: TVar (Map TraceId [Span]) -> Eff '[Tracer, IOE] (Int, Int)+program traces = do+  mid <- withSpan "root-1" $ do+    withSpan "child-a" (pure ())+    withSpan "child-b" (pure ())+    -- Both children have closed and been buffered under root-1's trace id;+    -- root-1 is still open, so nothing has been flushed. Snapshot the buffer.+    snapshot <- liftIO (readTVarIO traces)+    pure (Map.size snapshot, sum (map length (Map.elems snapshot)))+  withSpan "root-2" (withSpan "only-child" (pure ()))+  withSpan "root-3" (pure ())+  pure mid
+ test/Effectful/Tracing/PrettyPrintSpec.hs view
@@ -0,0 +1,218 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.PrettyPrintSpec+-- Description : Golden and behavioural tests for the pretty-print interpreter.+--+-- The pure renderer ('renderTrace') is pinned with golden files built from+-- fixed spans, so the layout is locked without depending on real clocks or+-- random ids. A separate end-to-end test runs a real program through+-- 'runTracerPretty' and checks the structural properties that survive+-- nondeterministic timing and id generation.+module Effectful.Tracing.PrettyPrintSpec+  ( tests+  ) where++import Data.ByteString.Lazy qualified as BL+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as TE+import Data.Time.Calendar (fromGregorian)+import Data.Time.Clock (UTCTime (UTCTime), addUTCTime, secondsToDiffTime)++import System.IO (hClose, stderr)+import System.IO.Temp (withSystemTempFile)++import Effectful (Eff, IOE, runEff)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Golden (goldenVsString)+import Test.Tasty.HUnit (assertBool, testCase, (@?=))++import Effectful.Tracing (Tracer, addAttribute, withSpan)+import Effectful.Tracing.Attribute (Attribute, (.=))+import Effectful.Tracing.Internal.Clock (Timestamp (Timestamp))+import Effectful.Tracing.Internal.Ids (SpanId, TraceId, spanIdFromHex, traceIdFromHex)+import Effectful.Tracing.Internal.Types+  ( Event (Event)+  , Span (..)+  , SpanContext (..)+  , SpanKind (Client, Internal, Server)+  , SpanStatus (Error, Ok)+  , defaultTraceFlags+  , emptyTraceState+  )+import Effectful.Tracing.Interpreter.PrettyPrint+  ( PrettyPrintConfig (showAttributes, showEvents, timeFormat, useColor)+  , TimeFormat (RelativeToTraceStart)+  , defaultPrettyPrintConfig+  , renderTrace+  , runTracerPretty+  )++tests :: TestTree+tests =+  testGroup+    "Pretty-print interpreter"+    [ testGroup+        "renderTrace golden"+        [ golden "nested" "nested" (renderTrace plainConfig exampleTrace)+        , golden "colored" "colored" (renderTrace plainConfig {useColor = True} exampleTrace)+        , golden+            "relative-no-details"+            "relative-no-details"+            ( renderTrace+                plainConfig {timeFormat = RelativeToTraceStart, showAttributes = False, showEvents = False}+                exampleTrace+            )+        , golden "error" "error" (renderTrace plainConfig errorTrace)+        ]+    , testGroup+        "renderTrace structure"+        [ testCase "an empty trace renders nothing" $+            renderTrace plainConfig [] @?= ""+        , testCase "siblings are ordered by start time, not list order" $ do+            -- feed the spans in reverse; rendering must reorder by start time+            let rendered = renderTrace plainConfig {showAttributes = False, showEvents = False} (reverse exampleTrace)+            spanLineNames rendered @?= ["handle_request", "authenticate", "load_user", "db.query", "render"]+        ]+    , testCase "runTracerPretty writes one trace header with every span name" $ do+        rendered <- renderViaInterpreter+        let headers = filter ("trace " `T.isPrefixOf`) (T.lines rendered)+        length headers @?= 1+        mapM_+          (\name -> assertBool (T.unpack name <> " appears in output") (name `T.isInfixOf` rendered))+          ["root", "first-child", "grandchild", "second-child"]+    ]++-- Config --------------------------------------------------------------------++-- | A config for the pure renderer. The handle is never touched by+-- 'renderTrace'; 'stderr' just fills the field.+plainConfig :: PrettyPrintConfig+plainConfig = defaultPrettyPrintConfig stderr++-- Fixtures ------------------------------------------------------------------++-- | The trace from the build-plan example: a server span with an attribute and+-- three children, one of which has a client child carrying an attribute and an+-- event. All statuses are @Ok@.+exampleTrace :: [Span]+exampleTrace =+  [ mkSpan s1 Nothing "handle_request" Server 0 78 ["user.id" .= ("u123" :: Text)] [] Ok+  , mkSpan s2 (Just s1) "authenticate" Internal 2 14 [] [] Ok+  , mkSpan s3 (Just s1) "load_user" Internal 16 24 [] [] Ok+  , mkSpan+      s4+      (Just s3)+      "db.query"+      Client+      17+      23+      ["db.system" .= ("postgresql" :: Text)]+      [Event "query.started" (millis 17.1) []]+      Ok+  , mkSpan s5 (Just s1) "render" Internal 24 78 [] [] Ok+  ]++-- | A single span that failed: @Error@ status and an exception event.+errorTrace :: [Span]+errorTrace =+  [ mkSpan+      s1+      Nothing+      "checkout"+      Server+      0+      40+      ["cart.size" .= (3 :: Int)]+      [Event "exception" (millis 39) []]+      (Error "payment declined")+  ]++mkSpan+  :: SpanId+  -> Maybe SpanId+  -> Text+  -> SpanKind+  -> Double+  -> Double+  -> [Attribute]+  -> [Event]+  -> SpanStatus+  -> Span+mkSpan spanId parent name kind startMs endMs attrs events status =+  Span+    { spanContext = context spanId+    , spanParentContext = context <$> parent+    , spanName = name+    , spanKind = kind+    , spanStartTime = millis startMs+    , spanEndTime = millis endMs+    , spanAttributes = attrs+    , spanEvents = events+    , spanLinks = []+    , spanStatus = status+    }++context :: SpanId -> SpanContext+context spanId =+  SpanContext+    { spanContextTraceId = traceId+    , spanContextSpanId = spanId+    , spanContextTraceFlags = defaultTraceFlags+    , spanContextTraceState = emptyTraceState+    , spanContextIsRemote = False+    }++traceId :: TraceId+traceId = unsafeFromHex traceIdFromHex "4f1a9c000000000000000000000000aa"++s1, s2, s3, s4, s5 :: SpanId+s1 = unsafeFromHex spanIdFromHex "0000000000000001"+s2 = unsafeFromHex spanIdFromHex "0000000000000002"+s3 = unsafeFromHex spanIdFromHex "0000000000000003"+s4 = unsafeFromHex spanIdFromHex "0000000000000004"+s5 = unsafeFromHex spanIdFromHex "0000000000000005"++unsafeFromHex :: (Text -> Maybe a) -> Text -> a+unsafeFromHex parse hex = fromMaybe (error ("bad fixture id: " <> T.unpack hex)) (parse hex)++-- | A timestamp the given number of milliseconds after a fixed epoch.+millis :: Double -> Timestamp+millis ms = Timestamp (addUTCTime (realToFrac (ms / 1000)) epoch)+  where+    epoch = UTCTime (fromGregorian 2026 1 1) (secondsToDiffTime 0)++-- Golden helper -------------------------------------------------------------++golden :: String -> FilePath -> Text -> TestTree+golden name file rendered =+  goldenVsString name ("test/golden/" <> file <> ".txt") (pure (BL.fromStrict (TE.encodeUtf8 rendered)))++-- | The span name from each label line (a line containing a tree connector),+-- stripped of the tree-drawing prefix and everything from the first space on.+spanLineNames :: Text -> [Text]+spanLineNames =+  map (T.takeWhile (/= ' ') . T.dropWhile (`elem` treeChars))+    . filter (T.any (`elem` connectors))+    . T.lines+  where+    treeChars = " \x2502\x251C\x2514\x2500" :: String+    connectors = "\x251C\x2514" :: String++-- End-to-end ----------------------------------------------------------------++tracedProgram :: Eff '[Tracer, IOE] ()+tracedProgram = withSpan "root" $ do+  addAttribute "k" ("v" :: Text)+  withSpan "first-child" (withSpan "grandchild" (pure ()))+  withSpan "second-child" (pure ())++renderViaInterpreter :: IO Text+renderViaInterpreter =+  withSystemTempFile "pretty-trace.txt" $ \path h -> do+    runEff (runTracerPretty (defaultPrettyPrintConfig h) tracedProgram)+    hClose h+    TE.decodeUtf8 . BL.toStrict <$> BL.readFile path
+ test/Effectful/Tracing/Propagation/B3Spec.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.Propagation.B3Spec+-- Description : Tests for B3 (Zipkin) propagation.+--+-- 'extractContextB3' is exercised directly with single-header and multi-header+-- B3 test vectors (the parse is the whole contract for inbound requests), and+-- the injectors are exercised through the in-memory interpreter, where an+-- active span exists. Round-trip tests confirm inject-then-extract preserves the+-- trace and span ids and the sampled flag in both wire encodings.+module Effectful.Tracing.Propagation.B3Spec+  ( tests+  ) where++import Data.ByteString (ByteString)+import Data.Maybe (isJust)++import Effectful (Eff, IOE, runEff)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase, (@?=))++import Effectful.Tracing (Tracer, withSpan)+import Effectful.Tracing.Internal.Ids (spanIdToHex, traceIdToHex)+import Effectful.Tracing.Internal.Types (SpanContext (..), isSampled)+import Effectful.Tracing.Interpreter.InMemory+  ( newCapturedSpans+  , runTracerInMemory+  )+import Effectful.Tracing.Propagation.B3+  ( b3FlagsHeader+  , b3Header+  , b3SampledHeader+  , b3SpanIdHeader+  , b3TraceIdHeader+  , extractContextB3+  , injectContextB3+  , injectContextB3Multi+  )++tests :: TestTree+tests =+  testGroup+    "Propagation.B3"+    [ testGroup "extractContextB3 (single header)" singleVectors+    , testGroup "extractContextB3 (multi header)" multiVectors+    , testGroup "inject" injectTests+    , testGroup "round-trip" roundTripTests+    ]++traceId128 :: ByteString+traceId128 = "4bf92f3577b34da6a3ce929d0e0e4736"++spanId :: ByteString+spanId = "00f067aa0ba902b7"++singleVectors :: [TestTree]+singleVectors =+  [ testCase "parses a 128-bit single header with sampling" $ do+      let context = extractContextB3 [(b3Header, traceId128 <> "-" <> spanId <> "-1")]+      fmap (traceIdToHex . spanContextTraceId) context @?= Just "4bf92f3577b34da6a3ce929d0e0e4736"+      fmap (spanIdToHex . spanContextSpanId) context @?= Just "00f067aa0ba902b7"+      fmap (isSampled . spanContextTraceFlags) context @?= Just True+      fmap spanContextIsRemote context @?= Just True+  , testCase "left-pads a 64-bit trace id to 128 bits" $ do+      let context = extractContextB3 [(b3Header, "a3ce929d0e0e4736-" <> spanId <> "-1")]+      fmap (traceIdToHex . spanContextTraceId) context+        @?= Just "0000000000000000a3ce929d0e0e4736"+  , testCase "deny sampling (0) parses as not sampled" $ do+      let context = extractContextB3 [(b3Header, traceId128 <> "-" <> spanId <> "-0")]+      fmap (isSampled . spanContextTraceFlags) context @?= Just False+  , testCase "debug (d) parses as sampled" $ do+      let context = extractContextB3 [(b3Header, traceId128 <> "-" <> spanId <> "-d")]+      fmap (isSampled . spanContextTraceFlags) context @?= Just True+  , testCase "absent sampling field defers to unsampled" $ do+      let context = extractContextB3 [(b3Header, traceId128 <> "-" <> spanId)]+      fmap (isSampled . spanContextTraceFlags) context @?= Just False+  , testCase "a trailing parent span id is accepted and ignored" $ do+      let context =+            extractContextB3+              [(b3Header, traceId128 <> "-" <> spanId <> "-1-05e3ac9a4f6e3b90")]+      fmap (spanIdToHex . spanContextSpanId) context @?= Just "00f067aa0ba902b7"+  , testCase "the deny-only single value (0) yields Nothing" $+      extractContextB3 [(b3Header, "0")] @?= Nothing+  , testCase "an all-zero trace id is rejected" $+      extractContextB3 [(b3Header, "00000000000000000000000000000000-" <> spanId <> "-1")]+        @?= Nothing+  , testCase "a non-hex span id is rejected" $+      extractContextB3 [(b3Header, traceId128 <> "-zzzzzzzzzzzzzzzz-1")] @?= Nothing+  , testCase "absent headers yield Nothing" $+      extractContextB3 [] @?= Nothing+  , testCase "the b3 header lookup is case-insensitive" $ do+      let context = extractContextB3 [("B3", traceId128 <> "-" <> spanId <> "-1")]+      fmap (spanIdToHex . spanContextSpanId) context @?= Just "00f067aa0ba902b7"+  ]++multiVectors :: [TestTree]+multiVectors =+  [ testCase "parses the multi-header form with X-B3-Sampled" $ do+      let context =+            extractContextB3+              [ (b3TraceIdHeader, traceId128)+              , (b3SpanIdHeader, spanId)+              , (b3SampledHeader, "1")+              ]+      fmap (traceIdToHex . spanContextTraceId) context @?= Just "4bf92f3577b34da6a3ce929d0e0e4736"+      fmap (isSampled . spanContextTraceFlags) context @?= Just True+      fmap spanContextIsRemote context @?= Just True+  , testCase "X-B3-Flags: 1 (debug) implies sampled" $ do+      let context =+            extractContextB3+              [ (b3TraceIdHeader, traceId128)+              , (b3SpanIdHeader, spanId)+              , (b3FlagsHeader, "1")+              ]+      fmap (isSampled . spanContextTraceFlags) context @?= Just True+  , testCase "X-B3-Sampled: 0 parses as not sampled" $ do+      let context =+            extractContextB3+              [ (b3TraceIdHeader, traceId128)+              , (b3SpanIdHeader, spanId)+              , (b3SampledHeader, "0")+              ]+      fmap (isSampled . spanContextTraceFlags) context @?= Just False+  , testCase "missing X-B3-SpanId yields Nothing" $+      extractContextB3 [(b3TraceIdHeader, traceId128)] @?= Nothing+  , testCase "the single header is preferred when both forms are present" $ do+      -- The single header carries the real ids; the multi headers are decoys.+      let context =+            extractContextB3+              [ (b3Header, traceId128 <> "-" <> spanId <> "-1")+              , (b3TraceIdHeader, "00000000000000000000000000000000")+              , (b3SpanIdHeader, "0000000000000000")+              ]+      fmap (traceIdToHex . spanContextTraceId) context @?= Just "4bf92f3577b34da6a3ce929d0e0e4736"+  ]++injectTests :: [TestTree]+injectTests =+  [ testCase "emits a single b3 header for the active span" $ do+      headers <- run (withSpan "outbound" injectContextB3)+      assertBool "a b3 header is present" (b3Header `elem` map fst headers)+  , testCase "emits multi headers for the active span" $ do+      headers <- run (withSpan "outbound" injectContextB3Multi)+      let names = map fst headers+      assertBool "X-B3-TraceId present" (b3TraceIdHeader `elem` names)+      assertBool "X-B3-SpanId present" (b3SpanIdHeader `elem` names)+      assertBool "X-B3-Sampled present" (b3SampledHeader `elem` names)+  , testCase "emits no single header when there is no active span" $ do+      headers <- run injectContextB3+      headers @?= []+  , testCase "emits no multi headers when there is no active span" $ do+      headers <- run injectContextB3Multi+      headers @?= []+  ]++roundTripTests :: [TestTree]+roundTripTests =+  [ testCase "single-header inject then extract preserves ids and sampled flag" $ do+      headers <- run (withSpan "outbound" injectContextB3)+      let extracted = extractContextB3 headers+      assertBool "round-trips to a context" (isJust extracted)+      fmap (isSampled . spanContextTraceFlags) extracted @?= Just True+      fmap spanContextIsRemote extracted @?= Just True+  , testCase "multi-header inject then extract preserves ids and sampled flag" $ do+      headers <- run (withSpan "outbound" injectContextB3Multi)+      let extracted = extractContextB3 headers+      assertBool "round-trips to a context" (isJust extracted)+      fmap (isSampled . spanContextTraceFlags) extracted @?= Just True+      fmap spanContextIsRemote extracted @?= Just True+  ]++-- | Run a 'Tracer' computation through the in-memory interpreter, discarding the+-- captured spans and returning the computation's result.+run :: Eff '[Tracer, IOE] a -> IO a+run action = runEff $ do+  captured <- newCapturedSpans+  runTracerInMemory captured action
+ test/Effectful/Tracing/Propagation/CompositeSpec.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.Propagation.CompositeSpec+-- Description : Tests for combining propagators.+--+-- The combinators are exercised end to end: 'injectContextAll' and+-- 'injectBaggageAll' through the in-memory interpreter (where an active span and+-- ambient baggage exist), and 'extractContextFirst' \/ 'extractBaggageAll' with+-- crafted header vectors. The order-sensitive cases pin down the contract that+-- matters for a composite: inject writes every format, extract takes the first+-- matching context but merges all baggage, and the @OTEL_PROPAGATORS@ token+-- lookups resolve the standard names.+module Effectful.Tracing.Propagation.CompositeSpec+  ( tests+  ) where++import Data.ByteString (ByteString)++import Effectful (Eff, IOE, runEff, runPureEff)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase, (@?=))++import Effectful.Tracing (Tracer, withSpan)+import Effectful.Tracing.Baggage+  ( lookupBaggageValue+  , runBaggage+  , withBaggageEntry+  )+import Effectful.Tracing.Internal.Ids (traceIdToHex)+import Effectful.Tracing.Internal.Types (SpanContext (..))+import Effectful.Tracing.Interpreter.InMemory+  ( newCapturedSpans+  , runTracerInMemory+  )+import Effectful.Tracing.Propagation (traceparentHeader)+import Effectful.Tracing.Propagation.B3 (b3Header)+import Effectful.Tracing.Propagation.Baggage (baggageHeader)+import Effectful.Tracing.Propagation.Composite+  ( baggageByToken+  , baggageName+  , b3Multi+  , b3Single+  , extractBaggageAll+  , extractContextFirst+  , injectBaggageAll+  , injectContextAll+  , jaegerBaggage+  , jaegerTraceContext+  , traceContextByToken+  , traceContextName+  , w3cBaggage+  , w3cTraceContext+  )++tests :: TestTree+tests =+  testGroup+    "Propagation.Composite"+    [ testGroup "injectContextAll" injectContextTests+    , testGroup "extractContextFirst" extractContextTests+    , testGroup "injectBaggageAll" injectBaggageTests+    , testGroup "extractBaggageAll" extractBaggageTests+    , testGroup "token lookup" tokenTests+    ]++-- A pair of distinct trace ids so the "first wins" extract test can tell which+-- propagator produced the context.+traceIdA :: ByteString+traceIdA = "4bf92f3577b34da6a3ce929d0e0e4736"++traceIdB :: ByteString+traceIdB = "0af7651916cd43dd8448eb211c80319c"++spanIdA :: ByteString+spanIdA = "00f067aa0ba902b7"++injectContextTests :: [TestTree]+injectContextTests =+  [ testCase "writes every configured format for the active span" $ do+      headers <- run (withSpan "outbound" (injectContextAll [w3cTraceContext, b3Single]))+      let names = map fst headers+      assertBool "traceparent present" (traceparentHeader `elem` names)+      assertBool "b3 present" (b3Header `elem` names)+  , testCase "an empty propagator list emits no headers" $ do+      headers <- run (withSpan "outbound" (injectContextAll []))+      headers @?= []+  , testCase "emits no headers when there is no active span" $ do+      headers <- run (injectContextAll [w3cTraceContext, b3Single])+      headers @?= []+  ]++extractContextTests :: [TestTree]+extractContextTests =+  [ testCase "takes the first propagator that parses" $ do+      -- Only a b3 header is present; W3C is tried first and misses, B3 matches.+      let headers = [(b3Header, traceIdB <> "-" <> spanIdA <> "-1")]+          context = extractContextFirst [w3cTraceContext, b3Single] headers+      fmap (traceIdToHex . spanContextTraceId) context @?= Just "0af7651916cd43dd8448eb211c80319c"+  , testCase "order decides the winner when several formats are present" $ do+      -- traceparent carries traceIdA, b3 carries traceIdB; W3C is listed first.+      let headers =+            [ (traceparentHeader, "00-" <> traceIdA <> "-" <> spanIdA <> "-01")+            , (b3Header, traceIdB <> "-" <> spanIdA <> "-1")+            ]+          context = extractContextFirst [w3cTraceContext, b3Single] headers+      fmap (traceIdToHex . spanContextTraceId) context @?= Just "4bf92f3577b34da6a3ce929d0e0e4736"+  , testCase "reordering the list reverses the winner" $ do+      let headers =+            [ (traceparentHeader, "00-" <> traceIdA <> "-" <> spanIdA <> "-01")+            , (b3Header, traceIdB <> "-" <> spanIdA <> "-1")+            ]+          context = extractContextFirst [b3Single, w3cTraceContext] headers+      fmap (traceIdToHex . spanContextTraceId) context @?= Just "0af7651916cd43dd8448eb211c80319c"+  , testCase "an empty propagator list never matches" $+      extractContextFirst [] [(b3Header, traceIdB <> "-" <> spanIdA <> "-1")] @?= Nothing+  , testCase "no matching headers yield Nothing" $+      extractContextFirst [w3cTraceContext, b3Single, jaegerTraceContext] [] @?= Nothing+  ]++injectBaggageTests :: [TestTree]+injectBaggageTests =+  [ testCase "writes every configured baggage format" $ do+      let headers =+            runPureEff (runBaggage (withBaggageEntry "tenant" "acme" (injectBaggageAll [w3cBaggage, jaegerBaggage])))+          names = map fst headers+      assertBool "W3C baggage header present" (baggageHeader `elem` names)+      assertBool "uberctx- header present" ("uberctx-tenant" `elem` names)+  , testCase "an empty propagator list emits no headers" $ do+      let headers = runPureEff (runBaggage (withBaggageEntry "tenant" "acme" (injectBaggageAll [])))+      headers @?= []+  ]++extractBaggageTests :: [TestTree]+extractBaggageTests =+  [ testCase "merges entries from every format" $ do+      let headers =+            [ (baggageHeader, "fromw3c=1")+            , ("uberctx-fromjaeger", "2")+            ]+          merged = extractBaggageAll [w3cBaggage, jaegerBaggage] headers+      lookupBaggageValue "fromw3c" merged @?= Just "1"+      lookupBaggageValue "fromjaeger" merged @?= Just "2"+  , testCase "a later propagator wins on a shared key" $ do+      let headers =+            [ (baggageHeader, "shared=w3c")+            , ("uberctx-shared", "jaeger")+            ]+          merged = extractBaggageAll [w3cBaggage, jaegerBaggage] headers+      lookupBaggageValue "shared" merged @?= Just "jaeger"+  ]++tokenTests :: [TestTree]+tokenTests =+  [ testCase "trace-context tokens resolve to their propagators" $ do+      fmap traceContextName (traceContextByToken "tracecontext") @?= Just "tracecontext"+      fmap traceContextName (traceContextByToken "b3") @?= Just "b3"+      fmap traceContextName (traceContextByToken "b3multi") @?= Just "b3multi"+      fmap traceContextName (traceContextByToken "jaeger") @?= Just "jaeger"+  , testCase "an unknown or baggage-only token has no trace-context side" $ do+      fmap traceContextName (traceContextByToken "baggage") @?= Nothing+      fmap traceContextName (traceContextByToken "nonsense") @?= Nothing+  , testCase "baggage tokens resolve to their propagators" $ do+      fmap baggageName (baggageByToken "baggage") @?= Just "baggage"+      fmap baggageName (baggageByToken "jaeger") @?= Just "jaeger"+  , testCase "a trace-context-only token has no baggage side" $+      fmap baggageName (baggageByToken "b3") @?= Nothing+  , testCase "the standard values carry their expected tokens" $ do+      traceContextName w3cTraceContext @?= "tracecontext"+      traceContextName b3Single @?= "b3"+      traceContextName b3Multi @?= "b3multi"+      traceContextName jaegerTraceContext @?= "jaeger"+      baggageName w3cBaggage @?= "baggage"+      baggageName jaegerBaggage @?= "jaeger"+  ]++-- | Run a 'Tracer' computation through the in-memory interpreter, discarding the+-- captured spans and returning the computation's result.+run :: Eff '[Tracer, IOE] a -> IO a+run action = runEff $ do+  captured <- newCapturedSpans+  runTracerInMemory captured action
+ test/Effectful/Tracing/Propagation/JaegerSpec.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.Propagation.JaegerSpec+-- Description : Tests for Jaeger (uber-trace-id) propagation.+--+-- 'extractContextJaeger' is exercised directly with @uber-trace-id@ test vectors+-- (the parse is the whole contract for inbound requests), the injectors are+-- exercised through the in-memory interpreter and the baggage interpreter where+-- the ambient context exists, and round-trip tests confirm inject-then-extract+-- preserves the trace and span ids, the sampled flag, and the baggage entries.+module Effectful.Tracing.Propagation.JaegerSpec+  ( tests+  ) where++import Data.ByteString (ByteString)+import Data.Maybe (isJust)++import Effectful (Eff, IOE, runEff, runPureEff)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase, (@?=))++import Effectful.Tracing (Tracer, withSpan)+import Effectful.Tracing.Baggage+  ( lookupBaggageValue+  , nullBaggage+  , runBaggage+  , withBaggageEntry+  )+import Effectful.Tracing.Internal.Ids (spanIdToHex, traceIdToHex)+import Effectful.Tracing.Internal.Types (SpanContext (..), isSampled)+import Effectful.Tracing.Interpreter.InMemory+  ( newCapturedSpans+  , runTracerInMemory+  )+import Effectful.Tracing.Propagation.Jaeger+  ( extractBaggageJaeger+  , extractContextJaeger+  , injectBaggageJaeger+  , injectContextJaeger+  , uberTraceIdHeader+  )++tests :: TestTree+tests =+  testGroup+    "Propagation.Jaeger"+    [ testGroup "extractContextJaeger" extractVectors+    , testGroup "inject" injectTests+    , testGroup "extractBaggageJaeger" baggageVectors+    , testGroup "round-trip" roundTripTests+    ]++traceId128 :: ByteString+traceId128 = "4bf92f3577b34da6a3ce929d0e0e4736"++spanId :: ByteString+spanId = "00f067aa0ba902b7"++extractVectors :: [TestTree]+extractVectors =+  [ testCase "parses a 128-bit uber-trace-id with sampling" $ do+      let context = extractContextJaeger [(uberTraceIdHeader, traceId128 <> ":" <> spanId <> ":0:1")]+      fmap (traceIdToHex . spanContextTraceId) context @?= Just "4bf92f3577b34da6a3ce929d0e0e4736"+      fmap (spanIdToHex . spanContextSpanId) context @?= Just "00f067aa0ba902b7"+      fmap (isSampled . spanContextTraceFlags) context @?= Just True+      fmap spanContextIsRemote context @?= Just True+  , testCase "left-pads leading-zero-stripped ids back to full width" $ do+      let context = extractContextJaeger [(uberTraceIdHeader, "a3ce929d0e0e4736:f067aa0ba902b7:0:1")]+      fmap (traceIdToHex . spanContextTraceId) context+        @?= Just "0000000000000000a3ce929d0e0e4736"+      fmap (spanIdToHex . spanContextSpanId) context @?= Just "00f067aa0ba902b7"+  , testCase "flags low bit clear parses as not sampled" $ do+      let context = extractContextJaeger [(uberTraceIdHeader, traceId128 <> ":" <> spanId <> ":0:0")]+      fmap (isSampled . spanContextTraceFlags) context @?= Just False+  , testCase "debug flag (3) still reads the sampled low bit" $ do+      let context = extractContextJaeger [(uberTraceIdHeader, traceId128 <> ":" <> spanId <> ":0:3")]+      fmap (isSampled . spanContextTraceFlags) context @?= Just True+  , testCase "fewer than four fields yields Nothing" $+      extractContextJaeger [(uberTraceIdHeader, traceId128 <> ":" <> spanId <> ":1")] @?= Nothing+  , testCase "an all-zero trace id is rejected" $+      extractContextJaeger [(uberTraceIdHeader, "0:" <> spanId <> ":0:1")] @?= Nothing+  , testCase "a non-hex flags field is rejected" $+      extractContextJaeger [(uberTraceIdHeader, traceId128 <> ":" <> spanId <> ":0:z")] @?= Nothing+  , testCase "absent header yields Nothing" $+      extractContextJaeger [] @?= Nothing+  , testCase "the header lookup is case-insensitive" $ do+      let context = extractContextJaeger [("Uber-Trace-Id", traceId128 <> ":" <> spanId <> ":0:1")]+      fmap (spanIdToHex . spanContextSpanId) context @?= Just "00f067aa0ba902b7"+  ]++injectTests :: [TestTree]+injectTests =+  [ testCase "emits an uber-trace-id header for the active span" $ do+      headers <- run (withSpan "outbound" injectContextJaeger)+      assertBool "an uber-trace-id header is present" (uberTraceIdHeader `elem` map fst headers)+  , testCase "emits no header when there is no active span" $ do+      headers <- run injectContextJaeger+      headers @?= []+  , testCase "emits uberctx- headers for the ambient baggage" $ do+      let headers = runPureEff (runBaggage (withBaggageEntry "tenant" "acme" injectBaggageJaeger))+      headers @?= [("uberctx-tenant", "acme")]+  , testCase "emits no baggage headers when the baggage is empty" $ do+      let headers = runPureEff (runBaggage injectBaggageJaeger)+      headers @?= []+  ]++baggageVectors :: [TestTree]+baggageVectors =+  [ testCase "reads a uberctx- header" $+      lookupBaggageValue "tenant" (extractBaggageJaeger [("uberctx-tenant", "acme")]) @?= Just "acme"+  , testCase "the prefix match is case-insensitive" $+      lookupBaggageValue "tenant" (extractBaggageJaeger [("Uberctx-tenant", "acme")]) @?= Just "acme"+  , testCase "trims surrounding whitespace" $+      lookupBaggageValue "tenant" (extractBaggageJaeger [("uberctx-tenant", " acme ")]) @?= Just "acme"+  , testCase "ignores non-uberctx headers" $+      nullBaggage (extractBaggageJaeger [("x-other", "v")]) @?= True+  , testCase "skips an empty key" $+      nullBaggage (extractBaggageJaeger [("uberctx-", "v")]) @?= True+  ]++roundTripTests :: [TestTree]+roundTripTests =+  [ testCase "context inject then extract preserves ids and sampled flag" $ do+      headers <- run (withSpan "outbound" injectContextJaeger)+      let extracted = extractContextJaeger headers+      assertBool "round-trips to a context" (isJust extracted)+      fmap (isSampled . spanContextTraceFlags) extracted @?= Just True+      fmap spanContextIsRemote extracted @?= Just True+  , testCase "baggage inject then extract preserves entries" $ do+      let headers = runPureEff (runBaggage (withBaggageEntry "tenant" "acme" injectBaggageJaeger))+      lookupBaggageValue "tenant" (extractBaggageJaeger headers) @?= Just "acme"+  ]++-- | Run a 'Tracer' computation through the in-memory interpreter, discarding the+-- captured spans and returning the computation's result.+run :: Eff '[Tracer, IOE] a -> IO a+run action = runEff $ do+  captured <- newCapturedSpans+  runTracerInMemory captured action
+ test/Effectful/Tracing/PropagationSpec.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.PropagationSpec+-- Description : Tests for W3C Trace Context propagation.+--+-- 'extractContext' is exercised directly with W3C @traceparent@ test vectors+-- (the parse is the whole contract for inbound requests), and 'injectContext'+-- is exercised through the in-memory interpreter, where an active span exists.+-- A round-trip test confirms inject-then-extract preserves the trace and span+-- ids and the sampled flag.+module Effectful.Tracing.PropagationSpec+  ( tests+  ) where++import Data.ByteString (ByteString)+import Data.Maybe (isJust)++import Effectful (Eff, IOE, runEff)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase, (@?=))++import Effectful.Tracing (Tracer, withSpan)+import Effectful.Tracing.Internal.Ids+  ( spanIdToHex+  , traceIdToHex+  )+import Effectful.Tracing.Internal.Types+  ( SpanContext (..)+  , isSampled+  )+import Effectful.Tracing.Interpreter.InMemory+  ( newCapturedSpans+  , runTracerInMemory+  )+import Effectful.Tracing.Propagation+  ( extractContext+  , injectContext+  , traceparentHeader+  , tracestateHeader+  )++tests :: TestTree+tests =+  testGroup+    "Propagation"+    [ testGroup "extractContext (W3C vectors)" extractVectors+    , testGroup "injectContext" injectTests+    , testGroup "round-trip" roundTripTests+    ]++-- A canonical valid traceparent from the W3C spec examples.+validTraceparent :: ByteString+validTraceparent = "00-4bf92f3577b34da6a3ce929d0e0e4736-00f067aa0ba902b7-01"++extractVectors :: [TestTree]+extractVectors =+  [ testCase "parses a valid traceparent" $ do+      let context = extractContext [(traceparentHeader, validTraceparent)]+      fmap (traceIdToHex . spanContextTraceId) context+        @?= Just "4bf92f3577b34da6a3ce929d0e0e4736"+      fmap (spanIdToHex . spanContextSpanId) context+        @?= Just "00f067aa0ba902b7"+      fmap (isSampled . spanContextTraceFlags) context @?= Just True+      fmap spanContextIsRemote context @?= Just True+  , testCase "unsampled flag (00) parses as not sampled" $ do+      let context =+            extractContext+              [(traceparentHeader, "00-4bf92f3577b34da6a3ce929d0e0e4736-00f067aa0ba902b7-00")]+      fmap (isSampled . spanContextTraceFlags) context @?= Just False+  , testCase "absent traceparent yields Nothing" $+      extractContext [] @?= Nothing+  , testCase "all-zero trace id is rejected" $+      extractContext+        [(traceparentHeader, "00-00000000000000000000000000000000-00f067aa0ba902b7-01")]+        @?= Nothing+  , testCase "all-zero span id is rejected" $+      extractContext+        [(traceparentHeader, "00-4bf92f3577b34da6a3ce929d0e0e4736-0000000000000000-01")]+        @?= Nothing+  , testCase "reserved version ff is rejected" $+      extractContext+        [(traceparentHeader, "ff-4bf92f3577b34da6a3ce929d0e0e4736-00f067aa0ba902b7-01")]+        @?= Nothing+  , testCase "version 00 with a trailing field is rejected" $+      extractContext+        [(traceparentHeader, validTraceparent <> "-extra")]+        @?= Nothing+  , testCase "future version with a trailing field is accepted" $ do+      let context =+            extractContext+              [(traceparentHeader, "01-4bf92f3577b34da6a3ce929d0e0e4736-00f067aa0ba902b7-01-extra")]+      fmap (traceIdToHex . spanContextTraceId) context+        @?= Just "4bf92f3577b34da6a3ce929d0e0e4736"+  , testCase "too few fields is rejected" $+      extractContext [(traceparentHeader, "00-4bf92f3577b34da6a3ce929d0e0e4736")] @?= Nothing+  , testCase "non-hex flags is rejected" $+      extractContext+        [(traceparentHeader, "00-4bf92f3577b34da6a3ce929d0e0e4736-00f067aa0ba902b7-zz")]+        @?= Nothing+  , testCase "a malformed tracestate does not fail extraction" $ do+      let context =+            extractContext+              [ (traceparentHeader, validTraceparent)+              , (tracestateHeader, "this is = not valid = tracestate")+              ]+      assertBool "traceparent still parses" (isJust context)+  , testCase "header lookup is case-insensitive" $ do+      let context = extractContext [("TraceParent", validTraceparent)]+      fmap (spanIdToHex . spanContextSpanId) context @?= Just "00f067aa0ba902b7"+  ]++injectTests :: [TestTree]+injectTests =+  [ testCase "emits a traceparent for the active span" $ do+      headers <- run (withSpan "outbound" injectContext)+      assertBool "a traceparent header is present" (traceparentHeader `elem` map fst headers)+  , testCase "emits no headers when there is no active span" $ do+      headers <- run injectContext+      headers @?= []+  ]++roundTripTests :: [TestTree]+roundTripTests =+  [ testCase "inject then extract preserves ids and sampled flag" $ do+      headers <- run (withSpan "outbound" injectContext)+      let extracted = extractContext headers+      -- The injected span is the live (sampled) child; extraction must recover+      -- its trace id, span id, and sampled flag, now marked remote.+      assertBool "round-trips to a context" (isJust extracted)+      fmap (isSampled . spanContextTraceFlags) extracted @?= Just True+      fmap spanContextIsRemote extracted @?= Just True+  ]++-- | Run a 'Tracer' computation through the in-memory interpreter, discarding the+-- captured spans and returning the computation's result.+run :: Eff '[Tracer, IOE] a -> IO a+run action = runEff $ do+  captured <- newCapturedSpans+  runTracerInMemory captured action
+ test/Effectful/Tracing/PropertySpec.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module      : Effectful.Tracing.PropertySpec+-- Description : Hedgehog property tests for the core data model.+module Effectful.Tracing.PropertySpec+  ( tests+  ) where++import Data.Int (Int64)++import Hedgehog (Gen, Property, assert, evalIO, forAll, property, (===))+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Hedgehog (testProperty)++import Effectful.Tracing.Attribute (AttributeValue (..), toAttributeValue)+import Effectful.Tracing.Internal.Ids+  ( isValidSpanId+  , isValidTraceId+  , newSpanId+  , newTraceId+  , spanIdFromHex+  , spanIdToHex+  , traceIdFromHex+  , traceIdToHex+  )+import Effectful.Tracing.Internal.Types+  ( maxTraceStateEntries+  , spanEndTime+  , spanStartTime+  , traceStateEntries+  , traceStateFromHeader+  , traceStateToHeader+  )++import Effectful.Tracing.Gen+  ( genSpan+  , genSpanId+  , genTraceId+  , genTraceState+  )++tests :: TestTree+tests =+  testGroup+    "core data model"+    [ testProperty "TraceId hex round-trips" prop_traceIdHexRoundTrip+    , testProperty "SpanId hex round-trips" prop_spanIdHexRoundTrip+    , testProperty "generated TraceId is valid" prop_generatedTraceIdValid+    , testProperty "generated SpanId is valid" prop_generatedSpanIdValid+    , testProperty "TraceState header round-trips" prop_traceStateRoundTrip+    , testProperty "TraceState respects the entry cap" prop_traceStateCap+    , testProperty "Int64 coerces to AttrInt" prop_int64Coercion+    , testProperty "Int widens to AttrInt" prop_intWidening+    , testProperty "Bool coerces to AttrBool" prop_boolCoercion+    , testProperty "span start precedes end" prop_spanStartLeEnd+    ]++prop_traceIdHexRoundTrip :: Property+prop_traceIdHexRoundTrip = property $ do+  tid <- forAll genTraceId+  traceIdFromHex (traceIdToHex tid) === Just tid++prop_spanIdHexRoundTrip :: Property+prop_spanIdHexRoundTrip = property $ do+  sid <- forAll genSpanId+  spanIdFromHex (spanIdToHex sid) === Just sid++prop_generatedTraceIdValid :: Property+prop_generatedTraceIdValid = property $ do+  tid <- evalIO newTraceId+  assert (isValidTraceId tid)++prop_generatedSpanIdValid :: Property+prop_generatedSpanIdValid = property $ do+  sid <- evalIO newSpanId+  assert (isValidSpanId sid)++prop_traceStateRoundTrip :: Property+prop_traceStateRoundTrip = property $ do+  st <- forAll genTraceState+  traceStateFromHeader (traceStateToHeader st) === st++prop_traceStateCap :: Property+prop_traceStateCap = property $ do+  st <- forAll genTraceState+  assert (length (traceStateEntries st) <= maxTraceStateEntries)++prop_int64Coercion :: Property+prop_int64Coercion = property $ do+  n <- forAll (Gen.integral (Range.linearFrom 0 minBound maxBound) :: Gen Int64)+  toAttributeValue n === AttrInt n++prop_intWidening :: Property+prop_intWidening = property $ do+  n <- forAll (Gen.integral (Range.linearFrom 0 minBound maxBound) :: Gen Int)+  toAttributeValue n === AttrInt (fromIntegral n)++prop_boolCoercion :: Property+prop_boolCoercion = property $ do+  b <- forAll Gen.bool+  toAttributeValue b === AttrBool b++prop_spanStartLeEnd :: Property+prop_spanStartLeEnd = property $ do+  s <- forAll genSpan+  assert (spanStartTime s <= spanEndTime s)
+ test/Effectful/Tracing/SamplerSpec.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.SamplerSpec+-- Description : Tests for the built-in samplers and their interpreter integration.+--+-- The samplers are tested directly through 'shouldSample' (the decision is the+-- whole contract), and the in-memory interpreter is used to confirm that a+-- 'Drop' omits a span, that 'RecordOnly' captures without setting the sampled+-- flag, and that 'RecordAndSample' captures and flags.+module Effectful.Tracing.SamplerSpec+  ( tests+  ) where++import Control.Monad (replicateM)+import Data.Maybe (fromMaybe)+import Data.Text (Text)++import Effectful (Eff, IOE, runEff)+import Hedgehog (Property, evalIO, forAll, property, (===))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))+import Test.Tasty.Hedgehog (testProperty)++import Effectful.Tracing (Tracer, withSpan)+import Effectful.Tracing.Attribute (attributeKey, (.=))+import Effectful.Tracing.Gen (genTraceId)+import Effectful.Tracing.Internal.Ids+  ( SpanId+  , TraceId+  , newTraceId+  , spanIdFromHex+  , traceIdFromHex+  )+import Effectful.Tracing.Internal.Types+  ( Span (spanAttributes, spanContext)+  , SpanContext (..)+  , SpanKind (Internal)+  , TraceState+  , defaultTraceFlags+  , emptyTraceState+  , insertTraceState+  , isSampled+  , setSampled+  )+import Effectful.Tracing.Interpreter.InMemory+  ( newCapturedSpans+  , readCapturedSpans+  , runTracerInMemoryWith+  )+import Effectful.Tracing.Sampler+  ( Sampler (Sampler, shouldSample)+  , SamplerInput (SamplerInput)+  , SamplingDecision (Drop, RecordAndSample, RecordOnly)+  , SamplingResult (SamplingResult, decision)+  , alwaysOff+  , alwaysOn+  , defaultParentBasedConfig+  , parentBased+  , simpleResult+  , traceIdRatioBased+  )++tests :: TestTree+tests =+  testGroup+    "Sampling"+    [ testGroup+        "built-in decisions"+        [ testCase "alwaysOn records and samples; alwaysOff drops" $ do+            decisionOf alwaysOn (input Nothing) >>= (@?= RecordAndSample)+            decisionOf alwaysOff (input Nothing) >>= (@?= Drop)+        , testProperty "traceIdRatioBased 1.0 always samples" prop_ratioOneSamples+        , testProperty "traceIdRatioBased 0.0 never samples" prop_ratioZeroDrops+        , testProperty "traceIdRatioBased is deterministic per trace id" prop_ratioDeterministic+        , testCase "traceIdRatioBased 0.5 samples about half of many trace ids" $ do+            ids <- replicateM sampleCount newTraceId+            let half = traceIdRatioBased 0.5+            sampled <-+              length . filter (== RecordAndSample)+                <$> traverse (decisionOf half . inputFor Nothing) ids+            let fraction = fromIntegral sampled / fromIntegral sampleCount :: Double+            assertBool+              ("sampled fraction " <> show fraction <> " should be near 0.5")+              (abs (fraction - 0.5) < 0.03)+        , testCase "parentBased follows the parent and falls back to the root" $ do+            -- root is alwaysOff, so a sampled parent decision can only come from+            -- inheritance, not the root sampler.+            let s = parentBased (defaultParentBasedConfig alwaysOff)+            decisionOf s (input Nothing) >>= (@?= Drop)+            decisionOf s (input (Just (parentContext True False))) >>= (@?= RecordAndSample)+            decisionOf s (input (Just (parentContext False False))) >>= (@?= Drop)+            decisionOf s (input (Just (parentContext True True))) >>= (@?= RecordAndSample)+            decisionOf s (input (Just (parentContext False True))) >>= (@?= Drop)+        ]+    , testGroup+        "interpreter integration"+        [ testCase "alwaysOff captures no spans" $ do+            spans <- captureWith alwaysOff twoSpans+            spans @?= []+        , testCase "traceIdRatioBased 0.0 captures no spans" $ do+            spans <- captureWith (traceIdRatioBased 0.0) twoSpans+            spans @?= []+        , testCase "alwaysOn captures every span and flags it sampled" $ do+            spans <- captureWith alwaysOn twoSpans+            length spans @?= 2+            assertBool "every captured span is flagged sampled" (all sampledFlag spans)+        , testCase "RecordOnly captures spans but does not flag them sampled" $ do+            spans <- captureWith recordOnly twoSpans+            length spans @?= 2+            assertBool "no captured span is flagged sampled" (not (any sampledFlag spans))+        , testCase "sampler extra attributes are attached to the captured span" $ do+            spans <- captureWith extraAttrSampler (withSpan "s" (pure ()))+            s <- single spans+            assertBool+              "the sampler-supplied attribute is present"+              (any ((== "sampler.tag") . attributeKey) (spanAttributes s))+        , testCase "sampler trace-state replacement is applied to the span context" $ do+            spans <- captureWith stateSampler (withSpan "s" (pure ()))+            s <- single spans+            spanContextTraceState (spanContext s) @?= samplerState+        ]+    ]++-- Properties ----------------------------------------------------------------++prop_ratioOneSamples :: Property+prop_ratioOneSamples = property $ do+  t <- forAll genTraceId+  d <- evalIO (decisionOf (traceIdRatioBased 1.0) (inputFor Nothing t))+  d === RecordAndSample++prop_ratioZeroDrops :: Property+prop_ratioZeroDrops = property $ do+  t <- forAll genTraceId+  d <- evalIO (decisionOf (traceIdRatioBased 0.0) (inputFor Nothing t))+  d === Drop++prop_ratioDeterministic :: Property+prop_ratioDeterministic = property $ do+  t <- forAll genTraceId+  let s = traceIdRatioBased 0.37+  d1 <- evalIO (decisionOf s (inputFor Nothing t))+  d2 <- evalIO (decisionOf s (inputFor Nothing t))+  d1 === d2++-- Programs and interpreter helpers ------------------------------------------++twoSpans :: Eff '[Tracer, IOE] ()+twoSpans = withSpan "outer" (withSpan "inner" (pure ()))++captureWith :: Sampler -> Eff '[Tracer, IOE] () -> IO [Span]+captureWith sampler prog = do+  captured <- runEff newCapturedSpans+  runEff (runTracerInMemoryWith sampler captured prog)+  runEff (readCapturedSpans captured)++recordOnly :: Sampler+recordOnly = Sampler "RecordOnly" (\_ -> pure (simpleResult RecordOnly))++-- | A sampler that records and tags every span with a fixed attribute.+extraAttrSampler :: Sampler+extraAttrSampler =+  Sampler "WithExtraAttribute" $ \_ ->+    pure (SamplingResult RecordAndSample ["sampler.tag" .= ("set" :: Text)] Nothing)++-- | A sampler that records and replaces the trace state with 'samplerState'.+stateSampler :: Sampler+stateSampler =+  Sampler "WithTraceState" $ \_ ->+    pure (SamplingResult RecordAndSample [] (Just samplerState))++-- | The trace state 'stateSampler' installs.+samplerState :: TraceState+samplerState = fromMaybe emptyTraceState (insertTraceState "vendor" "1" emptyTraceState)++single :: [Span] -> IO Span+single [s] = pure s+single other = assertFailure ("expected exactly one span, got " <> show (length other))++sampledFlag :: Span -> Bool+sampledFlag = isSampled . spanContextTraceFlags . spanContext++-- Sampler helpers -----------------------------------------------------------++sampleCount :: Int+sampleCount = 20000++decisionOf :: Sampler -> SamplerInput -> IO SamplingDecision+decisionOf sampler = fmap decision . shouldSample sampler++input :: Maybe SpanContext -> SamplerInput+input parent = inputFor parent fixedTraceId++inputFor :: Maybe SpanContext -> TraceId -> SamplerInput+inputFor parent traceId = SamplerInput parent traceId "op" Internal [] []++parentContext :: Bool -> Bool -> SpanContext+parentContext sampled remote =+  SpanContext+    { spanContextTraceId = fixedTraceId+    , spanContextSpanId = fixedSpanId+    , spanContextTraceFlags = setSampled sampled defaultTraceFlags+    , spanContextTraceState = emptyTraceState+    , spanContextIsRemote = remote+    }++fixedTraceId :: TraceId+fixedTraceId = unsafeHex traceIdFromHex "4f1a9c000000000000000000000000aa"++fixedSpanId :: SpanId+fixedSpanId = unsafeHex spanIdFromHex "0000000000000001"++unsafeHex :: (t -> Maybe a) -> t -> a+unsafeHex parse raw = fromMaybe (error "bad fixture id") (parse raw)
+ test/Effectful/Tracing/SpanLimitsSpec.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.SpanLimitsSpec+-- Description : Tests for the per-span attribute, event, and link caps.+--+-- Two layers are exercised. The pure 'applySpanLimits' is tested directly on a+-- captured span (captured under 'unlimitedSpanLimits', then re-capped purely),+-- which is the policy unit: count caps keep the earliest entries, the+-- value-length cap truncates strings and string-array elements and leaves other+-- values alone, a 'Nothing' cap keeps everything, and a negative cap keeps+-- nothing. The interpreter integration then confirms the same caps are enforced+-- as a span records: emitting past the count limit drops the overflow, and a+-- value-length limit truncates on the way out.+module Effectful.Tracing.SpanLimitsSpec+  ( tests+  ) where++import Data.Text (Text)+import Data.Text qualified as T+import Data.Vector qualified as V++import Effectful (Eff, IOE, runEff, (:>))++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase, (@?=))++import Effectful.Tracing+  ( SpanArguments (attributes)+  , Tracer+  , addAttribute+  , addAttributes+  , addEvent+  , alwaysOn+  , defaultSpanArguments+  , withSpan+  , withSpan'+  , (.=)+  )+import Effectful.Tracing.Attribute (Attribute (Attribute), AttributeValue (AttrInt, AttrText, AttrTextArray))+import Effectful.Tracing.Interpreter.InMemory+  ( newCapturedSpans+  , readCapturedSpans+  , runTracerInMemoryWithLimits+  )+import Effectful.Tracing.Internal.Types+  ( Event (eventAttributes)+  , Link (Link)+  , Span (spanAttributes, spanContext, spanEvents, spanLinks)+  )+import Effectful.Tracing.SpanLimits+  ( SpanLimits+      ( attributeCountLimit+      , attributeValueLengthLimit+      , eventCountLimit+      , linkCountLimit+      )+  , applySpanLimits+  , defaultSpanLimits+  , unlimitedSpanLimits+  )++tests :: TestTree+tests =+  testGroup+    "SpanLimits"+    [ testGroup "presets" presetTests+    , testGroup "applySpanLimits" applyTests+    , testGroup "interpreter integration" interpreterTests+    ]++presetTests :: [TestTree]+presetTests =+  [ testCase "defaultSpanLimits matches the OpenTelemetry defaults" $ do+      attributeCountLimit defaultSpanLimits @?= Just 128+      attributeValueLengthLimit defaultSpanLimits @?= Nothing+      eventCountLimit defaultSpanLimits @?= Just 128+      linkCountLimit defaultSpanLimits @?= Just 128+  , testCase "unlimitedSpanLimits disables every cap" $ do+      attributeCountLimit unlimitedSpanLimits @?= Nothing+      attributeValueLengthLimit unlimitedSpanLimits @?= Nothing+      eventCountLimit unlimitedSpanLimits @?= Nothing+      linkCountLimit unlimitedSpanLimits @?= Nothing+  ]++applyTests :: [TestTree]+applyTests =+  [ testCase "caps the attribute count, keeping the earliest" $ do+      s <- oneSpan unlimitedSpanLimits (withSpan "s" (addAttributes numbered))+      let capped = applySpanLimits (onlyAttributeCount (Just 2)) s+      map attrKey (spanAttributes capped) @?= ["k0", "k1"]+  , testCase "a Nothing attribute cap keeps everything" $ do+      s <- oneSpan unlimitedSpanLimits (withSpan "s" (addAttributes numbered))+      length (spanAttributes (applySpanLimits (onlyAttributeCount Nothing) s)) @?= 5+  , testCase "a negative attribute cap keeps nothing" $ do+      s <- oneSpan unlimitedSpanLimits (withSpan "s" (addAttributes numbered))+      spanAttributes (applySpanLimits (onlyAttributeCount (Just (-1))) s) @?= []+  , testCase "truncates a long AttrText value" $ do+      s <- oneSpan unlimitedSpanLimits (withSpan "s" (addAttribute "k" ("abcdef" :: Text)))+      let capped = applySpanLimits (onlyValueLength (Just 3)) s+      lookupValue "k" capped @?= Just (AttrText "abc")+  , testCase "truncates each element of an AttrTextArray value" $ do+      s <- oneSpan unlimitedSpanLimits (withSpan "s" (addAttribute "k" (["abcd", "ef", "ghijk"] :: [Text])))+      let capped = applySpanLimits (onlyValueLength (Just 2)) s+      lookupValue "k" capped @?= Just (AttrTextArray (V.fromList ["ab", "ef", "gh"]))+  , testCase "leaves non-string values untouched" $ do+      s <- oneSpan unlimitedSpanLimits (withSpan "s" (addAttribute "k" (123456 :: Int)))+      lookupValue "k" (applySpanLimits (onlyValueLength (Just 2)) s) @?= Just (AttrInt 123456)+  , testCase "caps the event count, keeping the earliest" $ do+      s <- oneSpan unlimitedSpanLimits (withSpan "s" (mapM_ event ["e0", "e1", "e2", "e3"]))+      length (spanEvents (applySpanLimits (onlyEventCount (Just 2)) s)) @?= 2+  , testCase "truncates string values inside an event's attributes" $ do+      s <- oneSpan unlimitedSpanLimits (withSpan "s" (addEvent "e" ["k" .= ("abcdef" :: Text)]))+      case spanEvents (applySpanLimits (onlyValueLength (Just 3)) s) of+        [e] -> map attrValue (eventAttributes e) @?= [AttrText "abc"]+        other -> assertFailure ("expected one event, got " <> show (length other))+  , testCase "caps the link count, keeping the earliest" $ do+      -- The interpreter does not synthesize links here, so seed the captured+      -- span with several (reusing its own context), then cap purely.+      s <- oneSpan unlimitedSpanLimits (withSpan "s" (pure ()))+      let withLinks = s {spanLinks = replicate 5 (Link (spanContext s) [])}+      length (spanLinks (applySpanLimits (onlyLinkCount (Just 2)) withLinks)) @?= 2+  ]++interpreterTests :: [TestTree]+interpreterTests =+  [ testCase "emitting past the attribute cap drops the overflow" $ do+      s <- oneSpan (onlyAttributeCount (Just 2)) (withSpan "s" (addAttributes numbered))+      map attrKey (spanAttributes s) @?= ["k0", "k1"]+  , testCase "the cap counts the initial span-argument attributes" $ do+      -- Three seeded via span arguments, capped at two: the initial set is+      -- bounded at open, keeping the earliest.+      s <-+        oneSpan+          (onlyAttributeCount (Just 2))+          (withSpan' "s" defaultSpanArguments {attributes = take 3 numbered} (pure ()))+      map attrKey (spanAttributes s) @?= ["k0", "k1"]+  , testCase "emitting past the event cap drops the overflow" $ do+      s <- oneSpan (onlyEventCount (Just 2)) (withSpan "s" (mapM_ event ["e0", "e1", "e2", "e3"]))+      length (spanEvents s) @?= 2+  , testCase "a value-length cap truncates on the way out" $ do+      s <- oneSpan (onlyValueLength (Just 4)) (withSpan "s" (addAttribute "k" ("abcdefgh" :: Text)))+      lookupValue "k" s @?= Just (AttrText "abcd")+  ]++-- | Five numbered attributes, @k0@ through @k4@, in order.+numbered :: [Attribute]+numbered = [T.pack ("k" <> show n) .= (n :: Int) | n <- [0 .. 4 :: Int]]++-- | Emit a no-attribute event with the given name.+event :: (Tracer :> es) => Text -> Eff es ()+event name = addEvent name []++attrKey :: Attribute -> Text+attrKey (Attribute k _) = k++attrValue :: Attribute -> AttributeValue+attrValue (Attribute _ v) = v++lookupValue :: Text -> Span -> Maybe AttributeValue+lookupValue key s = lookup key [(k, v) | Attribute k v <- spanAttributes s]++-- | Caps for one dimension at a time, everything else unlimited.+onlyAttributeCount :: Maybe Int -> SpanLimits+onlyAttributeCount n = unlimitedSpanLimits {attributeCountLimit = n}++onlyValueLength :: Maybe Int -> SpanLimits+onlyValueLength n = unlimitedSpanLimits {attributeValueLengthLimit = n}++onlyEventCount :: Maybe Int -> SpanLimits+onlyEventCount n = unlimitedSpanLimits {eventCountLimit = n}++onlyLinkCount :: Maybe Int -> SpanLimits+onlyLinkCount n = unlimitedSpanLimits {linkCountLimit = n}++-- | Run a single-root computation under the given limits and return the one+-- captured span, failing the test if a different number was captured.+oneSpan :: SpanLimits -> Eff '[Tracer, IOE] a -> IO Span+oneSpan limits action = do+  spans <- runEff $ do+    buffer <- newCapturedSpans+    _ <- runTracerInMemoryWithLimits limits alwaysOn buffer action+    readCapturedSpans buffer+  case spans of+    [s] -> pure s+    other -> assertFailure ("expected one captured span, got " <> show (length other))
+ test/Effectful/Tracing/TestingSpec.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.TestingSpec+-- Description : Tests for the public testing helpers.+--+-- Drives a small traced computation through the re-exported in-memory+-- interpreter and checks that the matchers and finders in+-- "Effectful.Tracing.Testing" report the captured tree faithfully: span lookup+-- (single and repeated names), parent/child and descendant structure, root+-- detection, and the attribute / status / event / kind predicates.+module Effectful.Tracing.TestingSpec+  ( tests+  ) where++import Data.List (sort)+import Data.Maybe (isJust)+import Data.Text (Text)++import Effectful (Eff, runEff, (:>))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase, (@?=))++import Effectful.Tracing+  ( SpanArguments (kind)+  , SpanKind (Client, Internal)+  , SpanStatus (Ok, Unset)+  , Tracer+  , addAttribute+  , addEvent+  , defaultSpanArguments+  , setStatus+  , withSpan+  , withSpan'+  )+import Effectful.Tracing.Attribute (AttributeValue (AttrText))+import Effectful.Tracing.Internal.Types (Span, spanName)+import Effectful.Tracing.Testing+  ( childrenOf+  , descendantsOf+  , findSpan+  , findSpans+  , hasAttribute+  , hasAttributeValue+  , hasEvent+  , hasKind+  , hasStatus+  , isChildOf+  , isRoot+  , lookupAttribute+  , lookupEvent+  , newCapturedSpans+  , readCapturedSpans+  , rootSpans+  , runTracerInMemory+  )++tests :: TestTree+tests =+  testGroup+    "Testing helpers"+    [ testCase "findSpan / findSpans locate spans by name" $ do+        spans <- captured+        fmap spanName (findSpan "root" spans) @?= Just "root"+        findSpan "absent" spans @?= Nothing+        -- "leaf" is opened twice, so findSpans returns both occurrences.+        length (findSpans "leaf" spans) @?= 2+        findSpans "absent" spans @?= []+    , testCase "rootSpans and isRoot agree on the single root" $ do+        spans <- captured+        fmap spanName (rootSpans spans) @?= ["root"]+        assertBool "root isRoot" (all isRoot (findSpan "root" spans))+        assertBool "db is not a root" (not (any isRoot (findSpan "db" spans)))+    , testCase "childrenOf returns direct children only" $ do+        spans <- captured+        case findSpan "root" spans of+          Just root -> sort (map spanName (childrenOf root spans)) @?= ["api", "leaf", "leaf"]+          Nothing -> assertBool "root present" False+    , testCase "descendantsOf returns the whole subtree" $ do+        spans <- captured+        case findSpan "root" spans of+          Just root -> sort (map spanName (descendantsOf root spans)) @?= ["api", "db", "leaf", "leaf"]+          Nothing -> assertBool "root present" False+    , testCase "isChildOf reflects the recorded parent" $ do+        spans <- captured+        case (findSpan "db" spans, findSpan "api" spans, findSpan "root" spans) of+          (Just db, Just api, Just root) -> do+            assertBool "db is a child of api" (db `isChildOf` api)+            assertBool "db is not a child of root" (not (db `isChildOf` root))+          _ -> assertBool "db, api, root present" False+    , testCase "attribute matchers read the captured attributes" $ do+        spans <- captured+        case findSpan "root" spans of+          Just root -> do+            lookupAttribute "service" root @?= Just (AttrText "checkout")+            lookupAttribute "absent" root @?= Nothing+            hasAttribute "service" root @?= True+            hasAttribute "absent" root @?= False+            hasAttributeValue "service" (AttrText "checkout") root @?= True+            hasAttributeValue "service" (AttrText "other") root @?= False+          Nothing -> assertBool "root present" False+    , testCase "status, event, and kind matchers" $ do+        spans <- captured+        case (findSpan "root" spans, findSpan "api" spans) of+          (Just root, Just api) -> do+            hasStatus Ok root @?= True+            hasStatus Unset api @?= True+            hasEvent "ready" root @?= True+            hasEvent "absent" root @?= False+            isJust (lookupEvent "ready" root) @?= True+            hasKind Client api @?= True+            hasKind Internal root @?= True+          _ -> assertBool "root and api present" False+    ]++-- | A small traced tree: a root with a service attribute, a "ready" event, and+-- an Ok status; a client-kind "api" child holding a "db" grandchild; and two+-- sibling "leaf" spans sharing a name.+program :: Tracer :> es => Eff es ()+program = withSpan "root" $ do+  addAttribute "service" ("checkout" :: Text)+  addEvent "ready" []+  setStatus Ok+  withSpan' "api" defaultSpanArguments {kind = Client} $+    withSpan "db" (pure ())+  withSpan "leaf" (pure ())+  withSpan "leaf" (pure ())++-- | Run 'program' through the in-memory interpreter and return the captured+-- spans.+captured :: IO [Span]+captured = runEff $ do+  buffer <- newCapturedSpans+  runTracerInMemory buffer program+  readCapturedSpans buffer
+ test/Effectful/Tracing/ThunkSpec.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- |+-- Module      : Effectful.Tracing.ThunkSpec+-- Description : Regression guard against thunk retention in completed spans.+--+-- A completed 'Span' crosses into an interpreter's sink (the in-memory buffer,+-- the pretty-print accumulator) and is held there. The shared lifecycle forces+-- that span to WHNF before handing it over (see @finalizeSpan@), so the sink+-- stores a finished value rather than a thunk that retains the span's builder+-- 'Data.IORef.IORef' and the live @ActiveSpan@. These tests assert, with+-- @nothunks@, that the spans a real traced computation produces carry no+-- unexpected thunk.+--+-- The check is deliberately precise rather than a blanket deep check. The+-- result attribute/event/link lists are built with 'reverse' and are+-- intentionally spine-lazy, so a deep walk would report thunks in their tails+-- that are not leaks. We therefore check the strict scalar structure of the+-- span deeply and the container fields to WHNF, which is exactly what the+-- lifecycle guarantees. The @NoThunks@ instances below live here, not in the+-- library, so the published package takes on no @nothunks@ dependency.+module Effectful.Tracing.ThunkSpec+  ( tests+  ) where++import Data.Text (Text)+import GHC.Generics (Generic)++import NoThunks.Class (NoThunks (noThunks, showTypeOf, wNoThunks), OnlyCheckWhnf (OnlyCheckWhnf), allNoThunks)++import Effectful (Eff, IOE, runEff, (:>))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase)++import Effectful.Tracing+  ( Tracer+  , addAttribute+  , addAttributes+  , addEvent+  , setStatus+  , withSpan+  , (.=)+  )+import Effectful.Tracing.Internal.Ids (SpanId, TraceId)+import Effectful.Tracing.Internal.Types+  ( Span (..)+  , SpanContext (..)+  , SpanKind (..)+  , SpanStatus (..)+  , TraceFlags+  , TraceState+  )+import Effectful.Tracing.Interpreter.InMemory+  ( newCapturedSpans+  , readCapturedSpans+  , runTracerInMemory+  )++-- The id and flag leaves are strict and opaque; checking them to WHNF is+-- enough (and avoids reaching into @bytestring@ / @text@ internals).+deriving via OnlyCheckWhnf TraceId instance NoThunks TraceId++deriving via OnlyCheckWhnf SpanId instance NoThunks SpanId++deriving via OnlyCheckWhnf TraceFlags instance NoThunks TraceFlags++deriving via OnlyCheckWhnf TraceState instance NoThunks TraceState++deriving stock instance Generic SpanContext++deriving anyclass instance NoThunks SpanContext++deriving stock instance Generic SpanKind++deriving anyclass instance NoThunks SpanKind++deriving stock instance Generic SpanStatus++deriving anyclass instance NoThunks SpanStatus++-- | Check the span itself and its strict scalar fields deeply; check the+-- intentionally spine-lazy container fields (and the timestamps) to WHNF.+--+-- Each field is bound with a bang before being handed to @nothunks@. Record+-- selectors are lazy, so @noThunks ctx (spanContext s)@ would otherwise inspect+-- the /selector application/ itself (an unevaluated thunk) and report a false+-- positive. The fields are strict, so forcing the projection to WHNF is a+-- no-op semantically and leaves any genuine nested thunk below WHNF intact for+-- the deep checks to find.+instance NoThunks Span where+  showTypeOf _ = "Span"+  wNoThunks ctx s = noThunks ctx (OnlyCheckWhnf s)+  noThunks ctx s =+    allNoThunks+      [ noThunks ctx (OnlyCheckWhnf s)+      , noThunks ("spanContext" : ctx) sContext+      , noThunks ("spanParentContext" : ctx) sParent+      , noThunks ("spanName" : ctx) sName+      , noThunks ("spanKind" : ctx) sKind+      , noThunks ("spanStartTime" : ctx) (OnlyCheckWhnf sStart)+      , noThunks ("spanEndTime" : ctx) (OnlyCheckWhnf sEnd)+      , noThunks ("spanAttributes" : ctx) (OnlyCheckWhnf sAttrs)+      , noThunks ("spanEvents" : ctx) (OnlyCheckWhnf sEvents)+      , noThunks ("spanLinks" : ctx) (OnlyCheckWhnf sLinks)+      , noThunks ("spanStatus" : ctx) sStatus+      ]+    where+      !sContext = spanContext s+      !sParent = spanParentContext s+      !sName = spanName s+      !sKind = spanKind s+      !sStart = spanStartTime s+      !sEnd = spanEndTime s+      !sAttrs = spanAttributes s+      !sEvents = spanEvents s+      !sLinks = spanLinks s+      !sStatus = spanStatus s++-- | A traced computation that exercises every span field kind: scalar and array+-- attributes, an event, a status, and a nested child span.+program :: (Tracer :> es) => Eff es ()+program =+  withSpan "root" $ do+    addAttribute "service" ("checkout" :: Text)+    addAttribute "items" (3 :: Int)+    addAttributes+      [ "tags" .= (["fast", "cart"] :: [Text])+      , "codes" .= ([200, 404] :: [Int])+      ]+    addEvent "cache.miss" ["key" .= ("session:42" :: Text)]+    withSpan "child" $ do+      addAttribute "db.rows" (12 :: Int)+      setStatus Ok+    setStatus Ok++tests :: TestTree+tests =+  testGroup+    "Thunk retention"+    [ testCase "completed spans carry no unexpected thunk" $ do+        spans <- captureSpans program+        case spans of+          [] -> assertFailure "expected the traced computation to produce spans"+          _ -> mapM_ assertNoThunks spans+    ]++-- | Run a traced program through the in-memory interpreter and return the+-- captured spans.+captureSpans :: Eff '[Tracer, IOE] a -> IO [Span]+captureSpans p = runEff $ do+  captured <- newCapturedSpans+  _ <- runTracerInMemory captured p+  readCapturedSpans captured++assertNoThunks :: Span -> IO ()+assertNoThunks s = do+  result <- noThunks [] s+  case result of+    Nothing -> pure ()+    Just info -> assertFailure ("unexpected thunk in completed span: " <> show info)
+ test/Effectful/Tracing/TypesSpec.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Effectful.Tracing.TypesSpec+-- Description : Unit and property tests for the pure span data model.+--+-- These cover the small total functions that the interpreters lean on but never+-- exercise in isolation: the OpenTelemetry status-transition rules, the W3C+-- trace-state insert/lookup invariants (dedup, capacity, key and value+-- validation), the @tracestate@ header parser's resilience, and the trace-flags+-- bit manipulation.+module Effectful.Tracing.TypesSpec+  ( tests+  ) where++import Data.Bits (testBit)+import Data.Maybe (fromMaybe, isNothing)+import Data.Text qualified as T+import Data.Word (Word8)++-- @foldl'@ moved into Prelude in base-4.20 (GHC 9.10); import it explicitly on+-- older bases so the package still builds on GHC 9.6 / 9.8.+#if !MIN_VERSION_base(4,20,0)+import Data.List (foldl')+#endif++import Hedgehog (Gen, Property, forAll, property, (===))+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase, (@?=))+import Test.Tasty.Hedgehog (testProperty)++import Effectful.Tracing.Effect (transitionStatus)+import Effectful.Tracing.Internal.Types+  ( SpanStatus (Error, Ok, Unset)+  , TraceFlags (TraceFlags)+  , defaultTraceFlags+  , emptyTraceState+  , insertTraceState+  , isSampled+  , lookupTraceState+  , maxTraceStateEntries+  , setSampled+  , traceStateEntries+  , traceStateFromHeader+  )++tests :: TestTree+tests =+  testGroup+    "Pure data model"+    [ testGroup "transitionStatus" transitionTests+    , testGroup "trace state" traceStateTests+    , testGroup "trace flags" traceFlagsTests+    ]++transitionTests :: [TestTree]+transitionTests =+  [ testCase "Unset moves to Ok or Error" $ do+      transitionStatus Unset Ok @?= Ok+      transitionStatus Unset (Error "boom") @?= Error "boom"+  , testCase "Error is overridden by Ok" $+      transitionStatus (Error "boom") Ok @?= Ok+  , testCase "Error is overridden by a later Error" $+      transitionStatus (Error "first") (Error "second") @?= Error "second"+  , testCase "Ok is terminal and ignores later transitions" $ do+      transitionStatus Ok (Error "boom") @?= Ok+      transitionStatus Ok Unset @?= Ok+      transitionStatus Ok Ok @?= Ok+  , testCase "a proposed Unset never downgrades the current status" $ do+      transitionStatus (Error "boom") Unset @?= Error "boom"+      transitionStatus Unset Unset @?= Unset+  , testProperty "Ok absorbs every proposed status" prop_okAbsorbs+  , testProperty "the result is Unset only when both inputs are Unset" prop_neverDowngradesToUnset+  ]++prop_okAbsorbs :: Property+prop_okAbsorbs = property $ do+  proposed <- forAll genStatus+  transitionStatus Ok proposed === Ok++prop_neverDowngradesToUnset :: Property+prop_neverDowngradesToUnset = property $ do+  current <- forAll genStatus+  proposed <- forAll genStatus+  (transitionStatus current proposed == Unset)+    === (current == Unset && proposed == Unset)++genStatus :: Gen SpanStatus+genStatus =+  Gen.choice [pure Unset, pure Ok, Error <$> Gen.text (Range.linear 0 12) Gen.alphaNum]++traceStateTests :: [TestTree]+traceStateTests =+  [ testCase "insert then lookup returns the value" $ do+      let st = insert "vendor" "value" emptyTraceState+      lookupTraceState "vendor" st @?= Just "value"+  , testCase "an inserted key is at the head (most recent)" $ do+      let st = insert "b" "2" (insert "a" "1" emptyTraceState)+      fmap fst (take 1 (traceStateEntries st)) @?= ["b"]+  , testCase "re-inserting a key dedupes and moves it to the head" $ do+      let st = insert "a" "v2" (insert "c" "3" (insert "a" "v1" emptyTraceState))+      traceStateEntries st @?= [("a", "v2"), ("c", "3")]+  , testCase "rejects an empty key" $+      assertBool "empty key" (isNothing (insertTraceState "" "v" emptyTraceState))+  , testCase "rejects an uppercase key" $+      assertBool "uppercase key" (isNothing (insertTraceState "Vendor" "v" emptyTraceState))+  , testCase "rejects an empty value" $+      assertBool "empty value" (isNothing (insertTraceState "k" "" emptyTraceState))+  , testCase "rejects a value containing a comma" $+      assertBool "comma value" (isNothing (insertTraceState "k" "a,b" emptyTraceState))+  , testCase "rejects a value containing an equals sign" $+      assertBool "equals value" (isNothing (insertTraceState "k" "a=b" emptyTraceState))+  , testCase "rejects a new key once the entry cap is reached" $+      assertBool "over capacity" (isNothing (insertTraceState "overflow" "v" fullState))+  , testCase "updates an existing key even at the entry cap" $ do+      -- key0 already exists, so the update removes it before inserting and stays+      -- within the cap.+      let updated = insertTraceState "key0" "fresh" fullState+      fmap (lookupTraceState "key0") updated @?= Just (Just "fresh")+  , testCase "the parser drops malformed members but keeps valid ones" $+      traceStateEntries (traceStateFromHeader "foo=bar,this is junk,baz=qux")+        @?= [("foo", "bar"), ("baz", "qux")]+  , testCase "the parser keeps the first occurrence of a duplicate key" $+      traceStateEntries (traceStateFromHeader "k=1,k=2") @?= [("k", "1")]+  ]+  where+    insert k v st = fromMaybe st (insertTraceState k v st)+    -- A trace state filled to exactly the entry cap, keys key0..key31.+    fullState =+      foldl'+        (\st n -> insert ("key" <> tShow n) (tShow n) st)+        emptyTraceState+        [0 .. maxTraceStateEntries - 1]+    tShow = T.pack . show++traceFlagsTests :: [TestTree]+traceFlagsTests =+  [ testCase "default flags are not sampled" $+      isSampled defaultTraceFlags @?= False+  , testCase "setSampled True then False round-trips the sampled bit" $ do+      isSampled (setSampled True defaultTraceFlags) @?= True+      isSampled (setSampled False (setSampled True defaultTraceFlags)) @?= False+  , testProperty "setSampled toggles only bit 0, preserving the reserved bits" prop_setSampledReservedBits+  ]++prop_setSampledReservedBits :: Property+prop_setSampledReservedBits = property $ do+  w <- forAll (Gen.word8 Range.constantBounded)+  b <- forAll Gen.bool+  let TraceFlags w' = setSampled b (TraceFlags w)+  -- bit 0 reflects the request; bits 1..7 are untouched.+  testBit w' 0 === b+  reservedBits w' === reservedBits w++-- | Bits 1 through 7 of a flags byte (everything but the sampled bit).+reservedBits :: Word8 -> [Bool]+reservedBits w = [testBit w i | i <- [1 .. 7]]
+ test/Main.hs view
@@ -0,0 +1,141 @@+-- |+-- Module      : Main+-- Description : tasty entry point for the effectful-tracing test suite.+-- Copyright   : (c) The effectful-tracing contributors+-- License     : BSD-3-Clause+--+-- Specs live under @test/Effectful/Tracing/@ and are aggregated here.+{-# LANGUAGE CPP #-}++module Main (main) where++import Test.Tasty (TestTree, defaultMain, testGroup)++import Effectful.Tracing.AsyncExceptionSpec qualified as AsyncExceptionSpec+import Effectful.Tracing.AttributeSpec qualified as AttributeSpec+import Effectful.Tracing.BaggageSpec qualified as BaggageSpec+import Effectful.Tracing.CompileTest qualified as CompileTest+import Effectful.Tracing.ConcurrentSpec qualified as ConcurrentSpec+import Effectful.Tracing.EnvConfigSpec qualified as EnvConfigSpec+import Effectful.Tracing.FuzzSpec qualified as FuzzSpec+import Effectful.Tracing.IdGenSpec qualified as IdGenSpec+import Effectful.Tracing.IdsSpec qualified as IdsSpec+import Effectful.Tracing.InMemorySpec qualified as InMemorySpec+import Effectful.Tracing.Instrumentation.DatabaseSpec qualified as DatabaseSpec+import Effectful.Tracing.Instrumentation.MessagingSpec qualified as MessagingSpec+import Effectful.Tracing.LifecycleSpec qualified as LifecycleSpec+import Effectful.Tracing.LogSpec qualified as LogSpec+import Effectful.Tracing.NoOpSpec qualified as NoOpSpec+import Effectful.Tracing.PrettyPrintLeakSpec qualified as PrettyPrintLeakSpec+import Effectful.Tracing.PrettyPrintSpec qualified as PrettyPrintSpec+import Effectful.Tracing.Propagation.B3Spec qualified as B3Spec+import Effectful.Tracing.Propagation.CompositeSpec qualified as CompositeSpec+import Effectful.Tracing.Propagation.JaegerSpec qualified as JaegerSpec+import Effectful.Tracing.PropagationSpec qualified as PropagationSpec+import Effectful.Tracing.PropertySpec qualified as PropertySpec+import Effectful.Tracing.SamplerSpec qualified as SamplerSpec+import Effectful.Tracing.SpanLimitsSpec qualified as SpanLimitsSpec+import Effectful.Tracing.TestingSpec qualified as TestingSpec+import Effectful.Tracing.ThunkSpec qualified as ThunkSpec+import Effectful.Tracing.TypesSpec qualified as TypesSpec++#ifdef OTEL+import Effectful.Tracing.OpenTelemetrySpec qualified as OpenTelemetrySpec+#endif++#ifdef WAI+import Effectful.Tracing.Instrumentation.WaiSpec qualified as WaiSpec+#endif++#ifdef HTTP_CLIENT+import Effectful.Tracing.Instrumentation.HttpClientSpec qualified as HttpClientSpec+#endif++#ifdef SERVANT+import Effectful.Tracing.Instrumentation.ServantSpec qualified as ServantSpec+#endif++#ifdef AMQP_BINDING+import Effectful.Tracing.Instrumentation.AmqpSpec qualified as AmqpSpec+#endif++main :: IO ()+main =+  defaultMain+    ( testGroup+        "effectful-tracing"+        ( [ PropertySpec.tests+          , TypesSpec.tests+          , AttributeSpec.tests+          , IdsSpec.tests+          , IdGenSpec.tests+          , CompileTest.tests+          , NoOpSpec.tests+          , InMemorySpec.tests+          , DatabaseSpec.tests+          , MessagingSpec.tests+          , LifecycleSpec.tests+          , LogSpec.tests+          , PrettyPrintSpec.tests+          , PrettyPrintLeakSpec.tests+          , SamplerSpec.tests+          , SpanLimitsSpec.tests+          , TestingSpec.tests+          , ConcurrentSpec.tests+          , PropagationSpec.tests+          , EnvConfigSpec.tests+          , B3Spec.tests+          , CompositeSpec.tests+          , JaegerSpec.tests+          , BaggageSpec.tests+          , FuzzSpec.tests+          , ThunkSpec.tests+          , AsyncExceptionSpec.tests+          ]+            <> otelTests+            <> waiTests+            <> httpClientTests+            <> servantTests+            <> amqpTests+        )+    )++-- | The OpenTelemetry interpreter tests, present only when built with @+otel@.+otelTests :: [TestTree]+#ifdef OTEL+otelTests = [OpenTelemetrySpec.tests]+#else+otelTests = []+#endif++-- | The WAI middleware tests, present only when built with @+wai@.+waiTests :: [TestTree]+#ifdef WAI+waiTests = [WaiSpec.tests]+#else+waiTests = []+#endif++-- | The http-client tests, present only when built with @+http-client@.+httpClientTests :: [TestTree]+#ifdef HTTP_CLIENT+httpClientTests = [HttpClientSpec.tests]+#else+httpClientTests = []+#endif++-- | The Servant middleware tests, present only when built with @+servant@.+servantTests :: [TestTree]+#ifdef SERVANT+servantTests = [ServantSpec.tests]+#else+servantTests = []+#endif++-- | The RabbitMQ binding tests, present only when built with @+amqp@.+amqpTests :: [TestTree]+#ifdef AMQP_BINDING+amqpTests = [AmqpSpec.tests]+#else+amqpTests = []+#endif