diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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'`. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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). diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -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 diff --git a/docs/cookbook.md b/docs/cookbook.md new file mode 100644 --- /dev/null +++ b/docs/cookbook.md @@ -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. diff --git a/docs/design.md b/docs/design.md new file mode 100644 --- /dev/null +++ b/docs/design.md @@ -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. diff --git a/docs/tutorial.md b/docs/tutorial.md new file mode 100644 --- /dev/null +++ b/docs/tutorial.md @@ -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 + 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. diff --git a/effectful-tracing.cabal b/effectful-tracing.cabal new file mode 100644 --- /dev/null +++ b/effectful-tracing.cabal @@ -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 diff --git a/src/Effectful/Tracing.hs b/src/Effectful/Tracing.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Tracing.hs @@ -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 diff --git a/src/Effectful/Tracing/Attribute.hs b/src/Effectful/Tracing/Attribute.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Tracing/Attribute.hs @@ -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 diff --git a/src/Effectful/Tracing/Baggage.hs b/src/Effectful/Tracing/Baggage.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Tracing/Baggage.hs @@ -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 +-- +-- 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) diff --git a/src/Effectful/Tracing/Concurrent.hs b/src/Effectful/Tracing/Concurrent.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Tracing/Concurrent.hs @@ -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) diff --git a/src/Effectful/Tracing/Effect.hs b/src/Effectful/Tracing/Effect.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Tracing/Effect.hs @@ -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 diff --git a/src/Effectful/Tracing/EnvConfig.hs b/src/Effectful/Tracing/EnvConfig.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Tracing/EnvConfig.hs @@ -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 +-- +-- 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") diff --git a/src/Effectful/Tracing/Instrumentation/Amqp.hs b/src/Effectful/Tracing/Instrumentation/Amqp.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Tracing/Instrumentation/Amqp.hs @@ -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 +-- 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 diff --git a/src/Effectful/Tracing/Instrumentation/Database.hs b/src/Effectful/Tracing/Instrumentation/Database.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Tracing/Instrumentation/Database.hs @@ -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) diff --git a/src/Effectful/Tracing/Instrumentation/HttpClient.hs b/src/Effectful/Tracing/Instrumentation/HttpClient.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Tracing/Instrumentation/HttpClient.hs @@ -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 diff --git a/src/Effectful/Tracing/Instrumentation/Messaging.hs b/src/Effectful/Tracing/Instrumentation/Messaging.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Tracing/Instrumentation/Messaging.hs @@ -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 +-- 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 diff --git a/src/Effectful/Tracing/Instrumentation/PostgresqlSimple.hs b/src/Effectful/Tracing/Instrumentation/PostgresqlSimple.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Tracing/Instrumentation/PostgresqlSimple.hs @@ -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) diff --git a/src/Effectful/Tracing/Instrumentation/Servant.hs b/src/Effectful/Tracing/Instrumentation/Servant.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Tracing/Instrumentation/Servant.hs @@ -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 diff --git a/src/Effectful/Tracing/Instrumentation/SqliteSimple.hs b/src/Effectful/Tracing/Instrumentation/SqliteSimple.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Tracing/Instrumentation/SqliteSimple.hs @@ -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 diff --git a/src/Effectful/Tracing/Instrumentation/Valiant.hs b/src/Effectful/Tracing/Instrumentation/Valiant.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Tracing/Instrumentation/Valiant.hs @@ -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 , +-- 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) diff --git a/src/Effectful/Tracing/Instrumentation/Wai.hs b/src/Effectful/Tracing/Instrumentation/Wai.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Tracing/Instrumentation/Wai.hs @@ -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)) diff --git a/src/Effectful/Tracing/Internal/Clock.hs b/src/Effectful/Tracing/Internal/Clock.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Tracing/Internal/Clock.hs @@ -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 diff --git a/src/Effectful/Tracing/Internal/Ids.hs b/src/Effectful/Tracing/Internal/Ids.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Tracing/Internal/Ids.hs @@ -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 diff --git a/src/Effectful/Tracing/Internal/Live.hs b/src/Effectful/Tracing/Internal/Live.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Tracing/Internal/Live.hs @@ -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)))] diff --git a/src/Effectful/Tracing/Internal/Types.hs b/src/Effectful/Tracing/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Tracing/Internal/Types.hs @@ -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) diff --git a/src/Effectful/Tracing/Interpreter/InMemory.hs b/src/Effectful/Tracing/Interpreter/InMemory.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Tracing/Interpreter/InMemory.hs @@ -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) diff --git a/src/Effectful/Tracing/Interpreter/NoOp.hs b/src/Effectful/Tracing/Interpreter/NoOp.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Tracing/Interpreter/NoOp.hs @@ -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 diff --git a/src/Effectful/Tracing/Interpreter/OpenTelemetry.hs b/src/Effectful/Tracing/Interpreter/OpenTelemetry.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Tracing/Interpreter/OpenTelemetry.hs @@ -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) diff --git a/src/Effectful/Tracing/Interpreter/PrettyPrint.hs b/src/Effectful/Tracing/Interpreter/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Tracing/Interpreter/PrettyPrint.hs @@ -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 diff --git a/src/Effectful/Tracing/Log.hs b/src/Effectful/Tracing/Log.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Tracing/Log.hs @@ -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 +-- (@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 diff --git a/src/Effectful/Tracing/Propagation.hs b/src/Effectful/Tracing/Propagation.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Tracing/Propagation.hs @@ -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 +-- @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 diff --git a/src/Effectful/Tracing/Propagation/B3.hs b/src/Effectful/Tracing/Propagation/B3.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Tracing/Propagation/B3.hs @@ -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 +-- 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 diff --git a/src/Effectful/Tracing/Propagation/Baggage.hs b/src/Effectful/Tracing/Propagation/Baggage.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Tracing/Propagation/Baggage.hs @@ -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 +-- @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 diff --git a/src/Effectful/Tracing/Propagation/Composite.hs b/src/Effectful/Tracing/Propagation/Composite.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Tracing/Propagation/Composite.hs @@ -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) diff --git a/src/Effectful/Tracing/Propagation/Jaeger.hs b/src/Effectful/Tracing/Propagation/Jaeger.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Tracing/Propagation/Jaeger.hs @@ -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 +-- +-- 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 diff --git a/src/Effectful/Tracing/Sampler.hs b/src/Effectful/Tracing/Sampler.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Tracing/Sampler.hs @@ -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 diff --git a/src/Effectful/Tracing/SemConv.hs b/src/Effectful/Tracing/SemConv.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Tracing/SemConv.hs @@ -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" diff --git a/src/Effectful/Tracing/SpanLimits.hs b/src/Effectful/Tracing/SpanLimits.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Tracing/SpanLimits.hs @@ -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 diff --git a/src/Effectful/Tracing/Testing.hs b/src/Effectful/Tracing/Testing.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Tracing/Testing.hs @@ -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 diff --git a/test-space-leak/Main.hs b/test-space-leak/Main.hs new file mode 100644 --- /dev/null +++ b/test-space-leak/Main.hs @@ -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") diff --git a/test/Effectful/Tracing/AsyncExceptionSpec.hs b/test/Effectful/Tracing/AsyncExceptionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Tracing/AsyncExceptionSpec.hs @@ -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) diff --git a/test/Effectful/Tracing/AttributeSpec.hs b/test/Effectful/Tracing/AttributeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Tracing/AttributeSpec.hs @@ -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) diff --git a/test/Effectful/Tracing/BaggageSpec.hs b/test/Effectful/Tracing/BaggageSpec.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Tracing/BaggageSpec.hs @@ -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 diff --git a/test/Effectful/Tracing/CompileTest.hs b/test/Effectful/Tracing/CompileTest.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Tracing/CompileTest.hs @@ -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 diff --git a/test/Effectful/Tracing/ConcurrentSpec.hs b/test/Effectful/Tracing/ConcurrentSpec.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Tracing/ConcurrentSpec.hs @@ -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 diff --git a/test/Effectful/Tracing/EnvConfigSpec.hs b/test/Effectful/Tracing/EnvConfigSpec.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Tracing/EnvConfigSpec.hs @@ -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}" + ] diff --git a/test/Effectful/Tracing/FuzzSpec.hs b/test/Effectful/Tracing/FuzzSpec.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Tracing/FuzzSpec.hs @@ -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 "" + ] diff --git a/test/Effectful/Tracing/Gen.hs b/test/Effectful/Tracing/Gen.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Tracing/Gen.hs @@ -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 + } diff --git a/test/Effectful/Tracing/IdGenSpec.hs b/test/Effectful/Tracing/IdGenSpec.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Tracing/IdGenSpec.hs @@ -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 + ] diff --git a/test/Effectful/Tracing/IdsSpec.hs b/test/Effectful/Tracing/IdsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Tracing/IdsSpec.hs @@ -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" diff --git a/test/Effectful/Tracing/InMemorySpec.hs b/test/Effectful/Tracing/InMemorySpec.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Tracing/InMemorySpec.hs @@ -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) diff --git a/test/Effectful/Tracing/Instrumentation/AmqpSpec.hs b/test/Effectful/Tracing/Instrumentation/AmqpSpec.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Tracing/Instrumentation/AmqpSpec.hs @@ -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 diff --git a/test/Effectful/Tracing/Instrumentation/DatabaseSpec.hs b/test/Effectful/Tracing/Instrumentation/DatabaseSpec.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Tracing/Instrumentation/DatabaseSpec.hs @@ -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 diff --git a/test/Effectful/Tracing/Instrumentation/HttpClientSpec.hs b/test/Effectful/Tracing/Instrumentation/HttpClientSpec.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Tracing/Instrumentation/HttpClientSpec.hs @@ -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)) diff --git a/test/Effectful/Tracing/Instrumentation/MessagingSpec.hs b/test/Effectful/Tracing/Instrumentation/MessagingSpec.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Tracing/Instrumentation/MessagingSpec.hs @@ -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 diff --git a/test/Effectful/Tracing/Instrumentation/ServantSpec.hs b/test/Effectful/Tracing/Instrumentation/ServantSpec.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Tracing/Instrumentation/ServantSpec.hs @@ -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 diff --git a/test/Effectful/Tracing/Instrumentation/WaiSpec.hs b/test/Effectful/Tracing/Instrumentation/WaiSpec.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Tracing/Instrumentation/WaiSpec.hs @@ -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)) diff --git a/test/Effectful/Tracing/LifecycleSpec.hs b/test/Effectful/Tracing/LifecycleSpec.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Tracing/LifecycleSpec.hs @@ -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) diff --git a/test/Effectful/Tracing/LogSpec.hs b/test/Effectful/Tracing/LogSpec.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Tracing/LogSpec.hs @@ -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) diff --git a/test/Effectful/Tracing/NoOpSpec.hs b/test/Effectful/Tracing/NoOpSpec.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Tracing/NoOpSpec.hs @@ -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 diff --git a/test/Effectful/Tracing/OpenTelemetrySpec.hs b/test/Effectful/Tracing/OpenTelemetrySpec.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Tracing/OpenTelemetrySpec.hs @@ -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 diff --git a/test/Effectful/Tracing/PrettyPrintLeakSpec.hs b/test/Effectful/Tracing/PrettyPrintLeakSpec.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Tracing/PrettyPrintLeakSpec.hs @@ -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 diff --git a/test/Effectful/Tracing/PrettyPrintSpec.hs b/test/Effectful/Tracing/PrettyPrintSpec.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Tracing/PrettyPrintSpec.hs @@ -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 diff --git a/test/Effectful/Tracing/Propagation/B3Spec.hs b/test/Effectful/Tracing/Propagation/B3Spec.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Tracing/Propagation/B3Spec.hs @@ -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 diff --git a/test/Effectful/Tracing/Propagation/CompositeSpec.hs b/test/Effectful/Tracing/Propagation/CompositeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Tracing/Propagation/CompositeSpec.hs @@ -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 diff --git a/test/Effectful/Tracing/Propagation/JaegerSpec.hs b/test/Effectful/Tracing/Propagation/JaegerSpec.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Tracing/Propagation/JaegerSpec.hs @@ -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 diff --git a/test/Effectful/Tracing/PropagationSpec.hs b/test/Effectful/Tracing/PropagationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Tracing/PropagationSpec.hs @@ -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 diff --git a/test/Effectful/Tracing/PropertySpec.hs b/test/Effectful/Tracing/PropertySpec.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Tracing/PropertySpec.hs @@ -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) diff --git a/test/Effectful/Tracing/SamplerSpec.hs b/test/Effectful/Tracing/SamplerSpec.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Tracing/SamplerSpec.hs @@ -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) diff --git a/test/Effectful/Tracing/SpanLimitsSpec.hs b/test/Effectful/Tracing/SpanLimitsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Tracing/SpanLimitsSpec.hs @@ -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)) diff --git a/test/Effectful/Tracing/TestingSpec.hs b/test/Effectful/Tracing/TestingSpec.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Tracing/TestingSpec.hs @@ -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 diff --git a/test/Effectful/Tracing/ThunkSpec.hs b/test/Effectful/Tracing/ThunkSpec.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Tracing/ThunkSpec.hs @@ -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) diff --git a/test/Effectful/Tracing/TypesSpec.hs b/test/Effectful/Tracing/TypesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Tracing/TypesSpec.hs @@ -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]] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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