hs-opentelemetry-api 0.3.1.0 → 1.0.0.0
raw patch · 99 files changed
+14077/−3670 lines, 99 filesdep +containersdep +hedgehogdep +hs-opentelemetry-api-typesdep −attoparsecdep −binarydep −charsetdep ~thread-utils-context
Dependencies added: containers, hedgehog, hs-opentelemetry-api-types, hs-opentelemetry-semantic-conventions, hspec-hedgehog, tasty-bench
Dependencies removed: attoparsec, binary, charset, clock, http-types, memory, mtl, regex-tdfa, safe-exceptions
Dependency ranges changed: thread-utils-context
Files
- ChangeLog.md +302/−0
- LICENSE +1/−1
- README.md +3/−2
- bench/Main.hs +319/−0
- cbits/hs_otel_hex.c +428/−0
- cbits/hs_otel_rng.c +140/−0
- cbits/hs_otel_time.c +30/−0
- hs-opentelemetry-api.cabal +79/−24
- include/hs_otel_hex.h +64/−0
- src/OpenTelemetry/Attributes.hs +329/−37
- src/OpenTelemetry/Attributes/Attribute.hs +0/−226
- src/OpenTelemetry/Attributes/Key.hs +0/−48
- src/OpenTelemetry/Attributes/Map.hs +3/−3
- src/OpenTelemetry/Baggage.hs +495/−87
- src/OpenTelemetry/Common.hs +89/−5
- src/OpenTelemetry/Context.hs +81/−46
- src/OpenTelemetry/Context/Environment.hs +236/−0
- src/OpenTelemetry/Context/ThreadLocal.hs +301/−63
- src/OpenTelemetry/Context/ThreadLocal/Propagation.hs +155/−0
- src/OpenTelemetry/Context/Types.hs +31/−5
- src/OpenTelemetry/Contrib/CarryOns.hs +24/−13
- src/OpenTelemetry/Contrib/SpanTraversals.hs +12/−7
- src/OpenTelemetry/Debug/MetricExport.hs +105/−0
- src/OpenTelemetry/Environment.hs +163/−0
- src/OpenTelemetry/Exporter.hs +16/−6
- src/OpenTelemetry/Exporter/LogRecord.hs +6/−1
- src/OpenTelemetry/Exporter/Metric.hs +8/−0
- src/OpenTelemetry/Internal/AtomicBucketArray.hs +125/−0
- src/OpenTelemetry/Internal/AtomicCounter.hs +100/−0
- src/OpenTelemetry/Internal/Common/Types.hs +192/−34
- src/OpenTelemetry/Internal/Log/Core.hs +469/−0
- src/OpenTelemetry/Internal/Log/Types.hs +597/−0
- src/OpenTelemetry/Internal/Logging.hs +153/−0
- src/OpenTelemetry/Internal/Logs/Core.hs +0/−311
- src/OpenTelemetry/Internal/Logs/Types.hs +0/−491
- src/OpenTelemetry/Internal/Metric/Export.hs +274/−0
- src/OpenTelemetry/Internal/Metric/Types.hs +275/−0
- src/OpenTelemetry/Internal/Trace/Id.hs +315/−148
- src/OpenTelemetry/Internal/Trace/Types.hs +484/−157
- src/OpenTelemetry/Internal/UnpackedMaybe.hs +84/−0
- src/OpenTelemetry/Log/Core.hs +111/−0
- src/OpenTelemetry/LogAttributes.hs +9/−2
- src/OpenTelemetry/Logs/Core.hs +0/−36
- src/OpenTelemetry/Metric/Core.hs +264/−0
- src/OpenTelemetry/Metric/InstrumentName.hs +78/−0
- src/OpenTelemetry/Processor.hs +11/−6
- src/OpenTelemetry/Processor/LogRecord.hs +7/−1
- src/OpenTelemetry/Processor/Span.hs +1/−4
- src/OpenTelemetry/Propagator.hs +249/−30
- src/OpenTelemetry/Registry.hs +350/−0
- src/OpenTelemetry/Resource.hs +206/−90
- src/OpenTelemetry/Resource/Cloud.hs +89/−86
- src/OpenTelemetry/Resource/Container.hs +27/−18
- src/OpenTelemetry/Resource/DeploymentEnvironment.hs +14/−13
- src/OpenTelemetry/Resource/Device.hs +0/−4
- src/OpenTelemetry/Resource/FaaS.hs +55/−51
- src/OpenTelemetry/Resource/Host.hs +22/−18
- src/OpenTelemetry/Resource/Kubernetes.hs +97/−61
- src/OpenTelemetry/Resource/OperatingSystem.hs +45/−46
- src/OpenTelemetry/Resource/Process.hs +88/−54
- src/OpenTelemetry/Resource/Service.hs +40/−35
- src/OpenTelemetry/Resource/Telemetry.hs +17/−15
- src/OpenTelemetry/Resource/Webengine.hs +33/−8
- src/OpenTelemetry/SemanticsConfig.hs +114/−38
- src/OpenTelemetry/Trace/Core.hs +1564/−974
- src/OpenTelemetry/Trace/ExceptionHandler.hs +140/−0
- src/OpenTelemetry/Trace/Id.hs +11/−0
- src/OpenTelemetry/Trace/Id/Generator.hs +72/−24
- src/OpenTelemetry/Trace/Id/Generator/Dummy.hs +7/−6
- src/OpenTelemetry/Trace/Monad.hs +46/−17
- src/OpenTelemetry/Trace/Sampler.hs +157/−85
- src/OpenTelemetry/Trace/TraceState.hs +28/−9
- src/OpenTelemetry/Util.hs +201/−43
- test/OpenTelemetry/AttributesSpec.hs +107/−0
- test/OpenTelemetry/BaggageSpec.hs +230/−1
- test/OpenTelemetry/Context/EnvironmentSpec.hs +45/−0
- test/OpenTelemetry/Context/PropagationSpec.hs +95/−0
- test/OpenTelemetry/Context/ThreadLocalSpec.hs +95/−0
- test/OpenTelemetry/ContextSpec.hs +83/−0
- test/OpenTelemetry/Contrib/CarryOnsSpec.hs +132/−0
- test/OpenTelemetry/Contrib/SpanTraversalsSpec.hs +58/−0
- test/OpenTelemetry/EnvironmentSpec.hs +245/−0
- test/OpenTelemetry/InstrumentationLibrarySpec.hs +122/−10
- test/OpenTelemetry/Internal/LoggingSpec.hs +86/−0
- test/OpenTelemetry/Log/CoreSpec.hs +537/−0
- test/OpenTelemetry/Logs/CoreSpec.hs +0/−91
- test/OpenTelemetry/MetricSpec.hs +64/−0
- test/OpenTelemetry/PropagatorSpec.hs +94/−0
- test/OpenTelemetry/RegistrySpec.hs +112/−0
- test/OpenTelemetry/ResourceSpec.hs +72/−2
- test/OpenTelemetry/SemanticsConfigSpec.hs +95/−8
- test/OpenTelemetry/Trace/ExceptionHandlerSpec.hs +185/−0
- test/OpenTelemetry/Trace/IdCodecSpec.hs +278/−0
- test/OpenTelemetry/Trace/MonadSpec.hs +63/−0
- test/OpenTelemetry/Trace/SamplerSpec.hs +364/−11
- test/OpenTelemetry/Trace/TraceFlagsSpec.hs +43/−6
- test/OpenTelemetry/Trace/TracerSpec.hs +62/−7
- test/OpenTelemetry/Trace/UtilsSpec.hs +138/−0
- test/Spec.hs +31/−45
ChangeLog.md view
@@ -2,6 +2,308 @@ ## Unreleased +## 1.0.0.0 - 2026-05-29++### Full Spec conformance against 1.55.0+- **`InstrumentationScope` type alias added.**+ The OTel spec renamed "Instrumentation Library" to "Instrumentation Scope".+ `InstrumentationScope` is now a type alias for `InstrumentationLibrary`, and+ `instrumentationScope` is the preferred constructor. The underlying type+ retains the old name for backwards compatibility.+ Spec: <https://opentelemetry.io/docs/specs/otel/common/instrumentation-scope/>+- **`LogRecordExporter.forceFlush` now returns `IO FlushResult`.**+ Previously returned `IO ()`. The spec says ForceFlush SHOULD let the+ caller know whether it succeeded, failed, or timed out.+ Spec: <https://opentelemetry.io/docs/specs/otel/logs/sdk/#logrecordexporter>+- **`shouldSample` now receives the `InstrumentationScope`.**+ The `Sampler` type's `CustomSampler` constructor now takes the tracer's+ `InstrumentationLibrary` as a final parameter. This is a breaking change+ for custom sampler implementations.+ Spec: <https://opentelemetry.io/docs/specs/otel/trace/sdk/#shouldsample>+- **`ImmutableLogRecord` internal fields switched to `UMaybe`.**+ The `logRecordTimestamp`, `logRecordTracingDetails`, `logRecordSeverityText`,+ `logRecordSeverityNumber`, and `logRecordEventName` fields now use unboxed+ optionals for lower allocation on the emit hot path. External+ `LogRecordArguments` fields remain as `Maybe`.++### Performance++Major performance rework across the tracing and metrics hot paths. The previous+release (`origin/main`) used `System.Random.Stateful` for ID generation,+`IORef ImmutableSpan` with a flat mutable record for span state,+`System.Clock.TimeSpec` for timestamps, Haskell-side hex encoding, and+`http-types`/`case-insensitive`/`binary` as transitive dependencies. All of+these have been replaced:++- **Span representation split**: `ImmutableSpan` identity fields (trace/span ID,+ kind, start time) are now immutable and accessed without touching any `IORef`;+ only mutable state (`hotName`, `hotEnd`, `hotAttributes`, etc.) goes through a+ single `IORef SpanHot`. Eliminates an indirection on every+ `getSpanContext`/`isRecording` call.+- **Unboxed TraceId/SpanId**: two `Word64` fields in registers instead of a+ heap-allocated pinned `ShortByteString`. Eliminates allocation on every span.+- **Thread-local xoshiro256++ RNG**: replaced `System.Random.Stateful` (Haskell+ `random` package) with thread-local xoshiro256++ implemented in C, seeded once+ from the platform CSPRNG (`arc4random_buf` / `getrandom`). Zero contention,+ zero syscalls, zero Haskell allocation after initial seed. Dropped the `random`+ dependency.+- **Timestamp FFI**: `Timestamp` is now `Word64` nanoseconds. Direct+ `clock_gettime` C FFI call bypasses the `clock` package's+ `alloca`/`errno`/`Storable` overhead. OTLP serialization is zero-cost+ (`coerce`). Dropped the `clock` dependency.+- **C hex encoding**: trace/span ID hex via SWAR in C (`hs_otel_hex.c`),+ avoiding intermediate `ByteString` allocations from the old Haskell encoder.+- **No-op fast path**: `inSpan` skips `mask`/`bracketError`/context+ modification entirely when no processors are registered.+- **`bracketError` elimination**: inlined the `mask $ \restore ->` pattern into+ `inSpan`, eliminating a 4-tuple allocation, `uninterruptibleMask_`, and `try`+ that the previous generic `bracketError` helper required.+- **Thread-local context rewrite**: the previous `thread-utils-context` V1+ stored contexts in 32-stripe `IntMap`s with CAS (`casArray#` + `yield#`+ retry) on every write. Every `getContext` call allocated a `ThreadId` box+ via `myThreadId#`, crossed the FFI boundary to `rts_getThreadId`, then did+ an O(log n) `IntMap.lookup` inside the stripe. Every `adjustContext` /+ `attachContext` additionally CAS'd the entire stripe `IntMap`, with+ `yield#`-based spin on contention. `lookupSpan` went through+ `Data.Vault.Strict` (a `HashMap` keyed by `Data.Unique`).+ The new implementation replaces all of this with a flat open-addressed hash table+ backed by `MutableByteArray#` keys and `MutableArray#` values, where each+ thread gets its own `IORef`. Hot-path reads and writes now go directly through+ that `IORef` with zero contention. CAS is only used for+ thread registration (once per thread lifetime). Two custom CMM primops+ (`stg_getCurrentThreadId`, `stg_probeThreadSlot`) fuse thread ID retrieval+ with the table probe in a single STG call, eliminating the `myThreadId#`+ box allocation and `rts_getThreadId` FFI call entirely. The OTel wrapper for `Context` itself+ now has dedicated unboxed slots for `Span` and `Baggage`,+ replacing `Data.Vault.Strict` lookups with O(1) pattern matches.+ Result: `getContext` dropped from 17.3 ns to 2.9 ns (6x), `lookupSpan`+ from 10.0 ns to 0.6 ns / 0 B (17x).+- **CAS `yield#` removal**: removed `yield#` from the CAS failure path in+ `casModifyIORef_`; its presence prevented GHC from optimizing the uncontended+ success path.+- **Cached attribute limits**: pre-resolved from `TracerProvider` onto `Tracer`+ at `makeTracer` time, eliminating repeated pointer chasing on every attribute+ operation.+- **Deferred caller attributes**: source-location attributes passed lazily to+ `createSpanHelper`, only forced when the span is actually recorded.+- **INLINE audit**: ~30 hot-path functions annotated; `shouldSample` split into+ an inline wrapper + NOINLINE complex path so GHC can perform case-of-case at+ call sites.+- **`AttrsBuilder`**: church-encoded attribute builder that folds directly into+ the span's `HashMap`, avoiding intermediate list/tuple allocation.+ search for histogram bucket index, `AtomicBucketArray` (single+ `MutableByteArray#` with `fetchAddIntArray#`), `OptionalDouble` for histogram+ min/max.+- **Dependency removals**: dropped `random`, `clock`, `http-types`,+ `case-insensitive`, `binary`, `charset`, `regex-tdfa` from the API package.++Current benchmark results (GHC 9.10, `-O1`, aarch64-osx, `-N1 -A32m`):++| Operation | Time | Allocated |+|---|---|---|+| `inSpan` no-op (no processors) | 13.6 ns | 15 B |+| `inSpan` active (skip callerAttrs) | 218 ns | 1.2 KB |+| `inSpan` active | 445 ns | 2.5 KB |+| bare span (create+end) | 209 ns | 1.2 KB |+| HTTP span (3 attrs) | 410 ns | 2.5 KB |+| DB span (5 attrs) | 520 ns | 3.3 KB |+| 3-deep nested spans | 683 ns | 3.7 KB |+| `getContext` | 2.9 ns | 15 B |+| `lookupSpan` | 0.6 ns | 0 B |+| SpanId gen (xoshiro) | 3.0 ns | 0 B |+| TraceId gen (xoshiro) | 5.8 ns | 0 B |++Head-to-head comparison (same benchmark code, same machine, GHC 9.10,+`-O1 -N1 -A32m`):++| Operation | origin/main | Current | Speedup |+|---|---|---|---|+| `createSpan` no-op | 39.7 ns / 191 B | 13.6 ns / 15 B | **2.9x / 12.7x** |+| `inSpan` no-op | 316 ns / 1,678 B | 13.6 ns / 15 B | **23x / 112x** |+| `createSpan+endSpan` no-op | 593 ns / 1,846 B | 441 ns / 1,095 B | **1.3x / 1.7x** |++The `inSpan` no-op improvement is the most representative: it's the path+every instrumented function takes when the SDK is not installed or has no+processors. The old version paid for `mask`, context read/write, and+`System.Random` ID generation even on the no-op path; the new version+short-circuits all of that.++Cross-language comparison (bare span create+end, no attributes, AlwaysSample):++| Language | Time | Source |+|---|---|---|+| **Haskell** | **209 ns** | This release (tasty-bench, aarch64-osx) |+| **Go** | ~279 ns | [open-telemetry/opentelemetry-go#6730](https://github.com/open-telemetry/opentelemetry-go/pull/6730) (StartEndSpan/AlwaysSample, May 2025) |+| **Rust** | ~349 ns | [open-telemetry/opentelemetry-rust#1101](https://github.com/open-telemetry/opentelemetry-rust/pull/1101) (basic span no attrs, always-sample, Jun 2023) |++Haskell's bare span is **1.3x faster than Go** and **1.7x faster than Rust**+on the equivalent workload. The `inSpan` wrapper adds `mask`/`restore` for+async-exception safety and TLS context management, bringing the total to+218 ns without caller attributes or 445 ns with automatic `code.*` source+location attributes (which other SDKs do not include by default).++Note: cross-language numbers are from different machines and compilers, so+ratios are approximate. The Go and Rust numbers are from their own CI /+maintainer benchmarks on x86-64 Linux.++### Bug fixes+- **`addAttributes` now correctly overwrites existing keys.**+ `H.union` argument order was reversed, causing existing attribute values to+ silently take precedence over new ones. New values now win on key conflict,+ matching `addAttribute` behavior and spec intent.+- **`traceIdRatioBased` description now always uses `TraceIdRatioBased{ratio}` format.**+ Previously, `traceIdRatioBased 1.0` returned `alwaysOn` whose description was+ `"AlwaysOnSampler"`, violating the spec's MUST requirement. The ratio is now+ clamped to `[0, 1]` and the description always follows the spec format.++### Spec conformance (SHOULD-level)+- **`LoggerProvider` shutdown suppresses processor dispatch.**+ Added `loggerProviderIsShutdown` flag. After `shutdownLoggerProvider`,+ `emitLogRecord` still returns a `ReadWriteLogRecord` but skips calling+ processors. `loggerIsEnabled` now returns `IO Bool` and accounts for+ shutdown state.+- **`Baggage` `insertChecked` enforces W3C size limits.**+ New `insertChecked :: Token -> Element -> Baggage -> Either InvalidBaggage Baggage`+ enforces the 180-member limit (W3C ABNF grammar) and 8192-byte total+ serialized size limit. `InvalidBaggage` now derives `Show, Eq`.++### Breaking changes+- **`createLoggerProvider` is now monadic (`MonadIO m => ... -> m LoggerProvider`).**+ Required to safely allocate the internal shutdown `IORef`. Existing `let`+ bindings need to become `<-` bindings.+- **`loggerIsEnabled` now returns `IO Bool` instead of `Bool`.**+ Checks the provider shutdown flag, which requires reading the `IORef`.+- **`propagatorNames` renamed to `propagatorFields`.**+ The `Propagator` record field is now called `propagatorFields` to match the+ OpenTelemetry spec's `Fields` method. Values are actual header names (e.g.+ `["traceparent", "tracestate"]`), not display names.+- **New `TextMapPropagator` type alias.**+ `type TextMapPropagator = Propagator Context RequestHeaders RequestHeaders`+ is now exported from `OpenTelemetry.Propagator`.+- **Global `TextMapPropagator` API.**+ `getGlobalTextMapPropagator` and `setGlobalTextMapPropagator` provide a+ spec-conformant global propagator. Defaults to no-op per spec. The SDK+ sets this during initialization. Instrumentation libraries should prefer+ the global propagator over `getTracerProviderPropagators`.+- **`SemanticsOptions` is now opaque with generalized stability lookup.**+ Instead of a record with `httpOption` and `databaseOption` fields,+ `SemanticsOptions` now stores the parsed env var values as a set. Use the new+ `lookupStability :: Text -> SemanticsOptions -> StabilityOpt` function to query+ any signal key (e.g. `"http"`, `"database"`, `"messaging"`, `"rpc"`). The+ convenience functions `httpOption` and `databaseOption` still work as before.+ `HttpOption` is now a type alias for the renamed `StabilityOpt` data type.+ Third-party instrumentation libraries can now participate in the+ `OTEL_SEMCONV_STABILITY_OPT_IN` mechanism without modifying this module.++### Bug fixes+- **Fix: `setStatus` merge semantics.** Previously used `max` on an `Ord SpanStatus`+ instance to merge statuses, which broke Error-over-Error (last-writer-wins) regardless+ of how `Ord` was defined. Now uses an explicit `mergeStatus` function implementing the+ three spec rules: Ok is final, Unset is ignored, everything else is last-writer-wins.+ The `Ord` instance is now lawful (EQ for Error/Error) and only represents the class+ hierarchy (Ok > Error > Unset), not merge logic.+- **Fix: `forceFlushTracerProvider` leaked async threads on timeout.** Outstanding+ processor flush asyncs were never cancelled when the timeout fired. Now calls+ `mapM_ cancel jobs` on the `Nothing` (timeout) branch.+- **Fix: `isRecording` returned `True` for `FrozenSpan`.** `FrozenSpan` is an+ already-completed immutable span (used for links/export). It is not recording.+ Now returns `False`, aligning with `whenSpanIsRecording`.+- **Fix: `setGlobalTracerProvider` used non-atomic `writeIORef`.** Concurrent reads+ could see torn state. Now uses `atomicWriteIORef`.+- **Fix: `setGlobalMeterProvider` and `setGlobalLoggerProvider` used non-atomic+ `writeIORef`.** Same rationale as the tracer provider; now uses+ `atomicWriteIORef`.+- **Fix: noop observable instruments reported `enabled = True`.** The no-op+ `Meter` now reports `False` from observable `*Enabled` actions so callers can+ skip expensive measurement callbacks when no SDK is installed (aligned with+ synchronous noop instruments).+- **Fix: span mutation functions (`addAttribute`, `addAttributes`, `addEvent`,+ `addLink`, `setStatus`, `updateName`) used non-atomic `modifyIORef'`.**+ Concurrent calls could race and silently drop updates (e.g. lost events+ under concurrent `addEvent`). All now use `atomicModifyIORef'`, matching+ `endSpan` which was already atomic. Also fixed `withCarryOnProcessor` in+ `OpenTelemetry.Contrib.CarryOns`.+- **Fix: log record mutation (`addAttribute`, `addAttributes`) used non-atomic+ lazy `modifyIORef`.** Same race condition as span mutations, plus thunk+ buildup from the lazy variant. `modifyLogRecord` and `atomicModifyLogRecord`+ now both use `atomicModifyIORef'` (strict and atomic).+- **Fix: `forceFlushLoggerProvider` leaked async threads on timeout.** Same+ bug as `forceFlushTracerProvider`: processor flush asyncs were never+ cancelled when the timeout fired. Now calls `mapM_ cancel jobs`.+- **Fix: `shutdownLoggerProvider` aborted on first processor failure.** Used+ `wait` which re-throws on async exception, causing remaining processors to+ be skipped. Now uses `waitCatch` so all processors get a chance to shut down.+- **Fix: `Dropped` / no-processor spans discarded parent `TraceState`.** When+ creating a child span with a `Dropped` parent, or when no processors are+ configured, `traceState` was forced to `TraceState.empty`. Now inherits the+ parent's `traceState`, preserving vendor data in W3C `tracestate`.+- **Fix: `shutdownTracerProvider` was sequential.** Each processor shutdown had to+ complete before the next started. Now launches all shutdowns concurrently and+ waits for all via `waitCatch`.++### ReadableLogRecord true snapshot+- `ReadableLogRecord` is now a `data` type holding a snapshotted `ImmutableLogRecord`,+ scope, and resource: instead of a `newtype` wrapper around `ReadWriteLogRecord`.+- `mkReadableLogRecord` is now `IO` (reads the `IORef` at call time to produce a+ consistent point-in-time snapshot). Callers must update `let` bindings to `<-`.++### Span lifecycle enforcement+- `setStatus`, `addAttribute`, `addAttributes`, `addEvent`, `addLink`, and+ `updateName` now check `spanEnd` and silently skip mutations on ended spans.+ This aligns with the OTel spec: "the Span MUST NOT be modified after it ends."++### Exception handlers (Haskell extension)+- New `OpenTelemetry.Trace.ExceptionHandler` module with `ExceptionClassification`, `ExceptionResponse`, `ExceptionHandler` types+- Smart constructors: `ignoreExceptionType`, `ignoreExceptionMatching`, `recordExceptionType`, `recordExceptionMatching`, `classifyException`, `exitSuccessHandler`+- `TracerProvider` now has `tracerProviderExceptionHandlers` field for global exception classification+- `TracerOptions` now has `tracerExceptionHandlerOptions` field for per-library exception classification+- `inSpan''` consults exception handlers before setting Error status / recording events+- **Breaking**: `TracerOptions` changed from `newtype` to `data` (added `tracerExceptionHandlerOptions` field)++### Resource & InstrumentationLibrary ergonomics+- `instrumentationLibrary :: Text -> Text -> InstrumentationLibrary`: smart constructor (name + version)+- `withSchemaUrl :: Text -> InstrumentationLibrary -> InstrumentationLibrary`: composable modifier+- `withLibraryAttributes :: Attributes -> InstrumentationLibrary -> InstrumentationLibrary`: composable modifier+- `materializeResourcesWithSchema :: Maybe String -> Resource schema -> MaterializedResources`: set runtime schema URL+- `setMaterializedResourcesSchema :: Maybe String -> MaterializedResources -> MaterializedResources`: override schema++### Tracing+- `makeTracer` now wires `TracerOptions.tracerSchema` into `InstrumentationLibrary.librarySchemaUrl` (was ignored)+- Add `alwaysRecord` sampler: decorator that upgrades DROP to RECORD_ONLY so span processors see all spans without increasing export volume+- Fix `isValid` to require BOTH TraceId AND SpanId non-zero (was incorrectly valid if either was non-zero)+- Add `TraceState.lookup` for getting a value by key (MUST per spec)+- Add `spanExporterForceFlush` field to `SpanExporter` (MUST per spec); built-in simple/batch processors now call it++### Logs+- Add `logRecordEventName` field to `ImmutableLogRecord` and `eventName` to `LogRecordArguments`+- Add `loggerIsEnabled` function to check if a Logger has registered processors (SHOULD per spec)++### Metrics: full API coverage (new!)++This release introduces complete metrics support to hs-opentelemetry-api,+covering the entire synchronous and asynchronous instrument surface from the+OpenTelemetry specification.++- **Synchronous instruments**: `Counter`, `UpDownCounter`, `Histogram`, `Gauge`+- **Asynchronous (observable) instruments**: `ObservableCounter`,+ `ObservableUpDownCounter`, `ObservableGauge`, with `observable*Enabled`+ fields so callers can skip expensive measurement callbacks when no SDK is+ installed+- **Views**: `name` and `description` override fields on `View`;+ `filterAttributesByKeys` for attribute projection+- **Aggregation**: `AggregationTemporality` (delta / cumulative),+ `ExponentialHistogramDataPoint`, `MetricExportExponentialHistogram`+- **Exemplars**: `MetricExemplar` type; exemplar fields on all data point types+- **Advisory parameters**: `AdvisoryParameters` with optional+ `advisoryHistogramAggregation`; `HistogramAggregation` selects explicit+ bucket boundaries or exponential scale+- **Timestamps**: `startTimeUnixNano` on `SumDataPoint`, `HistogramDataPoint`,+ `ExponentialHistogramDataPoint`, `GaugeDataPoint`+- **Environment**: `lookupMetricExportIntervalMillis`, `MetricsExemplarFilter`,+ `lookupMetricsExemplarFilter`+- **Debug**: `OpenTelemetry.Debug.MetricExport` for human-readable rendering of+ metric export batches+ ## 0.3.1.0 - Add `tracerIsEnabled` function to check if a Tracer is enabled (helps avoid expensive operations when tracing is disabled)
LICENSE view
@@ -1,4 +1,4 @@-Copyright Ian Duncan (c) 2021+Copyright Ian Duncan (c) 2021-2026 All rights reserved.
README.md view
@@ -1,7 +1,8 @@ # OpenTelemetry API for Haskell -This package provides an interface for instrumentors to use when instrumenting-a library directly or implementing a wrapper API around an existing project.+[](https://hackage.haskell.org/package/hs-opentelemetry-api)++This package provides an interface for instrumentors to use when instrumenting a library directly or implementing a wrapper API around an existing project. The methods in this package can be safely called by libraries or end-user applications regardless of whether the application has registered an OpenTelemetry SDK configuration or not.
+ bench/Main.hs view
@@ -0,0 +1,319 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import Control.Monad (void)+import qualified Data.HashMap.Strict as H+import Data.IORef+import qualified Data.Text as T+import GHC.Clock (getMonotonicTimeNSec)+import OpenTelemetry.Attributes (defaultAttributeLimits, emptyAttributes)+import qualified OpenTelemetry.Attributes as A+import OpenTelemetry.Context (empty, insertSpan, lookupSpan)+import OpenTelemetry.Context.ThreadLocal (adjustContext, attachContext, getContext)+import OpenTelemetry.Internal.AtomicCounter+import OpenTelemetry.Processor.Span (FlushResult (..), ShutdownResult (..), SpanProcessor (..))+import OpenTelemetry.Trace.Core+import OpenTelemetry.Trace.Id (newSpanId, newTraceAndSpanId, newTraceId)+import OpenTelemetry.Trace.Id.Generator (IdGenerator (..))+import Test.Tasty.Bench+++realOptions :: TracerProviderOptions+realOptions =+ emptyTracerProviderOptions+ { tracerProviderOptionsIdGenerator = DefaultIdGenerator+ }+++main :: IO ()+main = do+ noopTp <- createTracerProvider [] emptyTracerProviderOptions+ let noopTracer = makeTracer noopTp (InstrumentationLibrary "bench" "1.0" "" emptyAttributes) tracerOptions++ dummyProcessor <- mkCountingProcessor+ activeTp <- createTracerProvider [dummyProcessor] realOptions+ let activeTracer = makeTracer activeTp (InstrumentationLibrary "bench" "1.0" "" emptyAttributes) tracerOptions++ calibRef <- newIORef ()++ defaultMain+ [ bgroup+ "calibration"+ [ bench "noop IO" $ whnfIO (pure ())+ , bench "IORef read" $ whnfIO (readIORef calibRef)+ , bench "IORef write" $ whnfIO (writeIORef calibRef ())+ , bench "atomicModifyIORef'" $ whnfIO (atomicModifyIORef' calibRef (\x -> (x, ())))+ , bench "getMonotonicTimeNSec" $ whnfIO getMonotonicTimeNSec+ ]+ , bgroup+ "createSpan"+ [ bench "no-op (no processors)" $+ whnfIO $+ createSpan noopTracer empty "bench-span" defaultSpanArguments+ , bench "active (with processor)" $+ whnfIO $+ createSpan activeTracer empty "bench-span" defaultSpanArguments+ , bench "active + parent context" $ whnfIO $ do+ parent <- createSpan activeTracer empty "parent" defaultSpanArguments+ let ctx = insertSpan parent empty+ createSpan activeTracer ctx "child" defaultSpanArguments+ ]+ , bgroup+ "endSpan"+ [ bench "no-op span" $ whnfIO $ do+ s <- createSpan noopTracer empty "s" defaultSpanArguments+ endSpan s Nothing+ , bench "active span" $ whnfIO $ do+ s <- createSpan activeTracer empty "s" defaultSpanArguments+ endSpan s Nothing+ ]+ , bgroup+ "isRecording"+ [ bench "Dropped" $ whnfIO $ do+ s <- createSpan noopTracer empty "s" defaultSpanArguments+ isRecording s+ , bench "live Span" $ whnfIO $ do+ s <- createSpan activeTracer empty "s" defaultSpanArguments+ isRecording s+ ]+ , bgroup+ "addAttribute"+ [ bench "on Dropped span" $ whnfIO $ do+ s <- createSpan noopTracer empty "s" defaultSpanArguments+ addAttribute s "key" ("value" :: T.Text)+ , bench "on live span (1 attr)" $ whnfIO $ do+ s <- createSpan activeTracer empty "s" defaultSpanArguments+ addAttribute s "key" ("value" :: T.Text)+ , bench "on live span (10 attrs sequential)" $ whnfIO $ do+ s <- createSpan activeTracer empty "s" defaultSpanArguments+ addAttribute s "k1" ("v" :: T.Text)+ addAttribute s "k2" ("v" :: T.Text)+ addAttribute s "k3" ("v" :: T.Text)+ addAttribute s "k4" ("v" :: T.Text)+ addAttribute s "k5" ("v" :: T.Text)+ addAttribute s "k6" ("v" :: T.Text)+ addAttribute s "k7" ("v" :: T.Text)+ addAttribute s "k8" ("v" :: T.Text)+ addAttribute s "k9" ("v" :: T.Text)+ addAttribute s "k10" ("v" :: T.Text)+ ]+ , bgroup+ "addAttributes-batch"+ [ bench "H.fromList 10 attrs" $ whnfIO $ do+ s <- createSpan activeTracer empty "s" defaultSpanArguments+ addAttributes s $+ H.fromList+ [ ("k1", "v")+ , ("k2", "v")+ , ("k3", "v")+ , ("k4", "v")+ , ("k5", "v")+ , ("k6", "v")+ , ("k7", "v")+ , ("k8", "v")+ , ("k9", "v")+ , ("k10", "v")+ ]+ , bench "AttrsBuilder 10 attrs" $ whnfIO $ do+ s <- createSpan activeTracer empty "s" defaultSpanArguments+ addAttributes' s $+ A.attr "k1" ("v" :: T.Text)+ <> A.attr "k2" ("v" :: T.Text)+ <> A.attr "k3" ("v" :: T.Text)+ <> A.attr "k4" ("v" :: T.Text)+ <> A.attr "k5" ("v" :: T.Text)+ <> A.attr "k6" ("v" :: T.Text)+ <> A.attr "k7" ("v" :: T.Text)+ <> A.attr "k8" ("v" :: T.Text)+ <> A.attr "k9" ("v" :: T.Text)+ <> A.attr "k10" ("v" :: T.Text)+ , bench "H.fromList 3 attrs" $ whnfIO $ do+ s <- createSpan activeTracer empty "s" defaultSpanArguments+ addAttributes s $+ H.fromList+ [ ("method", A.toAttribute ("GET" :: T.Text))+ , ("url", A.toAttribute ("https://example.com/api" :: T.Text))+ , ("status", A.toAttribute (200 :: Int))+ ]+ , bench "AttrsBuilder 3 attrs" $ whnfIO $ do+ s <- createSpan activeTracer empty "s" defaultSpanArguments+ addAttributes' s $+ A.attr "method" ("GET" :: T.Text)+ <> A.attr "url" ("https://example.com/api" :: T.Text)+ <> A.attr "status" (200 :: Int)+ ]+ , bgroup+ "Attributes-pure"+ [ bench "addAttribute x1" $+ whnf+ (\a -> A.addAttribute defaultAttributeLimits a "key" ("val" :: T.Text))+ emptyAttributes+ , bench "addAttribute x10 (same key)" $+ whnf+ ( \a ->+ let go !acc i =+ if i > (10 :: Int)+ then acc+ else go (A.addAttribute defaultAttributeLimits acc "key" ("val" :: T.Text)) (i + 1)+ in go a 1+ )+ emptyAttributes+ , bench "addAttribute x10 (distinct keys)" $+ whnf+ ( \a ->+ let go !acc i =+ if i > (10 :: Int)+ then acc+ else go (A.addAttribute defaultAttributeLimits acc (T.pack $ "key" <> show i) ("val" :: T.Text)) (i + 1)+ in go a 1+ )+ emptyAttributes+ , bench "addAttributes (HashMap) x5" $+ whnf+ ( \a ->+ A.addAttributes+ defaultAttributeLimits+ a+ (H.fromList [("k1", "v1"), ("k2", "v2"), ("k3", "v3"), ("k4", "v4"), ("k5", "v5")] :: H.HashMap T.Text A.Attribute)+ )+ emptyAttributes+ , bench "addAttributesFromBuilder x5" $+ whnf+ ( \a ->+ A.addAttributesFromBuilder+ defaultAttributeLimits+ a+ ( A.attr "k1" ("v1" :: T.Text)+ <> A.attr "k2" ("v2" :: T.Text)+ <> A.attr "k3" ("v3" :: T.Text)+ <> A.attr "k4" ("v4" :: T.Text)+ <> A.attr "k5" ("v5" :: T.Text)+ )+ )+ emptyAttributes+ ]+ , bgroup+ "context"+ [ bench "getContext" $ whnfIO getContext+ , bench "attachContext + getContext" $ whnfIO $ do+ _ <- attachContext empty+ getContext+ , bench "adjustContext (insertSpan)" $ whnfIO $ do+ s <- createSpan noopTracer empty "s" defaultSpanArguments+ adjustContext (insertSpan s)+ , bench "lookupSpan" $ whnf lookupSpan empty+ ]+ , bgroup+ "inSpan"+ [ bench "no-op tracer" $+ whnfIO $+ inSpan noopTracer "bench" defaultSpanArguments (pure ())+ , bench "active tracer" $+ whnfIO $+ inSpan activeTracer "bench" defaultSpanArguments (pure ())+ , bench "no-op (skip callerAttributes)" $+ whnfIO $+ inSpan'' noopTracer "bench" defaultSpanArguments (const $ pure ())+ , bench "active (skip callerAttributes)" $+ whnfIO $+ inSpan'' activeTracer "bench" defaultSpanArguments (const $ pure ())+ ]+ , bgroup+ "getSpanContext"+ [ bench "Dropped" $ whnfIO $ do+ s <- createSpan noopTracer empty "s" defaultSpanArguments+ getSpanContext s+ , bench "live Span" $ whnfIO $ do+ s <- createSpan activeTracer empty "s" defaultSpanArguments+ getSpanContext s+ ]+ , bgroup "realistic" $+ let httpSpan tracer = inSpan'' tracer "GET /api/users" defaultSpanArguments $ \s -> do+ addAttribute s ("http.method" :: T.Text) ("GET" :: T.Text)+ addAttribute s ("http.url" :: T.Text) ("https://example.com/api/users" :: T.Text)+ addAttribute s ("http.status_code" :: T.Text) (200 :: Int)+ pure ()+ dbSpan tracer = inSpan'' tracer "SELECT users" defaultSpanArguments {kind = Client} $ \s -> do+ addAttribute s ("db.system" :: T.Text) ("postgresql" :: T.Text)+ addAttribute s ("db.statement" :: T.Text) ("SELECT * FROM users WHERE id = $1" :: T.Text)+ addAttribute s ("db.name" :: T.Text) ("mydb" :: T.Text)+ addAttribute s ("db.operation" :: T.Text) ("SELECT" :: T.Text)+ addAttribute s ("db.sql.table" :: T.Text) ("users" :: T.Text)+ pure ()+ spanWithEvents tracer = inSpan'' tracer "process" defaultSpanArguments $ \s -> do+ addEvent+ s+ NewEvent+ { newEventName = "item.processed"+ , newEventAttributes = H.fromList [("item.id", A.toAttribute ("abc" :: T.Text))]+ , newEventTimestamp = Nothing+ }+ addEvent+ s+ NewEvent+ { newEventName = "item.validated"+ , newEventAttributes = H.fromList [("valid", A.toAttribute True)]+ , newEventTimestamp = Nothing+ }+ pure ()+ nestedSpans tracer = inSpan'' tracer "parent" defaultSpanArguments $ \_ ->+ inSpan'' tracer "child" defaultSpanArguments $ \_ ->+ inSpan'' tracer "grandchild" defaultSpanArguments $ \_ ->+ pure ()+ heavySpan tracer = inSpan'' tracer "heavy" defaultSpanArguments $ \s -> do+ addAttribute s ("k1" :: T.Text) ("v" :: T.Text)+ addAttribute s ("k2" :: T.Text) ("v" :: T.Text)+ addAttribute s ("k3" :: T.Text) ("v" :: T.Text)+ addAttribute s ("k4" :: T.Text) ("v" :: T.Text)+ addAttribute s ("k5" :: T.Text) ("v" :: T.Text)+ setStatus s (Error "something broke")+ addEvent+ s+ NewEvent+ { newEventName = "exception"+ , newEventAttributes =+ H.fromList+ [ ("exception.type", A.toAttribute ("IOException" :: T.Text))+ , ("exception.message", A.toAttribute ("file not found" :: T.Text))+ ]+ , newEventTimestamp = Nothing+ }+ pure ()+ bareSpan tracer = inSpan'' tracer "bare" defaultSpanArguments $ \_ -> pure ()+ in [ bench "bare span (create+end only)" $ whnfIO $ bareSpan activeTracer+ , bench "HTTP span (3 attrs)" $ whnfIO $ httpSpan activeTracer+ , bench "DB span (5 attrs)" $ whnfIO $ dbSpan activeTracer+ , bench "span + 2 events" $ whnfIO $ spanWithEvents activeTracer+ , bench "3-deep nested spans" $ whnfIO $ nestedSpans activeTracer+ , bench "heavy span (5 attrs + status + event)" $ whnfIO $ heavySpan activeTracer+ , bench "getSpanContext (live, isolated)" $ whnfIO $ do+ s <- createSpan activeTracer empty "s" defaultSpanArguments+ getSpanContext s+ ]+ , bgroup+ "rng"+ [ bench "SpanId (xoshiro)" $ whnfIO $ newSpanId DefaultIdGenerator+ , bench "TraceId (xoshiro)" $ whnfIO $ newTraceId DefaultIdGenerator+ , bench "SpanId+TraceId (3 separate)" $ whnfIO $ do+ !_ <- newTraceId DefaultIdGenerator+ newSpanId DefaultIdGenerator+ , bench "TraceId+SpanId (cmm primop)" $+ whnfIO $+ newTraceAndSpanId DefaultIdGenerator+ ]+ ]+++mkCountingProcessor :: IO SpanProcessor+mkCountingProcessor = do+ ref <- newAtomicCounter 0+ pure+ SpanProcessor+ { spanProcessorOnStart = \_ _ -> pure ()+ , spanProcessorOnEnd = \_ -> void $ incrAtomicCounter ref+ , spanProcessorShutdown = pure ShutdownSuccess+ , spanProcessorForceFlush = pure FlushSuccess+ }
+ cbits/hs_otel_hex.c view
@@ -0,0 +1,428 @@+#include "hs_otel_hex.h"++#include <stdint.h>+#include <string.h>++/*+ * Hex encode/decode specialized for OpenTelemetry trace & span IDs.+ *+ * TraceId: 16 bytes <-> 32 hex chars+ * SpanId: 8 bytes <-> 16 hex chars+ *+ * Encoding hot path uses SIMD where available:+ * x86_64 — SSSE3 (pshufb), available on all x86_64 since ~2006+ * aarch64 — NEON (vtbl), always available+ * fallback — scalar with lookup table+ *+ * Decoding uses a branchless scalar loop with a 256-byte lookup table.+ * The loop accumulates an error flag via bitwise OR, producing a single+ * branch at the end.+ */++/* ── Encode lookup table ─────────────────────────────────────────────── */++static const char enc_lut[] = "0123456789abcdef";++/* ── Decode lookup table ─────────────────────────────────────────────── */++static const int8_t dec_lut[256] = {+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, /* 0x00-0x0f */+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, /* 0x10-0x1f */+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, /* 0x20-0x2f */+ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,-1,-1,-1,-1,-1,-1, /* 0x30-0x3f */+ -1,10,11,12,13,14,15,-1,-1,-1,-1,-1,-1,-1,-1,-1, /* 0x40-0x4f */+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, /* 0x50-0x5f */+ -1,10,11,12,13,14,15,-1,-1,-1,-1,-1,-1,-1,-1,-1, /* 0x60-0x6f */+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, /* 0x70-0x7f */+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, /* 0x80-0x8f */+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, /* 0x90-0x9f */+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, /* 0xa0-0xaf */+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, /* 0xb0-0xbf */+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, /* 0xc0-0xcf */+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, /* 0xd0-0xdf */+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, /* 0xe0-0xef */+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1 /* 0xf0-0xff */+};++/* ── Scalar encode ───────────────────────────────────────────────────── */++static inline void encode_hex_scalar(const uint8_t *src, uint8_t *dst, size_t n) {+ for (size_t i = 0; i < n; i++) {+ dst[2 * i ] = enc_lut[src[i] >> 4];+ dst[2 * i + 1] = enc_lut[src[i] & 0x0f];+ }+}++/* ── Branchless scalar decode ────────────────────────────────────────── */++static inline int decode_hex_scalar(const uint8_t *src, uint8_t *dst,+ size_t dst_len) {+ int8_t err = 0;+ for (size_t i = 0; i < dst_len; i++) {+ int8_t hi = dec_lut[src[2 * i ]];+ int8_t lo = dec_lut[src[2 * i + 1]];+ err |= (hi | lo);+ dst[i] = (uint8_t)((hi << 4) | lo);+ }+ return err < 0 ? -1 : 0;+}++/* ── Platform-specific SIMD decode ───────────────────────────────────── */++/*+ * Lemire/Muła-style SIMD hex decode.+ *+ * Decodes 16 hex ASCII chars → 8 raw bytes in one SIMD pass:+ * 1. Force lowercase via OR 0x20 (digits unchanged, upper→lower)+ * 2. Compute digit (input - '0') and alpha ((input|0x20) - 'a' + 10)+ * 3. Validate ranges: digit in [0,9] OR alpha in [10,15]+ * 4. Pack nibble pairs via multiply-add: (hi_nib << 4) | lo_nib+ */++#if defined(HEX_ARCH_X86_64)++__attribute__((target("ssse3")))+static int decode_hex_ssse3_16(const uint8_t *src, uint8_t *dst) {+ __m128i input = _mm_loadu_si128((const __m128i *)src);++ __m128i lower = _mm_or_si128(input, _mm_set1_epi8(0x20));++ __m128i digit = _mm_sub_epi8(input, _mm_set1_epi8(0x30));+ __m128i alpha = _mm_sub_epi8(lower, _mm_set1_epi8(0x57));++ __m128i nine = _mm_set1_epi8(9);+ __m128i ten = _mm_set1_epi8(10);+ __m128i fifteen = _mm_set1_epi8(15);++ __m128i is_digit = _mm_cmpeq_epi8(_mm_min_epu8(digit, nine), digit);+ __m128i is_alpha = _mm_and_si128(+ _mm_cmpeq_epi8(_mm_max_epu8(alpha, ten), alpha),+ _mm_cmpeq_epi8(_mm_min_epu8(alpha, fifteen), alpha));++ if (_mm_movemask_epi8(_mm_or_si128(is_digit, is_alpha)) != 0xFFFF)+ return -1;++ __m128i nibbles = _mm_or_si128(+ _mm_and_si128(is_digit, digit),+ _mm_andnot_si128(is_digit, alpha));++ /* Pack pairs: _mm_maddubs_epi16 with [16,1,16,1,...] */+ __m128i packed16 = _mm_maddubs_epi16(nibbles, _mm_set1_epi16(0x0110));+ __m128i packed8 = _mm_packus_epi16(packed16, _mm_setzero_si128());++ _mm_storel_epi64((__m128i *)dst, packed8);+ return 0;+}++#elif defined(HEX_ARCH_AARCH64)++static int decode_hex_neon_16(const uint8_t *src, uint8_t *dst) {+ uint8x16_t input = vld1q_u8(src);++ uint8x16_t lower = vorrq_u8(input, vdupq_n_u8(0x20));++ uint8x16_t digit = vsubq_u8(input, vdupq_n_u8(0x30));+ uint8x16_t alpha = vsubq_u8(lower, vdupq_n_u8(0x57));++ uint8x16_t is_digit = vcleq_u8(digit, vdupq_n_u8(9));+ uint8x16_t is_alpha = vandq_u8(+ vcgeq_u8(alpha, vdupq_n_u8(10)),+ vcleq_u8(alpha, vdupq_n_u8(15)));++ if (vminvq_u8(vorrq_u8(is_digit, is_alpha)) != 0xFF)+ return -1;++ uint8x16_t nibbles = vbslq_u8(is_digit, digit, alpha);++ /* Pack nibble pairs: separate even/odd, shift-or */+ uint8x16x2_t uzp = vuzpq_u8(nibbles, nibbles);+ uint8x8_t hi = vget_low_u8(uzp.val[0]);+ uint8x8_t lo = vget_low_u8(uzp.val[1]);++ vst1_u8(dst, vorr_u8(vshl_n_u8(hi, 4), lo));+ return 0;+}++#endif++/* ── Platform-specific SIMD encode ───────────────────────────────────── */++#if defined(HEX_ARCH_X86_64)++/*+ * SSSE3 encode: pshufb as a 4-bit → ASCII lookup.+ *+ * For 16-byte TraceId, one 128-bit load covers the entire input.+ * Split each byte into high/low nibbles, look up hex chars, interleave,+ * store 32 bytes.+ */+__attribute__((target("ssse3")))+static void encode_hex_ssse3_16(const uint8_t *src, uint8_t *dst) {+ __m128i input = _mm_loadu_si128((const __m128i *)src);+ __m128i hex_lut = _mm_setr_epi8('0','1','2','3','4','5','6','7',+ '8','9','a','b','c','d','e','f');+ __m128i mask_lo = _mm_set1_epi8(0x0f);++ __m128i lo = _mm_and_si128(input, mask_lo);+ __m128i hi = _mm_and_si128(_mm_srli_epi16(input, 4), mask_lo);++ __m128i hex_lo = _mm_shuffle_epi8(hex_lut, lo);+ __m128i hex_hi = _mm_shuffle_epi8(hex_lut, hi);++ _mm_storeu_si128((__m128i *)(dst ), _mm_unpacklo_epi8(hex_hi, hex_lo));+ _mm_storeu_si128((__m128i *)(dst + 16), _mm_unpackhi_epi8(hex_hi, hex_lo));+}++/*+ * SpanId: load 8 bytes into the low half of an XMM register.+ * After nibble split + pshufb, unpacklo gives 16 output bytes.+ */+__attribute__((target("ssse3")))+static void encode_hex_ssse3_8(const uint8_t *src, uint8_t *dst) {+ __m128i input = _mm_loadl_epi64((const __m128i *)src);+ __m128i hex_lut = _mm_setr_epi8('0','1','2','3','4','5','6','7',+ '8','9','a','b','c','d','e','f');+ __m128i mask_lo = _mm_set1_epi8(0x0f);++ __m128i lo = _mm_and_si128(input, mask_lo);+ __m128i hi = _mm_and_si128(_mm_srli_epi16(input, 4), mask_lo);++ __m128i hex_lo = _mm_shuffle_epi8(hex_lut, lo);+ __m128i hex_hi = _mm_shuffle_epi8(hex_lut, hi);++ _mm_storeu_si128((__m128i *)dst, _mm_unpacklo_epi8(hex_hi, hex_lo));+}++#elif defined(HEX_ARCH_AARCH64)++/*+ * NEON encode: vqtbl1q_u8 as a 4-bit → ASCII lookup (same idea as pshufb).+ */+static void encode_hex_neon_16(const uint8_t *src, uint8_t *dst) {+ uint8x16_t input = vld1q_u8(src);+ static const uint8_t lut_data[16] = {+ '0','1','2','3','4','5','6','7',+ '8','9','a','b','c','d','e','f'+ };+ uint8x16_t hex_lut = vld1q_u8(lut_data);++ uint8x16_t lo = vandq_u8(input, vdupq_n_u8(0x0f));+ uint8x16_t hi = vshrq_n_u8(input, 4);++ uint8x16_t hex_lo = vqtbl1q_u8(hex_lut, lo);+ uint8x16_t hex_hi = vqtbl1q_u8(hex_lut, hi);++ uint8x16x2_t zipped = vzipq_u8(hex_hi, hex_lo);+ vst1q_u8(dst, zipped.val[0]);+ vst1q_u8(dst + 16, zipped.val[1]);+}++static void encode_hex_neon_8(const uint8_t *src, uint8_t *dst) {+ uint8x8_t input = vld1_u8(src);+ static const uint8_t lut_data[16] = {+ '0','1','2','3','4','5','6','7',+ '8','9','a','b','c','d','e','f'+ };+ uint8x16_t hex_lut = vld1q_u8(lut_data);++ uint8x8_t lo = vand_u8(input, vdup_n_u8(0x0f));+ uint8x8_t hi = vshr_n_u8(input, 4);++ uint8x8_t hex_lo = vqtbl1_u8(hex_lut, lo);+ uint8x8_t hex_hi = vqtbl1_u8(hex_lut, hi);++ uint8x8x2_t zipped = vzip_u8(hex_hi, hex_lo);+ vst1_u8(dst, zipped.val[0]);+ vst1_u8(dst + 8, zipped.val[1]);+}++#endif++/* ── Public API ──────────────────────────────────────────────────────── */++void hs_otel_encode_trace_id(const uint8_t *src, uint8_t *dst) {+#if defined(HEX_ARCH_X86_64)+ encode_hex_ssse3_16(src, dst);+#elif defined(HEX_ARCH_AARCH64)+ encode_hex_neon_16(src, dst);+#else+ encode_hex_scalar(src, dst, 16);+#endif+}++void hs_otel_encode_span_id(const uint8_t *src, uint8_t *dst) {+#if defined(HEX_ARCH_X86_64)+ encode_hex_ssse3_8(src, dst);+#elif defined(HEX_ARCH_AARCH64)+ encode_hex_neon_8(src, dst);+#else+ encode_hex_scalar(src, dst, 8);+#endif+}++void hs_otel_encode_hex(const uint8_t *src, uint8_t *dst, size_t src_len) {+ encode_hex_scalar(src, dst, src_len);+}++int hs_otel_decode_trace_id(const uint8_t *src, uint8_t *dst) {+#if defined(HEX_ARCH_X86_64)+ if (decode_hex_ssse3_16(src, dst) != 0) return -1;+ return decode_hex_ssse3_16(src + 16, dst + 8);+#elif defined(HEX_ARCH_AARCH64)+ if (decode_hex_neon_16(src, dst) != 0) return -1;+ return decode_hex_neon_16(src + 16, dst + 8);+#else+ return decode_hex_scalar(src, dst, 16);+#endif+}++int hs_otel_decode_span_id(const uint8_t *src, uint8_t *dst) {+#if defined(HEX_ARCH_X86_64)+ return decode_hex_ssse3_16(src, dst);+#elif defined(HEX_ARCH_AARCH64)+ return decode_hex_neon_16(src, dst);+#else+ return decode_hex_scalar(src, dst, 8);+#endif+}++int hs_otel_decode_hex(const uint8_t *src, uint8_t *dst, size_t dst_len) {+ return decode_hex_scalar(src, dst, dst_len);+}++/* ── Traceparent parser ─────────────────────────────────────────────── */++/*+ * Parse W3C traceparent: "VV-{32hex}-{16hex}-FF" (55 bytes for v00).+ *+ * Output is an aligned uint64_t[4]:+ * out[0] = trace_id high Word64 (native byte order)+ * out[1] = trace_id low Word64 (native byte order)+ * out[2] = span_id Word64 (native byte order)+ * out[3] = (version << 8) | flags+ *+ * Returns: 0 = success, -1 = format error, -2 = all-zero trace,+ * -3 = all-zero span+ */++/* W3C TC2: traceparent hex fields must use HEXDIGLC (lowercase only) */+static inline int is_lowercase_hex(const uint8_t *src, size_t len) {+ for (size_t i = 0; i < len; i++) {+ uint8_t c = src[i];+ if ((c >= '0' && c <= '9') || (c >= 'a' && c <= 'f')) continue;+ return -1;+ }+ return 0;+}++int hs_otel_parse_traceparent(const uint8_t *src, size_t len, uint64_t out[4]) {+ if (len < 55) return -1;++ /* Validate dashes */+ if (src[2] != '-' || src[35] != '-' || src[52] != '-') return -1;++ /* W3C TC2: all hex fields must be lowercase (HEXDIGLC) */+ if (is_lowercase_hex(src, 2) != 0) return -1; /* version */+ if (is_lowercase_hex(src + 3, 32) != 0) return -1; /* trace-id */+ if (is_lowercase_hex(src + 36, 16) != 0) return -1; /* span-id */+ if (is_lowercase_hex(src + 53, 2) != 0) return -1; /* flags */++ /* Decode version (2 hex → 1 byte) */+ uint8_t ver;+ if (decode_hex_scalar(src, &ver, 1) != 0) return -1;++ /* W3C TC2: version ff is invalid */+ if (ver == 0xFF) return -1;++ /* Version 00 requires exactly 55 bytes */+ if (ver == 0 && len != 55) return -1;++ /* Decode trace_id (32 hex → 16 bytes) */+ uint8_t trace_buf[16] __attribute__((aligned(16)));+#if defined(HEX_ARCH_X86_64)+ if (decode_hex_ssse3_16(src + 3, trace_buf) != 0) return -1;+ if (decode_hex_ssse3_16(src + 3 + 16, trace_buf + 8) != 0) return -1;+#elif defined(HEX_ARCH_AARCH64)+ if (decode_hex_neon_16(src + 3, trace_buf) != 0) return -1;+ if (decode_hex_neon_16(src + 3 + 16, trace_buf + 8) != 0) return -1;+#else+ if (decode_hex_scalar(src + 3, trace_buf, 16) != 0) return -1;+#endif++ uint64_t hi, lo;+ memcpy(&hi, trace_buf, 8);+ memcpy(&lo, trace_buf + 8, 8);+ if (hi == 0 && lo == 0) return -2;++ /* Decode span_id (16 hex → 8 bytes) */+ uint8_t span_buf[8] __attribute__((aligned(8)));+#if defined(HEX_ARCH_X86_64)+ if (decode_hex_ssse3_16(src + 36, span_buf) != 0) return -1;+#elif defined(HEX_ARCH_AARCH64)+ if (decode_hex_neon_16(src + 36, span_buf) != 0) return -1;+#else+ if (decode_hex_scalar(src + 36, span_buf, 8) != 0) return -1;+#endif++ uint64_t sid;+ memcpy(&sid, span_buf, 8);+ if (sid == 0) return -3;++ /* Decode flags (2 hex → 1 byte) */+ uint8_t fl;+ if (decode_hex_scalar(src + 53, &fl, 1) != 0) return -1;++ out[0] = hi;+ out[1] = lo;+ out[2] = sid;+ out[3] = ((uint64_t)ver << 8) | (uint64_t)fl;+ return 0;+}++/* ── Traceparent encoder ────────────────────────────────────────────── */++/*+ * Encode traceparent: writes exactly 55 bytes to dst.+ * Format: "VV-{32hex}-{16hex}-FF"+ *+ * Input: trace_hi, trace_lo, span_id as native-order Word64;+ * version and flags as bytes.+ */+void hs_otel_encode_traceparent(+ uint64_t trace_hi, uint64_t trace_lo,+ uint64_t span_w,+ uint8_t version, uint8_t flags,+ uint8_t *dst)+{+ /* "VV-" */+ encode_hex_scalar(&version, dst, 1);+ dst[2] = '-';++ /* "{32hex}-" */+ uint8_t trace_buf[16];+ memcpy(trace_buf, &trace_hi, 8);+ memcpy(trace_buf + 8, &trace_lo, 8);+#if defined(HEX_ARCH_X86_64)+ encode_hex_ssse3_16(trace_buf, dst + 3);+#elif defined(HEX_ARCH_AARCH64)+ encode_hex_neon_16(trace_buf, dst + 3);+#else+ encode_hex_scalar(trace_buf, dst + 3, 16);+#endif+ dst[35] = '-';++ /* "{16hex}-" */+ uint8_t span_buf[8];+ memcpy(span_buf, &span_w, 8);+#if defined(HEX_ARCH_X86_64)+ encode_hex_ssse3_8(span_buf, dst + 36);+#elif defined(HEX_ARCH_AARCH64)+ encode_hex_neon_8(span_buf, dst + 36);+#else+ encode_hex_scalar(span_buf, dst + 36, 8);+#endif+ dst[52] = '-';++ /* "FF" */+ encode_hex_scalar(&flags, dst + 53, 1);+}
+ cbits/hs_otel_rng.c view
@@ -0,0 +1,140 @@+/*+ * RNG for OpenTelemetry trace and span ID generation.+ *+ * xoshiro256++ per OS thread, seeded once from the platform CSPRNG.+ * ~2-3x faster than a CSPRNG pool path because there is no shared+ * state, no atomics, and no syscalls after initial seed.+ * Fork-safe via pthread_atfork (reseeds in child).+ *+ * Platform CSPRNG (used only for seeding):+ * macOS/BSD — arc4random_buf (userspace ChaCha20, lock-free)+ * Linux — getrandom(2) (kernel CSPRNG, no fd needed)+ * Windows — BCryptGenRandom (CNG, no provider handle needed)+ * fallback — /dev/urandom+ */++#include <stdint.h>+#include <stddef.h>+#include <string.h>++#if defined(_WIN32) || defined(_WIN64)+ #define USE_BCRYPT 1+ #define WIN32_LEAN_AND_MEAN+ #include <windows.h>+ #include <bcrypt.h>+#elif defined(__APPLE__) || defined(__FreeBSD__) || defined(__OpenBSD__) || defined(__NetBSD__)+ #define USE_ARC4RANDOM 1+ #include <stdlib.h>+#elif defined(__linux__)+ #define USE_GETRANDOM 1+ #include <sys/random.h>+ #include <errno.h>+#else+ #define USE_DEVURANDOM 1+ #include <stdio.h>+#endif++#if defined(_MSC_VER)+ #define THREAD_LOCAL __declspec(thread)+#else+ #define THREAD_LOCAL __thread+ #include <pthread.h>+#endif++/* ── Platform CSPRNG (seed source only) ──────────────────────────────── */++static int fill_random_platform(uint8_t *buf, size_t n) {+#if defined(USE_BCRYPT)+ NTSTATUS status = BCryptGenRandom(+ NULL, buf, (ULONG)n, BCRYPT_USE_SYSTEM_PREFERRED_RNG);+ return BCRYPT_SUCCESS(status) ? 0 : -1;+#elif defined(USE_ARC4RANDOM)+ arc4random_buf(buf, n);+ return 0;+#elif defined(USE_GETRANDOM)+ while (n > 0) {+ ssize_t got = getrandom(buf, n, 0);+ if (got < 0) {+ if (errno == EINTR) continue;+ return -1;+ }+ buf += got;+ n -= (size_t)got;+ }+ return 0;+#elif defined(USE_DEVURANDOM)+ FILE *f = fopen("/dev/urandom", "rb");+ if (!f) return -1;+ size_t r = fread(buf, 1, n, f);+ fclose(f);+ return (r == n) ? 0 : -1;+#endif+}++/* ── xoshiro256++ (thread-local fast PRNG) ───────────────────────────── */+/*+ * Reference: https://prng.di.unimi.it/xoshiro256plusplus.c+ * by David Blackman and Sebastiano Vigna (vigna@acm.org), public domain.+ *+ * 256-bit state, 64-bit output, period 2^256-1. Passes BigCrush and+ * PractRand. Each OS thread gets its own state seeded from the platform+ * CSPRNG, so there is zero contention between threads.+ */++static inline uint64_t rotl64(uint64_t x, int k) {+ return (x << k) | (x >> (64 - k));+}++static THREAD_LOCAL uint64_t xoshiro_s[4];+static THREAD_LOCAL int xoshiro_init;++static void xoshiro_seed(void) {+ fill_random_platform((uint8_t *)xoshiro_s, sizeof(xoshiro_s));+ if (xoshiro_s[0] == 0 && xoshiro_s[1] == 0 &&+ xoshiro_s[2] == 0 && xoshiro_s[3] == 0) {+ xoshiro_s[0] = 1;+ }+ xoshiro_init = 1;+}++static inline uint64_t xoshiro256pp(void) {+ if (__builtin_expect(!xoshiro_init, 0)) xoshiro_seed();++ const uint64_t result = rotl64(xoshiro_s[0] + xoshiro_s[3], 23) + xoshiro_s[0];+ const uint64_t t = xoshiro_s[1] << 17;++ xoshiro_s[2] ^= xoshiro_s[0];+ xoshiro_s[3] ^= xoshiro_s[1];+ xoshiro_s[1] ^= xoshiro_s[2];+ xoshiro_s[0] ^= xoshiro_s[3];+ xoshiro_s[2] ^= t;+ xoshiro_s[3] = rotl64(xoshiro_s[3], 45);++ return result;+}++/* Fork safety: force reseed in child process so parent and child don't+ * share PRNG state (which would produce duplicate IDs). */+#if !defined(_WIN32) && !defined(_WIN64)+static void xoshiro_atfork_child(void) {+ xoshiro_init = 0;+}++__attribute__((constructor))+static void xoshiro_register_atfork(void) {+ pthread_atfork(NULL, NULL, xoshiro_atfork_child);+}+#endif++uint64_t hs_otel_xoshiro_next(void) {+ return xoshiro256pp();+}++/* Generate TraceId (2 words) + SpanId (1 word) in a single FFI call.+ * Used for root spans where both IDs need generating. Saves 2 FFI+ * round-trips vs 3 separate hs_otel_xoshiro_next calls. */+void hs_otel_xoshiro_trace_and_span(uint64_t *trace_hi, uint64_t *trace_lo, uint64_t *span_id) {+ *trace_hi = xoshiro256pp();+ *trace_lo = xoshiro256pp();+ *span_id = xoshiro256pp();+}
+ cbits/hs_otel_time.c view
@@ -0,0 +1,30 @@+#include <stdint.h>+#include <time.h>++/*+ * Fast wall-clock timestamp as nanoseconds since Unix epoch.+ *+ * Returns a single uint64_t, matching the OTLP wire format directly.+ * Platform-specific fast paths:+ * - macOS: clock_gettime_nsec_np avoids struct timespec entirely+ * - Linux: clock_gettime via vDSO (no syscall); one imul+add+ * - Other: portable clock_gettime fallback+ *+ * CLOCK_REALTIME never fails, so we skip errno checks.+ */++#if defined(__APPLE__)++uint64_t hs_otel_gettime_ns(void) {+ return clock_gettime_nsec_np(CLOCK_REALTIME);+}++#else++uint64_t hs_otel_gettime_ns(void) {+ struct timespec ts;+ clock_gettime(CLOCK_REALTIME, &ts);+ return (uint64_t)ts.tv_sec * 1000000000ULL + (uint64_t)ts.tv_nsec;+}++#endif
hs-opentelemetry-api.cabal view
@@ -1,12 +1,12 @@-cabal-version: 1.12+cabal-version: 1.22 --- This file has been generated from package.yaml by hpack version 0.37.0.+-- This file has been generated from package.yaml by hpack version 0.38.3. -- -- see: https://github.com/sol/hpack name: hs-opentelemetry-api-version: 0.3.1.0-synopsis: OpenTelemetry API for use by libraries for direct instrumentation or wrapper packages.+version: 1.0.0.0+synopsis: OpenTelemetry API for libraries to instrument code or build wrappers. description: Please see the README on GitHub at <https://github.com/iand675/hs-opentelemetry/tree/main/api#readme> category: OpenTelemetry, Telemetry, Monitoring, Observability, Metrics homepage: https://github.com/iand675/hs-opentelemetry#readme@@ -19,6 +19,7 @@ build-type: Simple extra-source-files: README.md+extra-doc-files: ChangeLog.md source-repository head@@ -28,29 +29,37 @@ library exposed-modules: OpenTelemetry.Attributes- OpenTelemetry.Attributes.Attribute- OpenTelemetry.Attributes.Key OpenTelemetry.Attributes.Map OpenTelemetry.Baggage OpenTelemetry.Common OpenTelemetry.Context+ OpenTelemetry.Context.Environment OpenTelemetry.Context.ThreadLocal+ OpenTelemetry.Context.ThreadLocal.Propagation OpenTelemetry.Contrib.CarryOns OpenTelemetry.Contrib.SpanTraversals+ OpenTelemetry.Debug.MetricExport OpenTelemetry.Environment OpenTelemetry.Exporter OpenTelemetry.Exporter.LogRecord+ OpenTelemetry.Exporter.Metric OpenTelemetry.Exporter.Span+ OpenTelemetry.Internal.AtomicBucketArray+ OpenTelemetry.Internal.AtomicCounter OpenTelemetry.Internal.Common.Types- OpenTelemetry.Internal.Logs.Core- OpenTelemetry.Internal.Logs.Types+ OpenTelemetry.Internal.Log.Core+ OpenTelemetry.Internal.Log.Types+ OpenTelemetry.Internal.Logging OpenTelemetry.Internal.Trace.Id+ OpenTelemetry.Log.Core OpenTelemetry.LogAttributes- OpenTelemetry.Logs.Core+ OpenTelemetry.Metric.Core+ OpenTelemetry.Metric.InstrumentName OpenTelemetry.Processor OpenTelemetry.Processor.LogRecord OpenTelemetry.Processor.Span OpenTelemetry.Propagator+ OpenTelemetry.Registry OpenTelemetry.Resource OpenTelemetry.Resource.Cloud OpenTelemetry.Resource.Container@@ -66,6 +75,7 @@ OpenTelemetry.Resource.Webengine OpenTelemetry.SemanticsConfig OpenTelemetry.Trace.Core+ OpenTelemetry.Trace.ExceptionHandler OpenTelemetry.Trace.Id OpenTelemetry.Trace.Id.Generator OpenTelemetry.Trace.Id.Generator.Dummy@@ -75,37 +85,43 @@ OpenTelemetry.Util other-modules: OpenTelemetry.Context.Types+ OpenTelemetry.Internal.Metric.Export+ OpenTelemetry.Internal.Metric.Types OpenTelemetry.Internal.Trace.Types+ OpenTelemetry.Internal.UnpackedMaybe Paths_hs_opentelemetry_api+ reexported-modules:+ OpenTelemetry.Attributes.Attribute+ , OpenTelemetry.Attributes.Key hs-source-dirs: src default-extensions: OverloadedStrings RecordWildCards ghc-options: -Wall+ include-dirs:+ include+ install-includes:+ hs_otel_hex.h+ c-sources:+ cbits/hs_otel_hex.c+ cbits/hs_otel_rng.c+ cbits/hs_otel_time.c build-depends: async- , attoparsec , base >=4.7 && <5- , binary , bytestring- , charset- , clock , hashable- , http-types- , memory- , mtl- , regex-tdfa- , safe-exceptions+ , hs-opentelemetry-api-types ==1.0.*+ , hs-opentelemetry-semantic-conventions >=1.40 && <2 , template-haskell , text- , thread-utils-context ==0.3.*+ , thread-utils-context >=0.3 && <0.5 , transformers , unliftio-core , unordered-containers , vault , vector- , vector-builder default-language: Haskell2010 test-suite hs-opentelemetry-api-test@@ -114,14 +130,28 @@ other-modules: OpenTelemetry.AttributesSpec OpenTelemetry.BaggageSpec+ OpenTelemetry.Context.EnvironmentSpec+ OpenTelemetry.Context.PropagationSpec+ OpenTelemetry.Context.ThreadLocalSpec+ OpenTelemetry.ContextSpec+ OpenTelemetry.Contrib.CarryOnsSpec+ OpenTelemetry.Contrib.SpanTraversalsSpec+ OpenTelemetry.EnvironmentSpec OpenTelemetry.InstrumentationLibrarySpec- OpenTelemetry.Logs.CoreSpec+ OpenTelemetry.Internal.LoggingSpec+ OpenTelemetry.Log.CoreSpec+ OpenTelemetry.MetricSpec+ OpenTelemetry.PropagatorSpec+ OpenTelemetry.RegistrySpec OpenTelemetry.ResourceSpec OpenTelemetry.SemanticsConfigSpec+ OpenTelemetry.Trace.ExceptionHandlerSpec+ OpenTelemetry.Trace.IdCodecSpec+ OpenTelemetry.Trace.MonadSpec OpenTelemetry.Trace.SamplerSpec OpenTelemetry.Trace.TraceFlagsSpec OpenTelemetry.Trace.TracerSpec- Paths_hs_opentelemetry_api+ OpenTelemetry.Trace.UtilsSpec hs-source-dirs: test default-extensions:@@ -129,12 +159,37 @@ RecordWildCards ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends:- base >=4.7 && <5+ async+ , base >=4.7 && <5+ , bytestring+ , hedgehog , hs-opentelemetry-api , hspec- , mtl+ , hspec-hedgehog , text+ , transformers , unliftio-core+ , unordered-containers+ , vector+ default-language: Haskell2010++benchmark hs-opentelemetry-api-bench+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ Paths_hs_opentelemetry_api+ hs-source-dirs:+ bench+ default-extensions:+ OverloadedStrings+ RecordWildCards+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2+ build-depends:+ base >=4.7 && <5+ , containers+ , hs-opentelemetry-api+ , tasty-bench+ , text , unordered-containers , vector , vector-builder
+ include/hs_otel_hex.h view
@@ -0,0 +1,64 @@+#ifndef HS_OTEL_HEX_H+#define HS_OTEL_HEX_H++#include <stddef.h>+#include <stdint.h>++/* Platform detection for SIMD paths */+#if defined(__x86_64__) || defined(_M_X64)+#define HEX_ARCH_X86_64 1+#include <immintrin.h>+#elif defined(__aarch64__) || defined(_M_ARM64)+#define HEX_ARCH_AARCH64 1+#include <arm_neon.h>+#endif++/* Encode exactly 16 bytes (TraceId) → 32 hex chars. SIMD where available. */+void hs_otel_encode_trace_id(const uint8_t *src, uint8_t *dst);++/* Encode exactly 8 bytes (SpanId) → 16 hex chars. SIMD where available. */+void hs_otel_encode_span_id(const uint8_t *src, uint8_t *dst);++/* Encode arbitrary length (scalar fallback). */+void hs_otel_encode_hex(const uint8_t *src, uint8_t *dst, size_t src_len);++/* Decode 32 hex chars → 16 bytes. Returns 0 on success, -1 on invalid hex. */+int hs_otel_decode_trace_id(const uint8_t *src, uint8_t *dst);++/* Decode 16 hex chars → 8 bytes. Returns 0 on success, -1 on invalid hex. */+int hs_otel_decode_span_id(const uint8_t *src, uint8_t *dst);++/* Decode 2*dst_len hex chars → dst_len bytes. Returns 0 or -1. */+int hs_otel_decode_hex(const uint8_t *src, uint8_t *dst, size_t dst_len);++/* ── W3C traceparent codec ───────────────────────────────────────────── */++/* Parse "VV-{32hex}-{16hex}-FF" into an aligned uint64_t[4]:+ * out[0] = trace_hi, out[1] = trace_lo, out[2] = span_id,+ * out[3] = (version << 8) | flags+ * Returns: 0=ok, -1=format, -2=zero-trace, -3=zero-span */+int hs_otel_parse_traceparent(const uint8_t *src, size_t len, uint64_t out[4]);++/* Encode 55-byte traceparent from Word64 trace/span + version/flags. */+void hs_otel_encode_traceparent(+ uint64_t trace_hi, uint64_t trace_lo,+ uint64_t span_w,+ uint8_t version, uint8_t flags,+ uint8_t *dst);++/* ── Fast PRNG (xoshiro256++, thread-local) ──────────────────────────── */++/* Generate 16 bytes via thread-local xoshiro256++. NOT crypto-secure.+ * Seeded from the platform CSPRNG on first use per OS thread. Returns 0. */+int hs_otel_gen_trace_id_fast(uint8_t *dst);++/* Generate 8 bytes via thread-local xoshiro256++. Returns 0. */+int hs_otel_gen_span_id_fast(uint8_t *dst);++/* Return a single xoshiro256++ output (64 bits). Ensures lazy init. */+uint64_t hs_otel_xoshiro_next(void);++/* Fill n bytes via thread-local xoshiro256++. Returns 0. */+int hs_otel_fill_fast_random(uint8_t *dst, size_t n);++#endif /* HS_OTEL_HEX_H */
src/OpenTelemetry/Attributes.hs view
@@ -5,31 +5,72 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE StrictData #-} {- |- Module : OpenTelemetry.Attributes- Copyright : (c) Ian Duncan, 2021- License : BSD-3- Description : Key-value pair metadata used in 'OpenTelemetry.Trace.Span's, 'OpenTelemetry.Trace.Link's, and 'OpenTelemetry.Trace.Event's- Maintainer : Ian Duncan- Stability : experimental- Portability : non-portable (GHC extensions)+Module : OpenTelemetry.Attributes+Copyright : (c) Ian Duncan, 2021-2026+License : BSD-3+Description : Key-value pair metadata for spans, events, links, and resources+Stability : experimental - An Attribute is a key-value pair, which MUST have the following properties:+= Overview - - The attribute key MUST be a non-null and non-empty string.- - The attribute value is either:- - A primitive type: string, boolean, double precision floating point (IEEE 754-1985) or signed 64 bit integer.- - An array of primitive type values. The array MUST be homogeneous, i.e., it MUST NOT contain values of different types. For protocols that do not natively support array values such values SHOULD be represented as JSON strings.- - Attribute values expressing a numerical value of zero, an empty string, or an empty array are considered meaningful and MUST be stored and passed on to processors / exporters.+Attributes are key-value pairs attached to spans, events, links, and+resources. Keys are 'Text' strings; values are one of the OpenTelemetry+primitive types: 'Text', 'Bool', 'Int64', 'Double', or arrays thereof.++= Quick example++@+import OpenTelemetry.Attributes++-- On a span:+addAttribute span "http.request.method" (toAttribute "GET")+addAttribute span "http.response.status_code" (toAttribute (200 :: Int))+addAttributes span+ [ ("user.id", toAttribute "abc123")+ , ("user.role", toAttribute "admin")+ ]++-- Using the builder API:+let attrs = buildAttrs $+ attr "http.request.method" ("GET" :: Text)+ <> attr "http.response.status_code" (200 :: Int)+@++= Typed attribute keys++For type-safe attribute access, use 'AttributeKey':++@+import OpenTelemetry.Attributes.Key (AttributeKey(..), unkey)+import qualified OpenTelemetry.SemanticConventions as SC++let attrs' = addAttributeByKey defaultAttributeLimits attrs SC.http_request_method "GET"+lookupAttributeByKey attrs' SC.http_response_statusCode -- Maybe Int64+@++= Attribute limits++The SDK enforces limits on attribute count and value length, configured via+@OTEL_ATTRIBUTE_COUNT_LIMIT@ and @OTEL_ATTRIBUTE_VALUE_LENGTH_LIMIT@+environment variables. When limits are exceeded, attributes are dropped+(tracked by 'getDropped').++= Spec reference++<https://opentelemetry.io/docs/specs/otel/common/#attribute> -} module OpenTelemetry.Attributes ( Attributes, emptyAttributes,+ unsafeAttributesFromMap, addAttribute, addAttributeByKey, addAttributes,+ addAttributesFromBuilder, lookupAttribute, lookupAttributeByKey, getAttributeMap,@@ -45,18 +86,28 @@ AttributeKey (..), module Key, + -- * Attribute builder+ AttrsBuilder,+ attr,+ optAttr,+ (.@),+ (.@?),+ buildAttrs,+ -- * Attribute limits AttributeLimits (..), defaultAttributeLimits, -- * Unsafe utilities unsafeAttributesFromListIgnoringLimits,+ unsafeAttributesFromMapIgnoringLimits, unsafeMergeAttributesIgnoringLimits, ) where import Data.Data (Data)-import qualified Data.HashMap.Strict as H+import qualified Data.HashMap.Lazy as H import Data.Hashable (Hashable)+import Data.Maybe (isJust) import Data.Text (Text) import qualified Data.Text as T import GHC.Generics (Generic)@@ -72,6 +123,8 @@ - 'attributeCountLimit': @Just 128@ - 'attributeLengthLimit': or @Nothing@++@since 0.0.1.0 -} defaultAttributeLimits :: AttributeLimits defaultAttributeLimits =@@ -81,6 +134,7 @@ } +-- | @since 0.0.1.0 data Attributes = Attributes { attributeMap :: !Map.AttributeMap , attributesCount :: {-# UNPACK #-} !Int@@ -92,40 +146,250 @@ instance Hashable Attributes +-- | @since 0.0.1.0 emptyAttributes :: Attributes emptyAttributes = Attributes mempty 0 0+{-# INLINE emptyAttributes #-} +{- | Build 'Attributes' directly from a pre-built 'AttributeMap', applying+count and length limits. Faster than @addAttributes limits emptyAttributes map@+because it skips the per-key membership check against an empty base map.++@since 0.4.0.0+-}+unsafeAttributesFromMap :: AttributeLimits -> Map.AttributeMap -> Attributes+unsafeAttributesFromMap AttributeLimits {..} m =+ let limitVal = case attributeLengthLimit of+ Nothing -> id+ Just limit -> limitLengths limit+ in case attributeCountLimit of+ Nothing ->+ let !m' = case attributeLengthLimit of+ Nothing -> m+ Just _ -> H.map limitVal m+ in Attributes m' (H.size m) 0+ Just limit_ ->+ let !sz = H.size m+ in if sz <= limit_+ then+ let !m' = case attributeLengthLimit of+ Nothing -> m+ Just _ -> H.map limitVal m+ in Attributes m' sz 0+ else+ let (!kept, !dropped) =+ H.foldlWithKey'+ ( \(!acc, !d) k v ->+ if H.size acc < limit_+ then (H.insert k (limitVal v) acc, d)+ else (acc, d + 1)+ )+ (H.empty, 0)+ m+ in Attributes kept (H.size kept) dropped+{-# INLINE unsafeAttributesFromMap #-}+++-- | @since 0.0.1.0 addAttribute :: (ToAttribute a) => AttributeLimits -> Attributes -> Text -> a -> Attributes-addAttribute AttributeLimits {..} Attributes {..} !k !v = case attributeCountLimit of- Nothing -> Attributes newAttrs newCount attributesDropped- Just limit_ ->- if newCount > limit_- then Attributes attributeMap attributesCount (attributesDropped + 1)- else Attributes newAttrs newCount attributesDropped- where- newAttrs = H.insert k (maybe id limitLengths attributeLengthLimit $ toAttribute v) attributeMap- newCount = H.size newAttrs-{-# INLINE addAttribute #-}+addAttribute AttributeLimits {..} Attributes {..} !k v =+ let attr = case attributeLengthLimit of+ Nothing -> toAttribute v+ Just limit -> limitLengths limit (toAttribute v)+ (!replacing, !newAttrs) = H.alterF (\old -> (isJust old, Just attr)) k attributeMap+ !newCount = if replacing then attributesCount else attributesCount + 1+ in case attributeCountLimit of+ Nothing -> Attributes newAttrs newCount attributesDropped+ Just limit_ ->+ if not replacing && newCount > limit_+ then Attributes attributeMap attributesCount (attributesDropped + 1)+ else Attributes newAttrs newCount attributesDropped+{-# INLINE [0] addAttribute #-} +-- | @since 0.0.1.0 addAttributeByKey :: (ToAttribute a) => AttributeLimits -> Attributes -> AttributeKey a -> a -> Attributes-addAttributeByKey limits attrs (AttributeKey k) !v = addAttribute limits attrs k v+addAttributeByKey limits attrs (AttributeKey k) v = addAttribute limits attrs k v+{-# INLINE addAttributeByKey #-} +-- Fuse two nested pure addAttribute calls into a single addAttributesFromBuilder pass.+-- Two H.alterF to one fold. Only fires in phases >=1 (before addAttribute inlines in phase 0).+{-# RULES+"addAttribute/addAttribute" forall lim attrs k1 v1 k2 v2.+ addAttribute lim (addAttribute lim attrs k1 v1) k2 v2 =+ addAttributesFromBuilder lim attrs (attr k1 v1 <> attr k2 v2)+ #-}+++-- | @since 0.0.1.0 addAttributes :: (ToAttribute a) => AttributeLimits -> Attributes -> H.HashMap Text a -> Attributes-addAttributes AttributeLimits {..} Attributes {..} attrs = case attributeCountLimit of- Nothing -> Attributes newAttrs newCount attributesDropped- Just limit_ ->- if newCount > limit_- then Attributes attributeMap attributesCount (attributesDropped + H.size attrs)- else Attributes newAttrs newCount attributesDropped- where- newAttrs = H.union attributeMap $ H.map (maybe id limitLengths attributeLengthLimit . toAttribute) attrs- newCount = H.size newAttrs+addAttributes AttributeLimits {..} Attributes {..} attrs+ | H.null attrs = Attributes attributeMap attributesCount attributesDropped+ | otherwise =+ let convertVal = case attributeLengthLimit of+ Nothing -> toAttribute+ Just limit -> limitLengths limit . toAttribute+ in case attributeCountLimit of+ Nothing ->+ let (!newAttrs, !added) =+ H.foldlWithKey'+ (\(!m, !n) k v -> (H.insert k (convertVal v) m, if H.member k attributeMap then n else n + 1))+ (attributeMap, 0 :: Int)+ attrs+ !newCount = attributesCount + added+ in Attributes newAttrs newCount attributesDropped+ Just limit_ ->+ let (!merged, !accepted, !totalNew) =+ H.foldlWithKey'+ ( \(!m, !n, !seen) k v ->+ if H.member k attributeMap+ then (H.insert k (convertVal v) m, n, seen)+ else+ if n < limit_+ then (H.insert k (convertVal v) m, n + 1, seen + 1)+ else (m, n, seen + 1)+ )+ (attributeMap, attributesCount, 0 :: Int)+ attrs+ !newKeys = accepted - attributesCount+ !dropped = totalNew - newKeys+ in Attributes merged accepted (attributesDropped + dropped) {-# INLINE addAttributes #-} +{- | Like 'addAttributes', but consumes an 'AttrsBuilder' instead of a 'HashMap'.+Folds each attribute directly into the existing 'Attributes' without allocating+an intermediate collection.++@since 0.4.0.0+-}+addAttributesFromBuilder :: AttributeLimits -> Attributes -> AttrsBuilder -> Attributes+addAttributesFromBuilder AttributeLimits {..} _as@Attributes {..} (AttrsBuilder fold) =+ let limitVal = case attributeLengthLimit of+ Nothing -> id+ Just limit -> limitLengths limit+ in case attributeCountLimit of+ Nothing ->+ let (!newMap, !added) = fold (\(!m, !n) k v -> (H.insert k (limitVal v) m, if H.member k m then n else n + 1)) (attributeMap, 0 :: Int)+ !newCount = attributesCount + added+ in Attributes newMap newCount attributesDropped+ Just limit_ ->+ let step (!m, !cnt, !drp) !k v =+ let a = limitVal v+ in if H.member k m+ then (H.insert k a m, cnt, drp)+ else+ if cnt < limit_+ then (H.insert k a m, cnt + 1, drp)+ else (m, cnt, drp + 1)+ (!newMap, !newCount, !newDropped) = fold step (attributeMap, attributesCount, attributesDropped)+ in Attributes newMap newCount newDropped+{-# INLINE addAttributesFromBuilder #-}+++-- Eliminate no-ops at compile time.+{-# RULES+"addAttributesFromBuilder/mempty" forall lim attrs.+ addAttributesFromBuilder lim attrs mempty =+ attrs+ #-}+++{- | Church-encoded left fold over attribute key-value pairs. Avoids allocating+intermediate tuples, list spines, or 'HashMap's when adding multiple+attributes to a span.++Construct individual entries with 'attr' \/ '.@' and combine with '<>'.+GHC can inline and fuse static builder expressions, eliminating all+intermediate allocation.++@+'addAttributes'' span $+ SC.http_request_method '.@' method+ <> SC.url_full '.@' url+ <> SC.server_port '.@?' mPort+@++@since 0.4.0.0+-}+newtype AttrsBuilder = AttrsBuilder (forall r. (r -> Text -> Attribute -> r) -> r -> r)+++instance Semigroup AttrsBuilder where+ AttrsBuilder f <> AttrsBuilder g = AttrsBuilder (\step z -> g step (f step z))+ {-# INLINE (<>) #-}+++instance Monoid AttrsBuilder where+ mempty = AttrsBuilder (\_ z -> z)+ {-# INLINE mempty #-}+++{- | Build an attribute entry from a 'Text' key. The value is converted+to 'Attribute' lazily; actual conversion is deferred until the exporter+thread reads the attribute, keeping the instrumented thread fast.++@since 0.4.0.0+-}+attr :: (ToAttribute a) => Text -> a -> AttrsBuilder+attr !k v = let a = toAttribute v in AttrsBuilder (\step z -> step z k a)+{-# INLINE attr #-}+++{- | Build an optional attribute entry. 'Nothing' contributes nothing+to the builder (zero cost).++@since 0.4.0.0+-}+optAttr :: (ToAttribute a) => Text -> Maybe a -> AttrsBuilder+optAttr _ Nothing = mempty+optAttr !k (Just v) = attr k v+{-# INLINE optAttr #-}+++{- | Build an attribute entry from a typed 'AttributeKey'. Type-safe:+the value type must match the key's phantom type.++@+SC.http_request_method '.@' ("GET" :: Text)+@++@since 0.4.0.0+-}+(.@) :: (ToAttribute a) => AttributeKey a -> a -> AttrsBuilder+(AttributeKey !k) .@ v = attr k v+{-# INLINE (.@) #-}+++infixl 8 .@+++{- | Build an optional attribute entry from a typed 'AttributeKey'.+'Nothing' contributes nothing to the builder.++@since 0.4.0.0+-}+(.@?) :: (ToAttribute a) => AttributeKey a -> Maybe a -> AttrsBuilder+_ .@? Nothing = mempty+(AttributeKey !k) .@? (Just v) = attr k v+{-# INLINE (.@?) #-}+++infixl 8 .@?+++{- | Materialize a builder into an 'Map.AttributeMap'. Useful when a raw+'HashMap' is needed (e.g. for 'NewEvent' attributes or 'SpanArguments').++@since 0.4.0.0+-}+buildAttrs :: AttrsBuilder -> Map.AttributeMap+buildAttrs (AttrsBuilder f) = f (\m k v -> H.insert k v m) H.empty+{-# INLINE buildAttrs #-}++ limitPrimAttr :: Int -> PrimitiveAttribute -> PrimitiveAttribute limitPrimAttr limit (TextAttribute t) = TextAttribute (T.take limit t) limitPrimAttr _ attr = attr@@ -136,42 +400,58 @@ limitLengths limit (AttributeArray arr) = AttributeArray $ fmap (limitPrimAttr limit) arr +-- | @since 0.0.1.0 getAttributeMap :: Attributes -> Map.AttributeMap getAttributeMap Attributes {..} = attributeMap+{-# INLINE getAttributeMap #-} +-- | @since 0.0.1.0 getCount :: Attributes -> Int getCount Attributes {..} = attributesCount+{-# INLINE getCount #-} +-- | @since 0.0.1.0 getDropped :: Attributes -> Int getDropped Attributes {..} = attributesDropped+{-# INLINE getDropped #-} +-- | @since 0.0.1.0 lookupAttribute :: Attributes -> Text -> Maybe Attribute lookupAttribute Attributes {..} k = H.lookup k attributeMap+{-# INLINE lookupAttribute #-} +-- | @since 0.0.1.0 lookupAttributeByKey :: FromAttribute a => Attributes -> AttributeKey a -> Maybe a lookupAttributeByKey Attributes {..} k = Map.lookupByKey k attributeMap+{-# INLINEABLE lookupAttributeByKey #-} {- | It is possible when adding attributes that a programming error might cause too many attributes to be added to an event. Thus, 'Attributes' use the limits set here as a safeguard against excessive memory consumption.++@since 0.0.1.0 -} data AttributeLimits = AttributeLimits { attributeCountLimit :: Maybe Int -- ^ The number of unique attributes that may be added to an 'Attributes' structure before they are dropped. , attributeLengthLimit :: Maybe Int- -- ^ The maximum length of string attributes that may be set. Longer-length string values will be truncated to the- -- specified amount.+ {- ^ The maximum length of string attributes that may be set. Longer-length string values will be truncated to the+ specified amount.+ -} } deriving stock (Read, Show, Eq, Ord, Data, Generic) deriving anyclass (Hashable) --- | Left-biased merge.+{- | Left-biased merge.++@since 0.0.1.0+-} unsafeMergeAttributesIgnoringLimits :: Attributes -> Attributes -> Attributes unsafeMergeAttributesIgnoringLimits left right = Attributes hm c d where@@ -180,8 +460,20 @@ d = attributesDropped left + attributesDropped right +-- | @since 0.0.1.0 unsafeAttributesFromListIgnoringLimits :: [(Text, Attribute)] -> Attributes unsafeAttributesFromListIgnoringLimits l = Attributes hm c 0 where hm = H.fromList l c = H.size hm+++{- | Wrap a pre-built HashMap directly into 'Attributes' with zero conversion.+No limit enforcement. Used by 'filterAttributesByKeys' to avoid+a HashMap -> list -> HashMap roundtrip.++@since 0.0.1.0+-}+unsafeAttributesFromMapIgnoringLimits :: H.HashMap Text Attribute -> Attributes+unsafeAttributesFromMapIgnoringLimits m = Attributes m (H.size m) 0+{-# INLINE unsafeAttributesFromMapIgnoringLimits #-}
− src/OpenTelemetry/Attributes/Attribute.hs
@@ -1,226 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveLift #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE StrictData #-}-{-# LANGUAGE TypeFamilies #-}--{- |-Module : OpenTelemetry.Attributes.Attribute-Copyright : (c) Ian Duncan, 2021-License : BSD-3-Description : Metadata values-Maintainer : Ian Duncan-Stability : experimental-Portability : non-portable (GHC extensions)--}-module OpenTelemetry.Attributes.Attribute (- Attribute (..),- ToAttribute (..),- FromAttribute (..),- PrimitiveAttribute (..),- ToPrimitiveAttribute (..),- FromPrimitiveAttribute (..),-) where--import Data.Data (Data)-import Data.Hashable (Hashable)-import Data.Int (Int64)-import qualified Data.List as L-import Data.String (IsString (..))-import Data.Text (Text)-import GHC.Generics (Generic)-import qualified Language.Haskell.TH.Syntax as TH-import Prelude hiding (lookup, map)----- | Convert a Haskell value to a 'PrimitiveAttribute' value.-class ToPrimitiveAttribute a where- toPrimitiveAttribute :: a -> PrimitiveAttribute---class FromPrimitiveAttribute a where- fromPrimitiveAttribute :: PrimitiveAttribute -> Maybe a---{- | An attribute represents user-provided metadata about a span, link, or event.-- Telemetry tools may use this data to support high-cardinality querying, visualization- in waterfall diagrams, trace sampling decisions, and more.--}-data Attribute- = -- | An attribute representing a single primitive value- AttributeValue PrimitiveAttribute- | -- | An attribute representing an array of primitive values.- --- -- All values in the array MUST be of the same primitive attribute type.- AttributeArray [PrimitiveAttribute]- deriving stock (Read, Show, Eq, Ord, Data, Generic, TH.Lift)- deriving anyclass (Hashable)---{- | Create a `TextAttribute` from the string value.-- @since 0.0.2.1--}-instance IsString PrimitiveAttribute where- fromString = TextAttribute . fromString---{- | Create a `TextAttribute` from the string value.-- @since 0.0.2.1--}-instance IsString Attribute where- fromString = AttributeValue . fromString---data PrimitiveAttribute- = TextAttribute Text- | BoolAttribute Bool- | DoubleAttribute Double- | IntAttribute Int64- deriving stock (Read, Show, Eq, Ord, Data, Generic, TH.Lift)- deriving anyclass (Hashable)---{- | Convert a Haskell value to an 'Attribute' value.-- For most values, you can define an instance of 'ToPrimitiveAttribute' and use the default 'toAttribute' implementation:-- @-- data Foo = Foo-- instance ToPrimitiveAttribute Foo where- toPrimitiveAttribute Foo = TextAttribute "Foo"- instance ToAttribute foo-- @--}-class ToAttribute a where- toAttribute :: a -> Attribute- default toAttribute :: (ToPrimitiveAttribute a) => a -> Attribute- toAttribute = AttributeValue . toPrimitiveAttribute---class FromAttribute a where- fromAttribute :: Attribute -> Maybe a- default fromAttribute :: (FromPrimitiveAttribute a) => Attribute -> Maybe a- fromAttribute (AttributeValue v) = fromPrimitiveAttribute v- fromAttribute _ = Nothing---instance ToPrimitiveAttribute PrimitiveAttribute where- toPrimitiveAttribute = id---instance FromPrimitiveAttribute PrimitiveAttribute where- fromPrimitiveAttribute = Just---instance ToAttribute PrimitiveAttribute where- toAttribute = AttributeValue---instance FromAttribute PrimitiveAttribute where- fromAttribute (AttributeValue v) = Just v- fromAttribute _ = Nothing---instance ToPrimitiveAttribute Text where- toPrimitiveAttribute = TextAttribute---instance FromPrimitiveAttribute Text where- fromPrimitiveAttribute (TextAttribute v) = Just v- fromPrimitiveAttribute _ = Nothing---instance ToAttribute Text---instance FromAttribute Text---instance ToPrimitiveAttribute Bool where- toPrimitiveAttribute = BoolAttribute---instance FromPrimitiveAttribute Bool where- fromPrimitiveAttribute (BoolAttribute v) = Just v- fromPrimitiveAttribute _ = Nothing---instance ToAttribute Bool---instance FromAttribute Bool---instance ToPrimitiveAttribute Double where- toPrimitiveAttribute = DoubleAttribute---instance FromPrimitiveAttribute Double where- fromPrimitiveAttribute (DoubleAttribute v) = Just v- fromPrimitiveAttribute _ = Nothing---instance ToAttribute Double---instance FromAttribute Double---instance ToPrimitiveAttribute Int64 where- toPrimitiveAttribute = IntAttribute---instance FromPrimitiveAttribute Int64 where- fromPrimitiveAttribute (IntAttribute v) = Just v- fromPrimitiveAttribute _ = Nothing---instance ToAttribute Int64---instance FromAttribute Int64---instance ToPrimitiveAttribute Int where- toPrimitiveAttribute = IntAttribute . fromIntegral---instance FromPrimitiveAttribute Int where- fromPrimitiveAttribute (IntAttribute v) = Just $ fromIntegral v- fromPrimitiveAttribute _ = Nothing---instance ToAttribute Int---instance FromAttribute Int---instance ToAttribute Attribute where- toAttribute = id---instance FromAttribute Attribute where- fromAttribute = Just---instance (ToPrimitiveAttribute a) => ToAttribute [a] where- toAttribute = AttributeArray . L.map toPrimitiveAttribute---instance (FromPrimitiveAttribute a) => FromAttribute [a] where- fromAttribute (AttributeArray arr) = traverse fromPrimitiveAttribute arr- fromAttribute _ = Nothing
− src/OpenTelemetry/Attributes/Key.hs
@@ -1,48 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}--{- |-Module : OpenTelemetry.Attributes.Key-Copyright : (c) Ian Duncan, 2021-License : BSD-3-Description : Names for key-value pair metadata-Maintainer : Ian Duncan-Stability : experimental-Portability : non-portable (GHC extensions)--}-module OpenTelemetry.Attributes.Key (- AttributeKey (..),- forget,-) where--import Data.String (IsString (..))-import Data.Text (Text)-import qualified Data.Text as T-import GHC.Generics (Generic)-import OpenTelemetry.Attributes.Attribute (Attribute)---{- | A 'AttributeKey' is a name for an attribute. The type parameter sets the type of the-attribute the key should be associated with. This is useful for standardising-attribute keys, since we can define both the key and the type of value it is-intended to record.--For example, we might define:--@--- See https://opentelemetry.io/docs/specs/semconv/attributes-registry/server/-serverPortKey :: AttributeKey Int-serverPortKey = "server.port"-@--}-newtype AttributeKey a = AttributeKey {unkey :: Text} deriving stock (Show, Eq, Ord, Generic)----- | Raise an error if the string is empty.-instance IsString (AttributeKey a) where- fromString "" = error "AttributeKey cannot be empty"- fromString s = AttributeKey $ T.pack s---forget :: AttributeKey a -> AttributeKey Attribute-forget = AttributeKey . unkey
src/OpenTelemetry/Attributes/Map.hs view
@@ -28,7 +28,7 @@ module H, ) where -import Data.HashMap.Strict as H+import Data.HashMap.Lazy as H import Data.Text (Text) import OpenTelemetry.Attributes.Attribute ( Attribute,@@ -45,11 +45,11 @@ insertByKey :: ToAttribute a => AttributeKey a -> a -> AttributeMap -> AttributeMap-insertByKey (AttributeKey !k) !v = H.insert k $ toAttribute v+insertByKey (AttributeKey !k) v = H.insert k (toAttribute v) insertAttributeByKey :: AttributeKey a -> Attribute -> AttributeMap -> AttributeMap-insertAttributeByKey (AttributeKey !k) !v = H.insert k v+insertAttributeByKey (AttributeKey !k) v = H.insert k v lookupByKey :: FromAttribute a => AttributeKey a -> AttributeMap -> Maybe a
src/OpenTelemetry/Baggage.hs view
@@ -5,24 +5,72 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} ------------------------------------------------------------------------------+{- |+Module : OpenTelemetry.Baggage+Copyright : (c) Ian Duncan, 2021-2026+License : BSD-3+Description : Propagated key-value metadata for cross-service context+Stability : experimental ------------------------------------------------------------------------------+= Overview -{- |- Module : OpenTelemetry.Baggage- Copyright : (c) Ian Duncan, 2021- License : BSD-3- Description : Serializable annotations to add user-defined values to telemetry- Maintainer : Ian Duncan- Stability : experimental- Portability : non-portable (GHC extensions)+Baggage is a set of key-value pairs that propagate alongside trace context+across service boundaries (typically via the @baggage@ HTTP header). Use it+to pass metadata like tenant IDs, feature flags, or routing hints through+your distributed system. - Baggage is used to annotate telemetry, adding context and information to metrics, traces, and logs.- It is a set of name/value pairs describing user-defined properties.+Baggage is /not/ for span-specific annotations. Use 'OpenTelemetry.Trace.addAttribute'+for that. - Note: if you are trying to add data annotations specific to a single trace span, you should use- 'OpenTelemetry.Trace.addAttribute' and 'OpenTelemetry.Trace.addAttributes'+= Quick example++@+import OpenTelemetry.Baggage++-- Create baggage:+let bag = insert [token|tenant-id|] (element "abc123")+ $ insert [token|region|] (element "us-east-1")+ $ empty++-- Encode for HTTP propagation:+let headerValue = encodeBaggageHeader bag+-- "tenant-id=abc123,region=us-east-1"++-- Decode from an incoming header:+case decodeBaggageHeader headerBytes of+ Right bag -> -- use the baggage+ Left err -> -- malformed header+@++= Thread-local baggage++Use the functions in "OpenTelemetry.Context.ThreadLocal" to get\/set baggage+on the current thread:++@+import OpenTelemetry.Context.ThreadLocal (getContext, adjustContext)+import OpenTelemetry.Context (insertBaggage, lookupBaggage)++-- Read:+mbag <- lookupBaggage \<$\> getContext+-- Write:+adjustContext (insertBaggage myBaggage)+@++= Limits++W3C Baggage specification enforces:++* Max 8192 bytes total serialized size+* Max 4096 bytes per member+* Max 180 members++'insertChecked' validates these limits and returns 'Left' 'InvalidBaggage'+on violation.++= Spec reference++<https://opentelemetry.io/docs/specs/otel/baggage/api/> -} module OpenTelemetry.Baggage ( -- * Constructing 'Baggage' structures@@ -39,38 +87,43 @@ property, InvalidBaggage (..), + -- * Limits (W3C Baggage specification)+ maxBaggageBytes,+ maxMemberBytes,+ maxMembers,+ -- * Modifying 'Baggage' insert,+ insertChecked, delete, + -- * Querying 'Baggage'+ getValue,+ -- * Encoding and decoding 'Baggage' encodeBaggageHeader, encodeBaggageHeaderB, decodeBaggageHeader,- decodeBaggageHeaderP, ) where -import Control.Applicative hiding (empty)-import qualified Data.Attoparsec.ByteString.Char8 as P+import Control.Monad (when) import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Builder.Extra as BS import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.Lazy as L import Data.ByteString.Unsafe (unsafePackAddressLen)-import Data.CharSet (CharSet)-import qualified Data.CharSet as C import qualified Data.HashMap.Strict as H import Data.Hashable-import Data.List (intersperse) import Data.Text (Text) import qualified Data.Text as T-import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Data.Text.Encoding (decodeUtf8', encodeUtf8)+import Data.Word (Word8) import Language.Haskell.TH.Lib import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax-import Network.HTTP.Types.URI import System.IO.Unsafe @@ -78,13 +131,18 @@ specified in the @token@ definition of RFC 2616: https://www.rfc-editor.org/rfc/rfc2616#section-2.2++ @since 0.0.1.0 -} newtype Token = Token ByteString deriving stock (Show, Eq, Ord) deriving newtype (Hashable) --- | Convert a 'Token' into a 'ByteString'+{- | Convert a 'Token' into a 'ByteString'++@since 0.0.1.0+-} tokenValue :: Token -> ByteString tokenValue (Token t) = t @@ -97,7 +155,10 @@ #endif --- | An entry into the baggage+{- | An entry into the baggage++@since 0.0.1.0+-} data Element = Element { value :: Text , properties :: [Property]@@ -105,6 +166,7 @@ deriving stock (Show, Eq) +-- | @since 0.0.1.0 element :: Text -> Element element t = Element t [] @@ -116,6 +178,7 @@ deriving stock (Show, Eq) +-- | @since 0.0.1.0 property :: Token -> Maybe Text -> Property property = Property @@ -123,16 +186,158 @@ {- | Baggage is used to annotate telemetry, adding context and information to metrics, traces, and logs. It is a set of name/value pairs describing user-defined properties. Each name in Baggage is associated with exactly one value.++ @since 0.0.1.0 -} newtype Baggage = Baggage (H.HashMap Token Element) deriving stock (Show, Eq) deriving newtype (Semigroup) -tokenCharacters :: CharSet-tokenCharacters = C.fromList "!#$%&'*+-.^_`|~0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"+-- | RFC 2616 token character predicate (no allocation, branchless via table)+isTokenChar :: Char -> Bool+isTokenChar c = w < 128 && tokenTable `BS.index` fromIntegral w /= 0+ where+ w = fromEnum c+{-# INLINE isTokenChar #-} +-- 128-byte lookup: 1 = valid token char, 0 = invalid+tokenTable :: ByteString+tokenTable =+ BS.pack+ [ 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0 -- 0x00-0x0f+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0 -- 0x10-0x1f+ , 0+ , 1+ , 0+ , 1+ , 1+ , 1+ , 1+ , 1+ , 0+ , 0+ , 1+ , 1+ , 0+ , 1+ , 1+ , 0 -- ! # $ % & ' * + - .+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0 -- 0-9+ , 0+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1 -- A-O+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 0+ , 0+ , 0+ , 1+ , 1 -- P-Z ^ _+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1 -- ` a-o+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 1+ , 0+ , 1+ , 0+ , 1+ , 0 -- p-z | ~+ ]+{-# NOINLINE tokenTable #-}++ -- Ripped from file-embed-0.0.13 bsToExp :: (Monad m) => ByteString -> m Exp #if MIN_VERSION_template_haskell(2, 5, 0)@@ -158,13 +363,16 @@ #endif +-- | @since 0.0.1.0 mkToken :: Text -> Maybe Token mkToken txt+ | T.null txt = Nothing | txt `T.compareLength` 4096 == GT = Nothing- | T.all (`C.member` tokenCharacters) txt = Just $ Token $ encodeUtf8 txt+ | T.all isTokenChar txt = Just $ Token $ encodeUtf8 txt | otherwise = Nothing +-- | @since 0.0.1.0 token :: QuasiQuoter token = QuasiQuoter@@ -179,15 +387,16 @@ Just tok -> lift tok +-- | @since 0.0.1.0 data InvalidBaggage = BaggageTooLong | MemberTooLong | TooManyListMembers | Empty+ deriving stock (Show, Eq) --- TODO: The fact that this can be a max of 8192 bytes--- should allow this to optimized pretty heavily+-- | @since 0.0.1.0 encodeBaggageHeader :: Baggage -> ByteString encodeBaggageHeader = L.toStrict@@ -195,77 +404,160 @@ . encodeBaggageHeaderB +-- | @since 0.0.1.0 encodeBaggageHeaderB :: Baggage -> B.Builder encodeBaggageHeaderB (Baggage bmap) =- mconcat $- intersperse (B.char7 ',') $- map go $- H.toList bmap+ go 0 True (take maxMembers $ H.toList bmap) where- go (Token k, Element v props) =- B.byteString k- <> B.char7 '='- <> urlEncodeBuilder False (encodeUtf8 v)- <> (mconcat $ intersperse (B.char7 ';') $ map propEncoder props)- propEncoder (Property (Token k) mv) =- B.byteString k- <> maybe- mempty- (\v -> B.char7 '=' <> urlEncodeBuilder False (encodeUtf8 v))- mv+ go :: Int -> Bool -> [(Token, Element)] -> B.Builder+ go _ _ [] = mempty+ go totalSoFar isFirst ((tok, el) : rest) =+ let memberBs = builderToStrict (encodeMemberB tok el)+ memberLen = BS.length memberBs+ sep = if isFirst then 0 else 1+ newTotal = totalSoFar + sep + memberLen+ in if memberLen > maxMemberBytes+ then go totalSoFar isFirst rest+ else+ if newTotal > maxBaggageBytes+ then mempty+ else+ (if isFirst then mempty else B.char7 ',')+ <> B.byteString memberBs+ <> go newTotal False rest +encodeMemberB :: Token -> Element -> B.Builder+encodeMemberB (Token k) (Element v props) =+ B.byteString k+ <> B.char7 '='+ <> percentEncodeBuilder (encodeUtf8 v)+ <> mconcat (map (\p -> B.char7 ';' <> propEncoderB p) props)+++propEncoderB :: Property -> B.Builder+propEncoderB (Property (Token k) mv) =+ B.byteString k+ <> maybe+ mempty+ (\v -> B.char7 '=' <> percentEncodeBuilder (encodeUtf8 v))+ mv+++builderToStrict :: B.Builder -> ByteString+builderToStrict = L.toStrict . B.toLazyByteString+++{- | W3C Baggage: max 8192 bytes total, max 180 members, max 4096 bytes per member++@since 0.0.1.0+-}+maxBaggageBytes, maxMemberBytes, maxMembers :: Int+maxBaggageBytes = 8192+maxMemberBytes = 4096+maxMembers = 180+++-- | @since 0.0.1.0 decodeBaggageHeader :: ByteString -> Either String Baggage-decodeBaggageHeader = P.parseOnly decodeBaggageHeaderP+decodeBaggageHeader bs+ | BS.length bs > maxBaggageBytes = Left "Baggage header exceeds 8192 byte limit"+ | otherwise = parseBaggageHeader bs -decodeBaggageHeaderP :: P.Parser Baggage-decodeBaggageHeaderP = do- owsP- firstMember <- memberP- otherMembers <- many (owsP >> P.char8 ',' >> owsP >> memberP)- owsP- pure $ Baggage $ H.fromList (firstMember : otherMembers)+parseBaggageHeader :: ByteString -> Either String Baggage+parseBaggageHeader input = do+ let stripped = stripOWS input+ when (BS.null stripped) $ Left "Empty baggage header"+ let rawMembers = splitOnByte 0x2C stripped -- ','+ when (length rawMembers > maxMembers) $+ Left ("Baggage has more than " ++ show maxMembers ++ " members")+ members <- mapM parseMember rawMembers+ pure $ Baggage $ H.fromList members+++parseMember :: ByteString -> Either String (Token, Element)+parseMember raw = do+ let s = stripOWS raw+ let (keyBs, rest0) = B8.span isTokenChar s+ when (BS.null keyBs) $ Left "Expected token in baggage member"+ let rest1 = stripOWS rest0+ rest2 <- expectByte 0x3D rest1 -- '='+ let rest3 = stripOWS rest2+ (valBs, rest4) = BS.span isValueByte rest3+ val <- case decodeUtf8' (percentDecode valBs) of+ Right t -> Right t+ Left _ -> Left "Invalid UTF-8 in baggage value"+ props <- parseProperties rest4+ pure (Token keyBs, Element val props)+++parseProperties :: ByteString -> Either String [Property]+parseProperties bs = go (stripOWS bs) where- owsSet = C.fromList " \t"- owsP = P.skipWhile (`C.member` owsSet)- memberP :: P.Parser (Token, Element)- memberP = do- tok <- tokenP- owsP- _ <- P.char8 '='- owsP- val <- valP- props <- many (owsP >> P.char8 ';' >> owsP >> propertyP)- pure (tok, Element val props)- valueSet =- C.fromList $- concat- [ ['\x21']- , ['\x23' .. '\x2B']- , ['\x2D' .. '\x3A']- , ['\x3C' .. '\x5B']- , ['\x5D' .. '\x7E']- ]- tokenP :: P.Parser Token- tokenP = Token <$> P.takeWhile1 (`C.member` tokenCharacters)- valP = decodeUtf8 . urlDecode False <$> P.takeWhile (`C.member` valueSet)- propertyP :: P.Parser Property- propertyP = do- key <- tokenP- owsP- val <- P.option Nothing $ do- _ <- P.char8 '='- owsP- Just <$> valP- pure $ Property key val+ go s+ | BS.null s = Right []+ | BS.head s == 0x3B = do+ -- ';'+ let s1 = stripOWS (BS.tail s)+ (keyBs, rest0) = B8.span isTokenChar s1+ when (BS.null keyBs) $ Left "Expected token in baggage property"+ let rest1 = stripOWS rest0+ if not (BS.null rest1) && BS.head rest1 == 0x3D -- '='+ then do+ let rest2 = stripOWS (BS.tail rest1)+ (valBs, rest3) = BS.span isValueByte rest2+ rest <- go (stripOWS rest3)+ propVal <- case decodeUtf8' (percentDecode valBs) of+ Right t -> Right t+ Left _ -> Left "Invalid UTF-8 in baggage property value"+ pure $ Property (Token keyBs) (Just propVal) : rest+ else do+ rest <- go rest1+ pure $ Property (Token keyBs) Nothing : rest+ | otherwise = Left $ "Unexpected byte in baggage: " ++ show (BS.head s) --- | An empty initial baggage value+isValueByte :: Word8 -> Bool+isValueByte w =+ w == 0x21+ || (w >= 0x23 && w <= 0x2B)+ || (w >= 0x2D && w <= 0x3A)+ || (w >= 0x3C && w <= 0x5B)+ || (w >= 0x5D && w <= 0x7E)+{-# INLINE isValueByte #-}+++stripOWS :: ByteString -> ByteString+stripOWS = B8.dropWhile (\c -> c == ' ' || c == '\t') . B8.dropWhileEnd (\c -> c == ' ' || c == '\t')+{-# INLINE stripOWS #-}+++expectByte :: Word8 -> ByteString -> Either String ByteString+expectByte expected bs+ | BS.null bs = Left $ "Expected " ++ show expected ++ " but got end of input"+ | BS.head bs == expected = Right (BS.tail bs)+ | otherwise = Left $ "Expected " ++ show expected ++ " but got " ++ show (BS.head bs)+{-# INLINE expectByte #-}+++splitOnByte :: Word8 -> ByteString -> [ByteString]+splitOnByte w bs+ | BS.null bs = []+ | otherwise =+ let (before, rest) = BS.break (== w) bs+ in before : if BS.null rest then [] else splitOnByte w (BS.tail rest)+++{- | An empty initial baggage value++@since 0.0.1.0+-} empty :: Baggage empty = Baggage H.empty +-- | @since 0.0.1.0 insert :: Token -- ^ The name for which to set the value@@ -276,11 +568,70 @@ insert k v (Baggage c) = Baggage (H.insert k v c) --- | Delete a key/value pair from the baggage.+{- | Insert a key\/value pair into the baggage with W3C limit enforcement.++Returns 'Left' 'InvalidBaggage' if adding the entry would violate:++* 'TooManyListMembers': exceeds 180 entries (W3C ABNF max)+* 'BaggageTooLong': serialized header would exceed 8192 bytes++@since 0.4.0.0+-}+insertChecked+ :: Token+ -> Element+ -> Baggage+ -> Either InvalidBaggage Baggage+insertChecked k v (Baggage c) =+ let c' = H.insert k v c+ newCount = H.size c'+ newBag = Baggage c'+ in if newCount > maxMembers+ then Left TooManyListMembers+ else+ let totalBytes = baggageSerializedSize c'+ in if totalBytes > maxBaggageBytes+ then Left BaggageTooLong+ else Right newBag+++baggageSerializedSize :: H.HashMap Token Element -> Int+baggageSerializedSize m =+ let entries = H.toList m+ memberSizes = map (\(tok, el) -> memberByteLen tok el) entries+ separators = max 0 (length entries - 1)+ in sum memberSizes + separators+ where+ memberByteLen (Token k) (Element v props) =+ BS.length k+ + 1+ + BS.length (percentEncode (encodeUtf8 v))+ + sum (map propLen props)+ propLen (Property (Token pk) Nothing) = 1 + BS.length pk+ propLen (Property (Token pk) (Just pv)) = 1 + BS.length pk + 1 + BS.length (percentEncode (encodeUtf8 pv))+++{- | Delete a key/value pair from the baggage.++@since 0.0.1.0+-} delete :: Token -> Baggage -> Baggage delete k (Baggage c) = Baggage (H.delete k c) +{- | Look up a baggage value by name.++Per the spec, this takes a name and returns the associated value, or+'Nothing' if the name is not present in the baggage.++@since 0.4.0.0+-}+getValue :: Token -> Baggage -> Maybe Text+getValue k (Baggage m) = case H.lookup k m of+ Just (Element v _) -> Just v+ Nothing -> Nothing++ {- | Returns the name/value pairs in the `Baggage`. The order of name/value pairs is not significant. @@ -290,6 +641,63 @@ values (Baggage m) = m --- | Convert a 'H.HashMap' into 'Baggage'+{- | Convert a 'H.HashMap' into 'Baggage'++@since 0.0.1.0+-} fromHashMap :: H.HashMap Token Element -> Baggage fromHashMap = Baggage+++-- Percent-encoding (RFC 3986 unreserved characters)+-- Spaces are always encoded as %20 (not +).++isUnreserved :: Word8 -> Bool+isUnreserved w =+ (w >= 65 && w <= 90) -- A-Z+ || (w >= 97 && w <= 122) -- a-z+ || (w >= 48 && w <= 57) -- 0-9+ || w == 45 -- -+ || w == 46 -- .+ || w == 95 -- _+ || w == 126 -- ~+{-# INLINE isUnreserved #-}+++percentEncode :: ByteString -> ByteString+percentEncode = L.toStrict . B.toLazyByteString . percentEncodeBuilder+{-# INLINE percentEncode #-}+++percentEncodeBuilder :: ByteString -> B.Builder+percentEncodeBuilder = BS.foldl' (\acc w -> acc <> encodeWord8 w) mempty+ where+ encodeWord8 w+ | isUnreserved w = B.word8 w+ | otherwise = B.char7 '%' <> hexWord8 w+ hexWord8 w =+ let (hi, lo) = w `divMod` 16+ in B.word8 (hexDigit hi) <> B.word8 (hexDigit lo)+ hexDigit n+ | n < 10 = n + 48 -- '0'+ | otherwise = n + 55 -- 'A' - 10+++percentDecode :: ByteString -> ByteString+percentDecode bs = L.toStrict $ B.toLazyByteString $ go 0+ where+ len = BS.length bs+ go i+ | i >= len = mempty+ | BS.index bs i == 0x25+ , i + 2 < len -- '%'+ , Just hi <- unhex (BS.index bs (i + 1))+ , Just lo <- unhex (BS.index bs (i + 2)) =+ B.word8 (hi * 16 + lo) <> go (i + 3)+ | otherwise =+ B.word8 (BS.index bs i) <> go (i + 1)+ unhex w+ | w >= 48 && w <= 57 = Just (w - 48) -- 0-9+ | w >= 65 && w <= 70 = Just (w - 55) -- A-F+ | w >= 97 && w <= 102 = Just (w - 87) -- a-f+ | otherwise = Nothing
src/OpenTelemetry/Common.hs view
@@ -1,13 +1,97 @@-module OpenTelemetry.Common where+{-# LANGUAGE NumericUnderscores #-} -import Data.Word (Word8)-import System.Clock (TimeSpec)+module OpenTelemetry.Common (+ Timestamp (..),+ TraceFlags (..),+ OptionalTimestamp (NoTimestamp, SomeTimestamp),+ isEnded,+ optionalTimestampToMaybe,+ optionalTimestampFromMaybe,+ timestampToOptional,+ mkTimestamp,+ timestampToNanoseconds,+) where +import Data.Word (Word64, Word8) -newtype Timestamp = Timestamp TimeSpec++{- | Wall-clock timestamp stored as nanoseconds since Unix epoch.+Matches the OTLP wire format directly (fixed64 nanoseconds).++@since 0.0.1.0+-}+newtype Timestamp = Timestamp Word64 deriving (Read, Show, Eq, Ord) --- | Contain details about the trace. Unlike TraceState values, TraceFlags are present in all traces. The current version of the specification only supports a single flag called sampled.+{- | Contain details about the trace. Unlike TraceState values, TraceFlags are present in all traces. The current version of the specification only supports a single flag called sampled.++@since 0.0.1.0+-} newtype TraceFlags = TraceFlags Word8 deriving (Show, Eq, Ord)+++{- | Unboxed optional timestamp. @SomeTimestamp@ stores a single unboxed+@Word64#@ directly in its closure: 2 words total vs 4 for+@Just (Timestamp ns)@.++@since 0.0.1.0+-}+data OptionalTimestamp+ = NoTimestamp+ | SomeTimestamp {-# UNPACK #-} !Word64+ deriving (Eq, Ord)+++instance Show OptionalTimestamp where+ showsPrec _ NoTimestamp = showString "NoTimestamp"+ showsPrec d (SomeTimestamp ns) =+ showParen (d > 10) $+ showString "SomeTimestamp " . showsPrec 11 ns+++-- | @since 0.0.1.0+isEnded :: OptionalTimestamp -> Bool+isEnded NoTimestamp = False+isEnded _ = True+{-# INLINE isEnded #-}+++-- | @since 0.0.1.0+optionalTimestampToMaybe :: OptionalTimestamp -> Maybe Timestamp+optionalTimestampToMaybe NoTimestamp = Nothing+optionalTimestampToMaybe (SomeTimestamp ns) = Just (Timestamp ns)+{-# INLINE optionalTimestampToMaybe #-}+++-- | @since 0.0.1.0+optionalTimestampFromMaybe :: Maybe Timestamp -> OptionalTimestamp+optionalTimestampFromMaybe Nothing = NoTimestamp+optionalTimestampFromMaybe (Just (Timestamp ns)) = SomeTimestamp ns+{-# INLINE optionalTimestampFromMaybe #-}+++-- | @since 0.0.1.0+timestampToOptional :: Timestamp -> OptionalTimestamp+timestampToOptional (Timestamp ns) = SomeTimestamp ns+{-# INLINE timestampToOptional #-}+++{- | Construct a 'Timestamp' from seconds and nanoseconds components.+Useful for tests and interop with @TimeSpec@-based APIs.++@since 0.0.1.0+-}+mkTimestamp :: Word64 -> Word64 -> Timestamp+mkTimestamp sec nsec = Timestamp (sec * 1_000_000_000 + nsec)+{-# INLINE mkTimestamp #-}+++{- | Extract nanoseconds since epoch. Identity on the internal representation.++@since 0.0.1.0+-}+timestampToNanoseconds :: Timestamp -> Word64+timestampToNanoseconds (Timestamp ns) = ns+{-# INLINE timestampToNanoseconds #-}
src/OpenTelemetry/Context.hs view
@@ -1,26 +1,52 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE UnboxedSums #-} ------------------------------------------------------------------------------+{- |+Module : OpenTelemetry.Context+Copyright : (c) Ian Duncan, 2021-2026+License : BSD-3+Description : Carrier for execution-scoped values across API boundaries+Stability : experimental ------------------------------------------------------------------------------+= Overview -{- |- Module : OpenTelemetry.Context- Copyright : (c) Ian Duncan, 2021- License : BSD-3- Description : Carrier for execution-scoped values across API boundaries- Maintainer : Ian Duncan- Stability : experimental- Portability : non-portable (GHC extensions)+A 'Context' carries trace state (the current 'Span') and 'Baggage' across+API boundaries and through your application. You rarely interact with it+directly; the @inSpan@ functions and propagators manage it for you. - The ability to correlate events across service boundaries is one of the principle concepts behind distributed tracing. To find these correlations, components in a distributed system need to be able to collect, store, and transfer metadata referred to as context.+= When you need Context directly - A context will often have information identifying the current span and trace, and can contain arbitrary correlations as key-value pairs.+* __Custom propagation__: extracting\/injecting context from non-HTTP transports+* __Manual span parenting__: creating a span as a child of a specific context+* __Baggage access__: reading or modifying baggage entries - Propagation is the means by which context is bundled and transferred in and across services, often via HTTP headers.+= Quick example - Together, context and propagation represent the engine behind distributed tracing.+@+import OpenTelemetry.Context+import OpenTelemetry.Context.ThreadLocal++-- Read the current span from thread-local context:+ctx <- getContext+case lookupSpan ctx of+ Just span -> addAttribute span "custom.key" (toAttribute "value")+ Nothing -> pure ()++-- Attach baggage to the current context:+adjustContext (insertBaggage myBaggage)+@++= Thread-local context++In most applications, context is stored in a thread-local variable managed+by "OpenTelemetry.Context.ThreadLocal". The @inSpan@ functions automatically+push and pop spans from this thread-local context.++= Spec reference++<https://opentelemetry.io/docs/specs/otel/context/> -} module OpenTelemetry.Context ( Key (keyName),@@ -43,87 +69,96 @@ ) where import Control.Monad.IO.Class-import Data.Maybe import Data.Text (Text) import qualified Data.Vault.Strict as V import OpenTelemetry.Baggage (Baggage) import OpenTelemetry.Context.Types import OpenTelemetry.Internal.Trace.Types-import System.IO.Unsafe+import OpenTelemetry.Internal.UnpackedMaybe+import Unsafe.Coerce (unsafeCoerce) import Prelude hiding (lookup) +-- | @since 0.0.1.0 newKey :: (MonadIO m) => Text -> m (Key a) newKey n = liftIO (Key n <$> V.newKey) +-- | @since 0.0.1.0 class HasContext s where contextL :: Lens' s Context +-- | @since 0.0.1.0 empty :: Context-empty = Context V.empty+empty = Context UNothing UNothing V.empty+{-# INLINE empty #-} +-- | @since 0.0.1.0 lookup :: Key a -> Context -> Maybe a-lookup (Key _ k) (Context v) = V.lookup k v+lookup (Key _ k) (Context _ _ v) = V.lookup k v+{-# INLINE lookup #-} +-- | @since 0.0.1.0 insert :: Key a -> a -> Context -> Context-insert (Key _ k) x (Context v) = Context $ V.insert k x v+insert (Key _ k) x (Context s b v) = Context s b (V.insert k x v)+{-# INLINE insert #-} --- insertWith--- :: (a -> a -> a)--- -- ^ new value -> old value -> result--- -> Key a -> a -> Context -> Context--- insertWith f (Key _ k) x (Context v) = Context $ case V.lookup k of--- Nothing -> V.insert k x v--- Just ox -> V.insert k (f x ox) v-+-- | @since 0.0.1.0 adjust :: (a -> a) -> Key a -> Context -> Context-adjust f (Key _ k) (Context v) = Context $ V.adjust f k v+adjust f (Key _ k) (Context s b v) = Context s b (V.adjust f k v) +-- | @since 0.0.1.0 delete :: Key a -> Context -> Context-delete (Key _ k) (Context v) = Context $ V.delete k v+delete (Key _ k) (Context s b v) = Context s b (V.delete k v) +-- | @since 0.0.1.0 union :: Context -> Context -> Context-union (Context v1) (Context v2) = Context $ V.union v1 v2+union = (<>) -spanKey :: Key Span-spanKey = unsafePerformIO $ newKey "span"-{-# NOINLINE spanKey #-}-+-- Span operations: O(1) via dedicated unboxed slot, no vault/hash overhead +-- | @since 0.0.1.0 lookupSpan :: Context -> Maybe Span-lookupSpan = lookup spanKey+lookupSpan (Context s _ _) = case s of+ UNothing -> Nothing+ UJust x -> Just (unsafeCoerce x)+{-# INLINE lookupSpan #-} +-- | @since 0.0.1.0 insertSpan :: Span -> Context -> Context-insertSpan = insert spanKey+insertSpan !span (Context _ b v) = Context (UJust (unsafeCoerce span)) b v+{-# INLINE insertSpan #-} +-- | @since 0.0.1.0 removeSpan :: Context -> Context-removeSpan = delete spanKey+removeSpan (Context _ b v) = Context UNothing b v+{-# INLINE removeSpan #-} -baggageKey :: Key Baggage-baggageKey = unsafePerformIO $ newKey "baggage"-{-# NOINLINE baggageKey #-}-+-- Baggage operations: O(1) via dedicated unboxed slot +-- | @since 0.0.1.0 lookupBaggage :: Context -> Maybe Baggage-lookupBaggage = lookup baggageKey+lookupBaggage (Context _ b _) = toBaseMaybe b+{-# INLINE lookupBaggage #-} +-- | @since 0.0.1.0 insertBaggage :: Baggage -> Context -> Context-insertBaggage b c = case lookup baggageKey c of- Nothing -> insert baggageKey b c- Just b' -> insert baggageKey (b <> b') c+insertBaggage bag (Context s _ v) = Context s (UJust bag) v+{-# INLINE insertBaggage #-} +-- | @since 0.0.1.0 removeBaggage :: Context -> Context-removeBaggage = delete baggageKey+removeBaggage (Context s _ v) = Context s UNothing v+{-# INLINE removeBaggage #-}
+ src/OpenTelemetry/Context/Environment.hs view
@@ -0,0 +1,236 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : OpenTelemetry.Context.Environment+Copyright : (c) Ian Duncan, 2024+License : BSD-3+Description : Propagate trace context to child processes via environment variables+Maintainer : Ian Duncan+Stability : alpha+Portability : non-portable (GHC extensions)++This module implements the+<https://opentelemetry.io/docs/specs/otel/context/env-carriers/ Environment Variables as Context Propagation Carriers>+specification (Alpha).++It uses the globally configured 'TextMapPropagator' to inject\/extract+trace context through environment variables. Propagation field names are+normalized to POSIX-compatible environment variable names per the+specification, making this module __format-agnostic__: it works with+W3C, B3, Datadog, or any other registered propagator.++== Usage++__Extracting context in a child process__ (at startup):++@+main :: IO ()+main = do+ ctx <- 'extractContextFromEnvironment'+ _tok <- 'OpenTelemetry.Context.ThreadLocal.attachContext' ctx+ -- ... this process is now part of the parent's trace+@++__Injecting context when spawning a child process__:++@+import System.Process ('System.Process.CreateProcess', 'System.Process.proc', 'System.Process.createProcess')+import System.Environment ('System.Environment.getEnvironment')++spawnTracedChild :: IO ()+spawnTracedChild = do+ baseEnv <- 'System.Environment.getEnvironment'+ traceEnv <- 'injectCurrentContextToEnvironment'+ let childEnv = 'mergeEnvironment' traceEnv baseEnv+ 'System.Process.createProcess' ('System.Process.proc' "my-child" []) { 'System.Process.env' = Just childEnv }+@++== Spec compliance++Per the specification, this module does __not__ handle process spawning.+The application is responsible for passing the injected environment+variables to its process-spawning mechanism.++The carrier is format-agnostic: key normalization follows POSIX rules+(uppercase, replace non-alphanumeric\/non-underscore with @_@, prefix+with @_@ if the name would start with a digit). Values are treated as+opaque strings.++@since 0.4.0.0+-}+module OpenTelemetry.Context.Environment (+ -- * Extract (child process startup)+ extractContextFromEnvironment,++ -- * Inject (before spawning child)+ injectContextToEnvironment,+ injectCurrentContextToEnvironment,++ -- * Helpers+ mergeEnvironment,++ -- * Key normalization+ normalizeKeyToEnvVar,++ -- * Well-known environment variable names+ envTraceparent,+ envTracestate,+ envBaggage,+) where++import Data.Char (isAsciiLower, isAsciiUpper, isDigit, toLower, toUpper)+import qualified Data.Text as T+import OpenTelemetry.Context (Context)+import OpenTelemetry.Context.ThreadLocal (getContext)+import OpenTelemetry.Propagator (TextMap, emptyTextMap, extract, getGlobalTextMapPropagator, inject, textMapFromList, textMapToList)+import System.Environment (getEnvironment)+++-- | @since 0.4.0.0+envTraceparent :: String+envTraceparent = "TRACEPARENT"+++-- | @since 0.4.0.0+envTracestate :: String+envTracestate = "TRACESTATE"+++-- | @since 0.4.0.0+envBaggage :: String+envBaggage = "BAGGAGE"+++{- | Normalize a propagation field name to a POSIX-compatible environment+variable name.++Per the OTel spec, environment variable names:++* MUST have ASCII letters uppercased+* MUST have every character that is not an ASCII letter, digit, or+ underscore replaced with an underscore+* MUST be prefixed with @_@ if the result would start with a digit++Examples:++@+normalizeKeyToEnvVar "traceparent" == "TRACEPARENT"+normalizeKeyToEnvVar "x-b3-traceid" == "X_B3_TRACEID"+normalizeKeyToEnvVar "x-datadog-trace" == "X_DATADOG_TRACE"+@++@since 0.4.0.0+-}+normalizeKeyToEnvVar :: T.Text -> String+normalizeKeyToEnvVar name =+ let raw = map normalizeChar (T.unpack name)+ in case raw of+ (c : _) | isDigit c -> '_' : map toUpper raw+ _ -> map toUpper raw+ where+ normalizeChar c+ | isAsciiUpper c || isAsciiLower c || isDigit c || c == '_' = c+ | otherwise = '_'+{-# INLINE normalizeKeyToEnvVar #-}+++{- | Reverse-normalize an environment variable name to a plausible+propagation field name: lowercase and replace underscores with hyphens.++This is not a perfect inverse (the forward normalization is lossy), but+it produces the correct result for all standard propagation formats+(W3C, B3, Datadog, etc.) since field names universally use lowercase+letters and hyphens.+-}+reverseNormalizeEnvVarToKey :: String -> T.Text+reverseNormalizeEnvVarToKey = T.pack . map (\c -> if c == '_' then '-' else toLower c)+{-# INLINE reverseNormalizeEnvVarToKey #-}+++{- | Extract trace context from the current process's environment variables.++Reads all environment variables, reverse-normalizes their names to+propagation field equivalents, and delegates to the globally configured+'TextMapPropagator' for parsing. The propagator determines which+variables are relevant (e.g. @TRACEPARENT@ for W3C, @X_B3_TRACEID@ for+B3).++Returns the current thread-local context enriched with any extracted+span context and baggage. If the environment variables are absent or+unparseable, the original context is returned unchanged.++@since 0.4.0.0+-}+extractContextFromEnvironment :: IO Context+extractContextFromEnvironment = do+ propagator <- getGlobalTextMapPropagator+ ctx <- getContext+ tm <- envToTextMap+ extract propagator tm ctx+++{- | Inject the given context into a list of environment variable+key-value pairs.++Uses the globally configured 'TextMapPropagator' to serialize trace+context and baggage, then normalizes the resulting field names to+POSIX-compatible environment variable names.++The returned list contains only the trace-related variables. Use+'mergeEnvironment' to combine them with the current process environment+before passing to @CreateProcess@.++@since 0.4.0.0+-}+injectContextToEnvironment :: Context -> IO [(String, String)]+injectContextToEnvironment ctx = do+ propagator <- getGlobalTextMapPropagator+ tm <- inject propagator ctx emptyTextMap+ pure (textMapToEnv tm)+++{- | Convenience wrapper: injects the current thread-local context.++Equivalent to @'getContext' >>= 'injectContextToEnvironment'@.++@since 0.4.0.0+-}+injectCurrentContextToEnvironment :: IO [(String, String)]+injectCurrentContextToEnvironment = getContext >>= injectContextToEnvironment+++{- | Merge trace environment variables into a base environment.++Later entries (the base) are overwritten by earlier entries (the+trace vars) for matching keys. This is the intended merge direction:+trace context should override any stale @TRACEPARENT@ etc. that may+exist in the inherited environment.++@+baseEnv <- getEnvironment+traceEnv <- injectCurrentContextToEnvironment+let childEnv = mergeEnvironment traceEnv baseEnv+@++@since 0.4.0.0+-}+mergeEnvironment+ :: [(String, String)]+ -- ^ Trace environment variables (take precedence)+ -> [(String, String)]+ -- ^ Base environment+ -> [(String, String)]+mergeEnvironment traceVars baseEnv =+ traceVars <> filter (\(k, _) -> k `notElem` traceKeys) baseEnv+ where+ traceKeys = fmap fst traceVars+++envToTextMap :: IO TextMap+envToTextMap = do+ allEnv <- getEnvironment+ pure $ textMapFromList $ map (\(k, v) -> (reverseNormalizeEnvVarToKey k, T.pack v)) allEnv+++textMapToEnv :: TextMap -> [(String, String)]+textMapToEnv = map (\(k, v) -> (normalizeKeyToEnvVar k, T.unpack v)) . textMapToList
src/OpenTelemetry/Context/ThreadLocal.hs view
@@ -1,45 +1,80 @@-{-# LANGUAGE UnliftedFFITypes #-}+{-# LANGUAGE BangPatterns #-} ------------------------------------------------------------------------------+{- |+Module : OpenTelemetry.Context.ThreadLocal+Copyright : (c) Ian Duncan, 2021-2026+License : BSD-3+Description : Thread-local context storage with token-based attach\/detach+Stability : experimental ------------------------------------------------------------------------------+= Overview -{- |- Module : OpenTelemetry.Context.ThreadLocal- Copyright : (c) Ian Duncan, 2021- License : BSD-3- Description : State management for 'OpenTelemetry.Context.Context' on a per-thread basis.- Maintainer : Ian Duncan- Stability : experimental- Portability : non-portable (GHC extensions)+Manages the implicit 'Context' that flows through your application. The+@inSpan@ functions automatically push\/pop context here, so you rarely+need to use this module directly. - Thread-local contexts may be attached as implicit state at a per-Haskell-thread- level.+= Common operations - This module uses a fair amount of GHC internals to enable performing- lookups of context for any threads that are alive. Caution should be- taken for consumers of this module to not retain ThreadId references- indefinitely, as that could delay cleanup of thread-local state.+@+import OpenTelemetry.Context.ThreadLocal+import OpenTelemetry.Context (insertBaggage, lookupSpan) - Thread-local contexts have the following semantics:+-- Read the current context (contains active span + baggage):+ctx <- getContext - - A value 'attach'ed to a 'ThreadId' will remain alive at least as long- as the 'ThreadId'.- - A value may be detached from a 'ThreadId' via 'detach' by the- library consumer without detriment.- - No guarantees are made about when a value will be garbage-collected- once all references to 'ThreadId' have been dropped. However, this simply- means in practice that any unused contexts will cleaned up upon the next- garbage collection and may not be actively freed when the program exits.+-- Modify the current context (e.g. attach baggage):+adjustContext (insertBaggage myBaggage)++-- Attach context extracted from incoming headers:+tok <- attachContext extractedCtx+-- ... later ...+detachContext tok+@++= Token semantics++Per the OpenTelemetry specification, 'attachContext' returns an opaque 'Token'+that must be passed to 'detachContext' to restore the previous context. Tokens+enforce __LIFO ordering__: if you attach contexts A then B, you must detach B+before A. Detaching out of order logs a diagnostic error.++= When to use this module++* Reading the current span: @lookupSpan \<$\> getContext@+* Setting\/reading baggage on the current thread+* Manually attaching context after propagator extraction+* Implementing custom instrumentation middleware -} module OpenTelemetry.Context.ThreadLocal ( -- * Thread-local context++ -- ** Opaque token (spec-mandated attach\/detach handle)+ Token, getContext, lookupContext, attachContext, detachContext, adjustContext,+ getAndAdjustContext, + -- * Active baggage (implicit context)+ getActiveBaggage,+ setActiveBaggage,+ clearActiveBaggage,++ -- * Fused ref-based operations (zero CAS on hot path)++ --+ -- These operations use a per-thread IORef for direct reads and writes,+ -- eliminating all CAS contention from the span lifecycle hot path.+ ContextEntry (ceContext),+ emptyEntry,+ ensureContextRef,+ ensureContextRefFast,+ lookupContextRefFast,+ readContextRef,+ writeContextRef,+ -- ** Generalized thread-local context functions -- You should not use these without using some sort of specific cross-thread coordination mechanism,@@ -55,16 +90,66 @@ import Control.Concurrent import Control.Concurrent.Thread.Storage+import Control.Monad (when) import Control.Monad.IO.Class+import Data.IORef import Data.Maybe (fromMaybe)-import OpenTelemetry.Context (Context, empty)+import Data.Word (Word64)+import OpenTelemetry.Baggage (Baggage)+import OpenTelemetry.Context (Context, empty, insertBaggage, lookupBaggage, removeBaggage)+import OpenTelemetry.Internal.Logging (otelLogError) import System.IO.Unsafe import Prelude hiding (lookup) -type ThreadContextMap = ThreadStorageMap Context+{- | Per-thread context entry: the context plus the active token ID.+A token ID of 0 means no token is active (initial state).+-}+data ContextEntry = ContextEntry+ { ceContext :: !Context+ , ceTokenId :: {-# UNPACK #-} !Word64+ } +emptyEntry :: ContextEntry+emptyEntry = ContextEntry empty 0+{-# INLINE emptyEntry #-}+++{- | Opaque token returned by 'attachContext'.++Pass this to 'detachContext' to restore the context that was active before+the attach. The implementation validates LIFO ordering: detaching out of+order (i.e. with a token that doesn't match the most recent attach) logs+a diagnostic error per the OpenTelemetry specification.++Tokens are lightweight (three words) and do not hold resources that need+explicit cleanup. If a token is simply dropped without calling+'detachContext', nothing leaks — but you lose the LIFO validation for+that attach point.++@since 0.5.0.0+-}+data Token = Token+ { _tokenId :: {-# UNPACK #-} !Word64+ , _tokenPreviousContext :: !Context+ , _tokenPreviousTokenId :: {-# UNPACK #-} !Word64+ }+++type ThreadContextMap = ThreadStorageMap ContextEntry+++tokenCounter :: IORef Word64+tokenCounter = unsafePerformIO (newIORef 0)+{-# NOINLINE tokenCounter #-}+++nextTokenId :: IO Word64+nextTokenId = atomicModifyIORef' tokenCounter (\n -> let !n' = n + 1 in (n', n'))+{-# INLINE nextTokenId #-}++ {- | This is a global variable that is used to store the thread-local context map. It is not intended to be used directly for production purposes, but is exposed for debugging purposes. -}@@ -81,7 +166,12 @@ @since 0.0.1.0 -} getContext :: (MonadIO m) => m Context-getContext = fromMaybe empty <$> lookupContext+getContext = do+ me <- lookup threadContextMap+ pure $! case me of+ Nothing -> empty+ Just entry -> ceContext entry+{-# INLINE getContext #-} {- | Retrieve a stored 'Context' for the current thread, if it exists.@@ -89,7 +179,8 @@ @since 0.0.1.0 -} lookupContext :: (MonadIO m) => m (Maybe Context)-lookupContext = lookup threadContextMap+lookupContext = fmap (fmap ceContext) (lookup threadContextMap)+{-# INLINE lookupContext #-} {- | Retrieve a stored 'Context' for the provided 'ThreadId', if it exists.@@ -97,70 +188,217 @@ @since 0.0.1.0 -} lookupContextOnThread :: (MonadIO m) => ThreadId -> m (Maybe Context)-lookupContextOnThread = lookupOnThread threadContextMap+lookupContextOnThread tid = fmap (fmap ceContext) (lookupOnThread threadContextMap tid)+{-# INLINE lookupContextOnThread #-} -{- | Store a given 'Context' for the current thread, returning any context previously stored.+{- | Attach a 'Context' to the current thread, returning an opaque 'Token'. - @since 0.0.1.0+Pass the token to 'detachContext' to restore the previous context. Tokens+enforce LIFO ordering per the OpenTelemetry specification.++@since 0.5.0.0 -}-attachContext :: (MonadIO m) => Context -> m (Maybe Context)-attachContext = attach threadContextMap+attachContext :: (MonadIO m) => Context -> m Token+attachContext newCtx = liftIO $ do+ tokId <- nextTokenId+ update threadContextMap $ \mentry ->+ let !old = fromMaybe emptyEntry mentry+ !tok = Token tokId (ceContext old) (ceTokenId old)+ !new = ContextEntry newCtx tokId+ in (Just new, tok)+{-# INLINE attachContext #-} -{- | Store a given 'Context' for the provided 'ThreadId', returning any context previously stored.+{- | Attach a 'Context' to the provided 'ThreadId', returning an opaque 'Token'. - @since 0.0.1.0+@since 0.5.0.0 -}-attachContextOnThread :: (MonadIO m) => ThreadId -> Context -> m (Maybe Context)-attachContextOnThread = attachOnThread threadContextMap+attachContextOnThread :: (MonadIO m) => ThreadId -> Context -> m Token+attachContextOnThread tid newCtx = liftIO $ do+ tokId <- nextTokenId+ updateOnThread threadContextMap tid $ \mentry ->+ let !old = fromMaybe emptyEntry mentry+ !tok = Token tokId (ceContext old) (ceTokenId old)+ !new = ContextEntry newCtx tokId+ in (Just new, tok)+{-# INLINE attachContextOnThread #-} -{- | Remove a stored 'Context' for the current thread, returning any context previously stored.+{- | Restore the context that was active before the corresponding+'attachContext' call, using the provided 'Token'. -The detach functions don't generally need to be called manually, because finalizers will automatically-clean up contexts when a thread has completed and been garbage collected. If you are replacing a context-on a long-lived thread by detaching and attaching, use `adjustContext (const newContext)` instead to avoid-registering additional finalizer functions to be called on thread exit.+If the token does not match the most recently attached context on this+thread (LIFO violation), the implementation logs a diagnostic error per+the OpenTelemetry specification. The previous context is still restored+regardless. - @since 0.0.1.0+@since 0.5.0.0 -}-detachContext :: (MonadIO m) => m (Maybe Context)-detachContext = detach threadContextMap+detachContext :: (MonadIO m) => Token -> m ()+detachContext (Token expectedId prevCtx prevTokenId) = liftIO $ do+ mismatch <- update threadContextMap $ \mentry ->+ let !current = fromMaybe emptyEntry mentry+ !restored = ContextEntry prevCtx prevTokenId+ in (Just restored, ceTokenId current /= expectedId)+ when mismatch $+ otelLogError+ "Context detach token mismatch: LIFO ordering violated. \+ \This likely indicates a context leak — an attachContext call \+ \without a corresponding detachContext in the correct order."+{-# INLINE detachContext #-} -{- | Remove a stored 'Context' for the provided 'ThreadId', returning any context previously stored.--The detach functions don't generally need to be called manually, because finalizers will automatically-clean up contexts when a thread has completed and been garbage collected. If you are replacing a context-on a long-lived thread by detaching and attaching, use `adjustContext (const newContext)` instead to avoid-registering additional finalizer functions to be called on thread exit.+{- | Restore the context on the provided 'ThreadId' using the given 'Token'. - @since 0.0.1.0+@since 0.5.0.0 -}-detachContextFromThread :: (MonadIO m) => ThreadId -> m (Maybe Context)-detachContextFromThread = detachFromThread threadContextMap+detachContextFromThread :: (MonadIO m) => ThreadId -> Token -> m ()+detachContextFromThread tid (Token expectedId prevCtx prevTokenId) = liftIO $ do+ mismatch <- updateOnThread threadContextMap tid $ \mentry ->+ let !current = fromMaybe emptyEntry mentry+ !restored = ContextEntry prevCtx prevTokenId+ in (Just restored, ceTokenId current /= expectedId)+ when mismatch $+ otelLogError+ "Context detach token mismatch on remote thread: LIFO ordering violated."+{-# INLINE detachContextFromThread #-} {- | Alter the context on the current thread using the provided function. If there is not a context associated with the current thread, the function will-be applied to an empty context and the result will be stored+be applied to an empty context and the result will be stored. +This does not affect the active token — it modifies the context in place.+ @since 0.0.1.0 -} adjustContext :: (MonadIO m) => (Context -> Context) -> m ()-adjustContext f = update threadContextMap $ \mctx ->- (pure $ f $ fromMaybe empty mctx, ())+adjustContext f = update threadContextMap $ \mentry ->+ let !old = fromMaybe emptyEntry mentry+ !ctx' = f (ceContext old)+ in (Just (old {ceContext = ctx'}), ())+{-# INLINE adjustContext #-} -{- | Alter the context+{- | Atomically read the current context and replace it via @f@ in a single+operation, returning the old context. +@since 0.4.0.0+-}+getAndAdjustContext :: (MonadIO m) => (Context -> Context) -> m Context+getAndAdjustContext f = update threadContextMap $ \mentry ->+ let !old = fromMaybe emptyEntry mentry+ !ctx = ceContext old+ !new = f ctx+ in (Just (old {ceContext = new}), ctx)+{-# INLINE getAndAdjustContext #-}+++{- | Get or create the per-thread context IORef. On the first call per thread,+this inserts a new entry (flat-table CAS, once per thread lifetime). On all+subsequent calls the IORef is found via a single flat-table probe (no CAS).++Use 'readIORef' and 'writeIORef' on the returned 'IORef' for zero-overhead+context access on the hot path.++@since 0.5.0.0+-}+ensureContextRef :: ThreadId -> Int -> IO (IORef ContextEntry)+ensureContextRef tid tw = ensureRef threadContextMap tid tw emptyEntry+{-# INLINE ensureContextRef #-}+++{- | Fused CMM fast path: reads @CurrentTSO.id@ and probes the flat table+entirely in CMM, returning the per-thread context IORef. No 'ThreadId'+allocation, no FFI call, no 'Maybe' wrapper on the steady-state path.++Returns @(threadId, contextRef)@. The thread ID is returned for reuse+as the @thread.id@ span attribute.++First call per thread: falls back to 'myThreadId' + insert (one CAS).++@since 0.5.0.0+-}+ensureContextRefFast :: IO (Int, IORef ContextEntry)+ensureContextRefFast = ensureRefFast threadContextMap emptyEntry+{-# INLINE ensureContextRefFast #-}+++{- | Fused CMM probe: reads @CurrentTSO.id@ and probes the flat table+entirely in CMM. Returns @(threadId, Maybe (IORef ContextEntry))@.+The thread ID is returned for reuse on the slow path.++@since 0.5.0.0+-}+lookupContextRefFast :: IO (Int, Maybe (IORef ContextEntry))+lookupContextRefFast = lookupRefFast threadContextMap+{-# INLINE lookupContextRefFast #-}+++{- | Read just the 'Context' from a per-thread IORef.++For the hot path where you need both the entry and the context, prefer+reading the 'IORef' directly and using 'ceContext'.++@since 0.5.0.0+-}+readContextRef :: IORef ContextEntry -> IO Context+readContextRef ref = ceContext <$> readIORef ref+{-# INLINE readContextRef #-}+++{- | Write a 'Context' to a per-thread IORef, preserving the active token ID.+Only the owning thread should call this.++For the hot path (e.g. 'inSpanInternal'), prefer writing the full+'ContextEntry' via 'writeIORef' to avoid the read-modify-write.++@since 0.5.0.0+-}+writeContextRef :: IORef ContextEntry -> Context -> IO ()+writeContextRef ref ctx = modifyIORef' ref (\e -> e {ceContext = ctx})+{-# INLINE writeContextRef #-}+++{- | Alter the context on the provided thread.+ If there is not a context associated with the provided thread, the function will-be applied to an empty context and the result will be stored+be applied to an empty context and the result will be stored. @since 0.0.1.0 -} adjustContextOnThread :: (MonadIO m) => ThreadId -> (Context -> Context) -> m ()-adjustContextOnThread tid f = updateOnThread threadContextMap tid $ \mctx ->- (pure $ f $ fromMaybe empty mctx, ())+adjustContextOnThread tid f = updateOnThread threadContextMap tid $ \mentry ->+ let !old = fromMaybe emptyEntry mentry+ !ctx' = f (ceContext old)+ in (Just (old {ceContext = ctx'}), ())+{-# INLINE adjustContextOnThread #-}+++{- | Get the currently active 'Baggage' from the implicit thread-local context.++@since 0.4.0.0+-}+getActiveBaggage :: (MonadIO m) => m (Maybe Baggage)+getActiveBaggage = lookupBaggage <$> getContext+{-# INLINE getActiveBaggage #-}+++{- | Set the currently active 'Baggage' in the implicit thread-local context.++@since 0.4.0.0+-}+setActiveBaggage :: (MonadIO m) => Baggage -> m ()+setActiveBaggage b = adjustContext (insertBaggage b)+{-# INLINE setActiveBaggage #-}+++{- | Clear the active 'Baggage' from the implicit thread-local context.++@since 0.4.0.0+-}+clearActiveBaggage :: (MonadIO m) => m ()+clearActiveBaggage = adjustContext removeBaggage+{-# INLINE clearActiveBaggage #-}
+ src/OpenTelemetry/Context/ThreadLocal/Propagation.hs view
@@ -0,0 +1,155 @@+{- |+Module : OpenTelemetry.Context.ThreadLocal.Propagation+Copyright : (c) Ian Duncan, 2021+License : BSD-3+Description : Primitives for carrying OpenTelemetry context across thread boundaries.+Maintainer : Ian Duncan+Stability : experimental+Portability : non-portable (GHC extensions)++Haskell's green threads do not inherit thread-local state. Any time you+fork a thread, directly with 'Control.Concurrent.forkIO', or indirectly+through @async@, @mapConcurrently@, etc., the child starts with an+empty 'Context'. This silently breaks trace propagation and baggage+flow.++This module provides drop-in replacements for common concurrency+primitives that capture the caller's 'Context' and install it in the+child thread before running the user action. The pattern mirrors+Go's explicit @ctx@ parameter and Java\/Python's automatic context+inheritance for child tasks.++== Quick start++@+import OpenTelemetry.Context.ThreadLocal.Propagation++-- Instead of @async work@:+a <- tracedAsync work++-- Instead of @forkIO work@:+tid <- tracedForkIO work++-- Instead of @mapConcurrently f xs@:+results <- tracedMapConcurrently f xs+@++If you need to integrate with a concurrency primitive not covered here,+use 'propagateContext' to wrap any @IO@ action so it inherits the+current thread's context:++@+myCustomFork action = customFork (propagateContext action)+@++@since 0.4.0.0+-}+module OpenTelemetry.Context.ThreadLocal.Propagation (+ -- * Core combinator+ propagateContext,++ -- * Common concurrency wrappers+ tracedForkIO,+ tracedAsync,+ tracedWithAsync,+ tracedConcurrently,+ tracedMapConcurrently,+ tracedForConcurrently,+) where++import Control.Concurrent (ThreadId, forkIO)+import Control.Concurrent.Async (Async, async, concurrently, forConcurrently, mapConcurrently, withAsync)+import OpenTelemetry.Context (Context)+import OpenTelemetry.Context.ThreadLocal (attachContext, getContext)+++{- | Capture the current thread's 'Context' and return an action that,+when run in /any/ thread, installs that context before executing the+wrapped computation.++This is the fundamental building block. The other combinators in this+module are thin wrappers around it.++@since 0.4.0.0+-}+propagateContext :: IO a -> IO (IO a)+propagateContext action = do+ ctx <- getContext+ pure (installContext ctx >> action)+{-# INLINE propagateContext #-}+++{- | 'forkIO' with automatic context propagation.++@since 0.4.0.0+-}+tracedForkIO :: IO () -> IO ThreadId+tracedForkIO action = do+ wrapped <- propagateContext action+ forkIO wrapped+{-# INLINE tracedForkIO #-}+++{- | 'async' with automatic context propagation.++@since 0.4.0.0+-}+tracedAsync :: IO a -> IO (Async a)+tracedAsync action = do+ wrapped <- propagateContext action+ async wrapped+{-# INLINE tracedAsync #-}+++{- | 'withAsync' with automatic context propagation.++@since 0.4.0.0+-}+tracedWithAsync :: IO a -> (Async a -> IO b) -> IO b+tracedWithAsync action k = do+ wrapped <- propagateContext action+ withAsync wrapped k+{-# INLINE tracedWithAsync #-}+++{- | 'concurrently' with automatic context propagation for both branches.++@since 0.4.0.0+-}+tracedConcurrently :: IO a -> IO b -> IO (a, b)+tracedConcurrently left right = do+ l <- propagateContext left+ r <- propagateContext right+ concurrently l r+{-# INLINE tracedConcurrently #-}+++{- | 'mapConcurrently' with automatic context propagation.++Each concurrent worker inherits the caller's context.++@since 0.4.0.0+-}+tracedMapConcurrently :: (Traversable t) => (a -> IO b) -> t a -> IO (t b)+tracedMapConcurrently f ta = do+ ctx <- getContext+ mapConcurrently (\a -> installContext ctx >> f a) ta+{-# INLINE tracedMapConcurrently #-}+++{- | 'forConcurrently' with automatic context propagation.++@since 0.4.0.0+-}+tracedForConcurrently :: (Traversable t) => t a -> (a -> IO b) -> IO (t b)+tracedForConcurrently ta f = do+ ctx <- getContext+ forConcurrently ta (\a -> installContext ctx >> f a)+{-# INLINE tracedForConcurrently #-}+++installContext :: Context -> IO ()+installContext ctx = do+ _ <- attachContext ctx+ pure ()+{-# INLINE installContext #-}
src/OpenTelemetry/Context/Types.hs view
@@ -1,23 +1,49 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE UnboxedSums #-}+ module OpenTelemetry.Context.Types where import Data.Text (Text) import qualified Data.Vault.Strict as V+import GHC.Exts (Any)+import OpenTelemetry.Baggage (Baggage)+import OpenTelemetry.Internal.UnpackedMaybe -{- | A `Context` is a propagation mechanism which carries execution-scoped values+{- | A @Context@ is a propagation mechanism which carries execution-scoped values across API boundaries and between logically associated execution units. Cross-cutting concerns access their data in-process using the same shared- `Context` object+ @Context@ object.++ The span and baggage slots use UMaybe (unboxed sums) for zero-indirection+ access when UNPACKed into the Context closure. All other keys go through+ the vault. -}-newtype Context = Context V.Vault+data Context = Context+ { ctxSpanSlot :: {-# UNPACK #-} !(UMaybe Any)+ , ctxBaggageSlot :: {-# UNPACK #-} !(UMaybe Baggage)+ , ctxVault :: !V.Vault+ } instance Semigroup Context where- (<>) (Context l) (Context r) = Context (V.union l r)+ (<>) (Context s1 b1 v1) (Context s2 b2 v2) =+ Context+ (orElse s2 s1)+ (mergeBaggage b1 b2)+ (V.union v1 v2)+ where+ orElse UNothing x = x+ orElse x _ = x+ {-# INLINE orElse #-}+ mergeBaggage UNothing r = r+ mergeBaggage l UNothing = l+ mergeBaggage (UJust l) (UJust r) = UJust (l <> r)+ {-# INLINE mergeBaggage #-} instance Monoid Context where- mempty = Context V.empty+ mempty = Context UNothing UNothing V.empty {- | Keys are used to allow cross-cutting concerns to control access to their local state.
src/OpenTelemetry/Contrib/CarryOns.hs view
@@ -1,3 +1,11 @@+{- |+Module : OpenTelemetry.Contrib.CarryOns+Description : Carry-on attributes that propagate from parent to child spans.+Stability : experimental++Carry-ons are extra attributes merged into spans completed within a thread's+context, so values can flow down a trace without attaching them to every span.+-} module OpenTelemetry.Contrib.CarryOns ( alterCarryOns, withCarryOnProcessor,@@ -5,9 +13,8 @@ import Control.Monad.IO.Class import qualified Data.HashMap.Strict as H-import Data.IORef (modifyIORef')+import Data.IORef (atomicModifyIORef') import Data.Maybe (fromMaybe)-import Data.Text (Text) import qualified OpenTelemetry.Attributes as Attributes import OpenTelemetry.Attributes.Map (AttributeMap) import OpenTelemetry.Context@@ -22,6 +29,7 @@ {-# NOINLINE carryOnKey #-} +-- | @since 0.4.0.0 alterCarryOns :: (MonadIO m) => (AttributeMap -> AttributeMap) -> m () alterCarryOns f = adjustContext $ \ctxt -> Context.insert carryOnKey (f $ fromMaybe mempty $ Context.lookup carryOnKey ctxt) ctxt@@ -34,27 +42,30 @@ Be cautious about adding too many additional attributes via carry ons. The attributes are added to every span, and will be discarded if the span has attributes that exceed the configured attribute limits for the configured 'TracerProvider'.++ @since 0.4.0.0 -} withCarryOnProcessor :: SpanProcessor -> SpanProcessor withCarryOnProcessor p = SpanProcessor { spanProcessorOnStart = spanProcessorOnStart p- , spanProcessorOnEnd = \spanRef -> do+ , spanProcessorOnEnd = \imm -> do ctxt <- getContext let carryOns = fromMaybe mempty $ Context.lookup carryOnKey ctxt if H.null carryOns then pure () else do- -- I doubt we need atomicity at this point. Hopefully people aren't trying to modify the same span after it has ended from multiple threads.- modifyIORef' spanRef $ \is ->- is- { spanAttributes =- Attributes.addAttributes- (tracerProviderAttributeLimits $ tracerProvider $ spanTracer is)- (spanAttributes is)- carryOns- }- spanProcessorOnEnd p spanRef+ atomicModifyIORef' (spanHot imm) $ \h ->+ ( h+ { hotAttributes =+ Attributes.addAttributes+ (tracerProviderAttributeLimits $ tracerProvider $ spanTracer imm)+ (hotAttributes h)+ carryOns+ }+ , ()+ )+ spanProcessorOnEnd p imm , spanProcessorShutdown = spanProcessorShutdown p , spanProcessorForceFlush = spanProcessorForceFlush p }
src/OpenTelemetry/Contrib/SpanTraversals.hs view
@@ -11,16 +11,21 @@ data IterationInstruction a = Continue a | Halt -{- | Alter traces upwards from the provides span to the highest available mutable span. Only mutable spans may be altered.+{- | Alter traces upwards from the provided span to the highest available mutable span. - The step value indicates whether the desired topmost span has been reached or not. This function will continue to iterate- upwards until either a span that cannot be mutated has been reached, or there are no more parent spans remaining.+The callback receives the 'ImmutableSpan' (for reading cold fields like parent)+and the current 'SpanHot' (for reading\/modifying mutable fields). It returns an+'IterationInstruction' and the (possibly modified) 'SpanHot'.++Iteration continues upward until a non-mutable span is reached, there are no+more parents, or the callback returns 'Halt'. -}-alterSpansUpwards :: (MonadIO m) => Span -> st -> (st -> ImmutableSpan -> (IterationInstruction st, ImmutableSpan)) -> m st-alterSpansUpwards (Span immutableSpanRef) st f = liftIO $ do- (step, a') <- atomicModifyIORef' immutableSpanRef (\a -> let (step, a') = f st a in (a', (step, a')))+alterSpansUpwards :: (MonadIO m) => Span -> st -> (st -> ImmutableSpan -> SpanHot -> (IterationInstruction st, SpanHot)) -> m st+alterSpansUpwards (Span imm) st f = liftIO $ do+ step <- atomicModifyIORef' (spanHot imm) $ \h ->+ let (step, h') = f st imm h in (h', step) case step of- Continue st' -> case spanParent a' of+ Continue st' -> case spanParent imm of Nothing -> return st' Just s -> alterSpansUpwards s st' f Halt -> return st
+ src/OpenTelemetry/Debug/MetricExport.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : OpenTelemetry.Debug.MetricExport+Copyright : (c) Ian Duncan, 2026+License : BSD-3+Description : Human-readable rendering of 'ResourceMetricsExport' batches for tests and debugging.+Stability : experimental++This is not a stable interchange format.+-}+module OpenTelemetry.Debug.MetricExport (+ renderResourceMetricsExportDebug,+) where++import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Data.Text.Lazy.Builder (Builder, fromText, toLazyText)+import Data.Text.Lazy.Builder.Int (decimal)+import qualified Data.Vector as V+import OpenTelemetry.Exporter.Metric (+ MetricExport (..),+ ResourceMetricsExport (..),+ ScopeMetricsExport (..),+ )+++{- | Multi-line text summary (not Prometheus or OTLP format).++@since 0.0.1.0+-}+renderResourceMetricsExportDebug :: [ResourceMetricsExport] -> Text+renderResourceMetricsExportDebug rs =+ T.intercalate "\n---\n" (fmap renderResource rs)+++renderResource :: ResourceMetricsExport -> Text+renderResource ResourceMetricsExport {..} =+ T.intercalate "\n" $+ "ResourceMetricsExport"+ : fmap renderScope (V.toList resourceMetricsScopes)+++renderScope :: ScopeMetricsExport -> Text+renderScope ScopeMetricsExport {..} =+ T.intercalate "\n" $+ " ScopeMetricsExport"+ : fmap (\m -> T.append " " (renderMetric m)) (V.toList scopeMetricsExports)+++renderMetric :: MetricExport -> Text+renderMetric = TL.toStrict . toLazyText . renderMetricB+++renderMetricB :: MetricExport -> Builder+renderMetricB = \case+ MetricExportSum n d u _ m i _ pts ->+ "Sum "+ <> fromText n+ <> " "+ <> fromText d+ <> " "+ <> fromText u+ <> " monotonic="+ <> showBool m+ <> " isInt="+ <> showBool i+ <> " nPts="+ <> decimal (V.length pts)+ MetricExportHistogram n d u _ _ pts ->+ "Histogram "+ <> fromText n+ <> " "+ <> fromText d+ <> " "+ <> fromText u+ <> " nPts="+ <> decimal (V.length pts)+ MetricExportExponentialHistogram n d u _ _ pts ->+ "ExponentialHistogram "+ <> fromText n+ <> " "+ <> fromText d+ <> " "+ <> fromText u+ <> " nPts="+ <> decimal (V.length pts)+ MetricExportGauge n d u _ i pts ->+ "Gauge "+ <> fromText n+ <> " "+ <> fromText d+ <> " "+ <> fromText u+ <> " isInt="+ <> showBool i+ <> " nPts="+ <> decimal (V.length pts)+++showBool :: Bool -> Builder+showBool True = "True"+showBool False = "False"
src/OpenTelemetry/Environment.hs view
@@ -1,9 +1,33 @@+{- |+Module : OpenTelemetry.Environment+Copyright : (c) Ian Duncan, 2024-2026+License : BSD-3+Description : Read standard OTEL_* environment variables for SDK configuration.+Stability : experimental++Helpers for reading OpenTelemetry environment variables that control exporter+selection, metric export intervals, exemplar filters, and log exporter choice.+Used by the SDK during provider initialization.+-} module OpenTelemetry.Environment ( lookupBooleanEnv,+ readEnv,+ readEnvDefault,+ readEnvDefaultWithAlias,+ MetricsExporterSelection (..),+ lookupMetricsExporterSelection,+ lookupMetricExportIntervalMillis,+ lookupMetricExportTimeoutMillis,+ MetricsExemplarFilter (..),+ lookupMetricsExemplarFilter,+ LogsExporterSelection (..),+ lookupLogsExporterSelection, ) where import qualified Data.Char as C+import Data.List (dropWhileEnd) import System.Environment (lookupEnv)+import Text.Read (readMaybe) {- | Does the given value of an environment variable correspond to "true" according@@ -15,3 +39,142 @@ lookupBooleanEnv :: String -> IO Bool lookupBooleanEnv = fmap (maybe False isTrue) . lookupEnv+++-- | Read an environment variable and parse it with 'readMaybe'. Returns 'Nothing' if unset or unparseable.+readEnv :: (Read a) => String -> IO (Maybe a)+readEnv k = (>>= readMaybe) <$> lookupEnv k+++-- | Like 'readEnv' but falls back to a default value if the variable is unset or unparseable.+readEnvDefault :: (Read a) => String -> a -> IO a+readEnvDefault k def = maybe def id <$> readEnv k+++{- | Like 'readEnvDefault' but tries a primary key first, then a legacy alias.+Useful when an env var was renamed to maintain backwards compatibility.+-}+readEnvDefaultWithAlias :: (Read a) => String -> String -> a -> IO a+readEnvDefaultWithAlias primary fallback def = do+ mv <- readEnv primary+ case mv of+ Just v -> pure v+ Nothing -> readEnvDefault fallback def+++{- | Parsed value of @OTEL_METRICS_EXPORTER@ (first entry if comma-separated).+See <https://opentelemetry.io/docs/specs/otel/configuration/sdk-environment-variables/#exporter-selection>.+-}+data MetricsExporterSelection+ = MetricsExporterNone+ | MetricsExporterOtlp+ | MetricsExporterPrometheus+ | MetricsExporterConsole+ | -- | A name not in the built-in set; looked up via the exporter registry.+ MetricsExporterCustom !String+ deriving (Eq, Show)+++trimSpaces :: String -> String+trimSpaces = dropWhile C.isSpace . dropWhileEnd C.isSpace+++-- | Read @OTEL_METRICS_EXPORTER@. Unknown or empty values return 'Nothing' (caller may default to OTLP).+lookupMetricsExporterSelection :: IO (Maybe MetricsExporterSelection)+lookupMetricsExporterSelection = do+ me <- lookupEnv "OTEL_METRICS_EXPORTER"+ case me of+ Nothing -> pure Nothing+ Just raw ->+ let firstSeg = trimSpaces $ case break (== ',') raw of+ (a, _) -> a+ key = map C.toLower $ trimSpaces firstSeg+ in pure $ case key of+ "" -> Nothing+ "none" -> Just MetricsExporterNone+ "otlp" -> Just MetricsExporterOtlp+ "prometheus" -> Just MetricsExporterPrometheus+ "console" -> Just MetricsExporterConsole+ other -> Just (MetricsExporterCustom other)+++{- | Read @OTEL_METRIC_EXPORT_INTERVAL@ (milliseconds between periodic export cycles).+See <https://opentelemetry.io/docs/specs/otel/configuration/sdk-environment-variables/>.+-}+lookupMetricExportIntervalMillis :: IO (Maybe Int)+lookupMetricExportIntervalMillis = do+ me <- lookupEnv "OTEL_METRIC_EXPORT_INTERVAL"+ pure $ case me >>= readMaybe . trimSpaces of+ Just n | n > 0 -> Just n+ _ -> Nothing+++{- | Read @OTEL_METRIC_EXPORT_TIMEOUT@ (milliseconds allowed per export call).+See <https://opentelemetry.io/docs/specs/otel/configuration/sdk-environment-variables/>.+-}+lookupMetricExportTimeoutMillis :: IO (Maybe Int)+lookupMetricExportTimeoutMillis = do+ me <- lookupEnv "OTEL_METRIC_EXPORT_TIMEOUT"+ pure $ case me >>= readMaybe . trimSpaces of+ Just n | n > 0 -> Just n+ _ -> Nothing+++{- | Parsed value of @OTEL_LOGS_EXPORTER@ (first entry if comma-separated).+See <https://opentelemetry.io/docs/specs/otel/configuration/sdk-environment-variables/#exporter-selection>.++@since 0.4.0.0+-}+data LogsExporterSelection+ = LogsExporterNone+ | LogsExporterOtlp+ | LogsExporterConsole+ | -- | A name not in the built-in set; looked up via the exporter registry.+ LogsExporterCustom !String+ deriving (Eq, Show)+++{- | Read @OTEL_LOGS_EXPORTER@. Empty values return 'Nothing' (caller defaults to OTLP).+Unknown names are returned as 'LogsExporterCustom' for registry lookup.+-}+lookupLogsExporterSelection :: IO (Maybe LogsExporterSelection)+lookupLogsExporterSelection = do+ me <- lookupEnv "OTEL_LOGS_EXPORTER"+ case me of+ Nothing -> pure Nothing+ Just raw ->+ let firstSeg = trimSpaces $ case break (== ',') raw of+ (a, _) -> a+ key = map C.toLower $ trimSpaces firstSeg+ in pure $ case key of+ "" -> Nothing+ "none" -> Just LogsExporterNone+ "otlp" -> Just LogsExporterOtlp+ "console" -> Just LogsExporterConsole+ other -> Just (LogsExporterCustom other)+++-- | Parsed @OTEL_METRICS_EXEMPLAR_FILTER@ (when present).+data MetricsExemplarFilter+ = MetricsExemplarFilterTraceBased+ | MetricsExemplarFilterAlwaysOn+ | MetricsExemplarFilterAlwaysOff+ deriving (Eq, Show)+++-- | Read @OTEL_METRICS_EXEMPLAR_FILTER@ (first segment if comma-separated). Unknown values return 'Nothing'.+lookupMetricsExemplarFilter :: IO (Maybe MetricsExemplarFilter)+lookupMetricsExemplarFilter = do+ me <- lookupEnv "OTEL_METRICS_EXEMPLAR_FILTER"+ case me of+ Nothing -> pure Nothing+ Just raw ->+ let firstSeg = trimSpaces $ case break (== ',') raw of+ (a, _) -> a+ key = map C.toLower $ trimSpaces firstSeg+ in pure $ case key of+ "" -> Nothing+ "trace_based" -> Just MetricsExemplarFilterTraceBased+ "always_on" -> Just MetricsExemplarFilterAlwaysOn+ "always_off" -> Just MetricsExemplarFilterAlwaysOff+ _ -> Nothing
src/OpenTelemetry/Exporter.hs view
@@ -1,16 +1,24 @@ {-# LANGUAGE PatternSynonyms #-} +{- |+Module : OpenTelemetry.Exporter+Description : Re-exports of span exporter types.+Stability : experimental++This module is deprecated; prefer 'OpenTelemetry.Exporter.Span'.+-} module OpenTelemetry.Exporter {-# DEPRECATED "use OpenTelemetry.Exporter.Span instead" #-} ( Exporter,- SpanExporter (Exporter, exporterExport, exporterShutdown),+ mkExporter,+ SpanExporter (..), ExportResult (..), ) where import Data.HashMap.Strict (HashMap) import Data.Vector (Vector) import OpenTelemetry.Exporter.Span-import OpenTelemetry.Internal.Common.Types (InstrumentationLibrary)+import OpenTelemetry.Internal.Common.Types (FlushResult (..), InstrumentationLibrary, ShutdownResult (..)) import OpenTelemetry.Internal.Trace.Types (ImmutableSpan) @@ -20,9 +28,11 @@ type Exporter a = SpanExporter -pattern Exporter :: (HashMap InstrumentationLibrary (Vector ImmutableSpan) -> IO ExportResult) -> IO () -> Exporter ImmutableSpan-pattern Exporter {exporterExport, exporterShutdown} =+{-# DEPRECATED mkExporter "use SpanExporter constructor directly" #-}+mkExporter :: (HashMap InstrumentationLibrary (Vector ImmutableSpan) -> IO ExportResult) -> IO () -> Exporter ImmutableSpan+mkExporter export shutdown = SpanExporter- { spanExporterExport = exporterExport- , spanExporterShutdown = exporterShutdown+ { spanExporterExport = export+ , spanExporterShutdown = shutdown >> pure ShutdownSuccess+ , spanExporterForceFlush = pure FlushSuccess }
src/OpenTelemetry/Exporter/LogRecord.hs view
@@ -1,3 +1,8 @@+{- |+Module : OpenTelemetry.Exporter.LogRecord+Description : Re-exports of log record exporter types.+Stability : experimental+-} module OpenTelemetry.Exporter.LogRecord ( LogRecordExporter, LogRecordExporterArguments (..),@@ -8,7 +13,7 @@ ShutdownResult (..), ) where -import OpenTelemetry.Internal.Logs.Types (+import OpenTelemetry.Internal.Log.Types ( LogRecordExporter, LogRecordExporterArguments (..), logRecordExporterExport,
+ src/OpenTelemetry/Exporter/Metric.hs view
@@ -0,0 +1,8 @@+-- | Push metric exporter interface (specification/metrics/sdk.md, MetricExporter).+module OpenTelemetry.Exporter.Metric (+ MetricExporter (..),+ module OpenTelemetry.Internal.Metric.Export,+) where++import OpenTelemetry.Internal.Metric.Export+
+ src/OpenTelemetry/Internal/AtomicBucketArray.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}++{- |+Module : OpenTelemetry.Internal.AtomicBucketArray+Copyright : (c) Ian Duncan, 2024-2026+License : BSD-3+Description : Contiguous array of atomic counters for histogram bucket counts.+Stability : experimental++One 'MutableByteArray#' holds all bucket counts in a single allocation,+indexed by bucket number. Each slot supports atomic fetch-and-add via+@fetchAddIntArray#@, a single @ldadd@ (AArch64) or @lock xadd@ (x86)+instruction with no CAS retry and no allocation.++Used to eliminate the O(n) bucket vector copy that 'Data.Vector.Unboxed.modify'+performs on every histogram recording inside an @atomicModifyIORef'@ CAS loop.+-}+module OpenTelemetry.Internal.AtomicBucketArray (+ AtomicBucketArray,+ newAtomicBucketArray,+ atomicAddBucket,+ readBucketArray,+ readAndResetBucketArray,+) where+++#include "MachDeps.h"++import Data.Vector.Unboxed (Vector)+import qualified Data.Vector.Unboxed as U+import Data.Word (Word64)+import GHC.Exts (+ Int (..),+ Int#,+ MutableByteArray#,+ RealWorld,+ State#,+ fetchAddIntArray#,+ isTrue#,+ negateInt#,+ newByteArray#,+ readIntArray#,+ writeIntArray#,+ (*#),+ (+#),+ (>=#),+ )+import GHC.IO (IO (..))+++{- | Contiguous mutable array of atomic counters. Each element is one+machine-word 'Int', accessible via hardware fetch-and-add.++@since 0.0.1.0+-}+data AtomicBucketArray = AtomicBucketArray (MutableByteArray# RealWorld) Int#+++{- | Allocate a new bucket array with all counters initialized to zero.++@since 0.0.1.0+-}+newAtomicBucketArray :: Int -> IO AtomicBucketArray+newAtomicBucketArray (I# n) = IO $ \s ->+ let !nbytes = n *# SIZEOF_HSINT#+ in case newByteArray# nbytes s of+ (# s1, arr #) -> case zeroFill arr n s1 of+ s2 -> (# s2, AtomicBucketArray arr n #)+++zeroFill :: MutableByteArray# RealWorld -> Int# -> State# RealWorld -> State# RealWorld+zeroFill arr nwords s0 = go 0# s0+ where+ go i s+ | isTrue# (i >=# nwords) = s+ | otherwise = case writeIntArray# arr i 0# s of+ s' -> go (i +# 1#) s'+++{- | Atomically increment the bucket at the given index by 1.+No bounds checking.++@since 0.0.1.0+-}+atomicAddBucket :: AtomicBucketArray -> Int -> IO ()+atomicAddBucket (AtomicBucketArray arr _) (I# i) = IO $ \s ->+ case fetchAddIntArray# arr i 1# s of+ (# s', _ #) -> (# s', () #)+{-# INLINE atomicAddBucket #-}+++{- | Read all bucket values into an immutable 'U.Vector Word64'.+Each element is read individually; not globally atomic across buckets+(acceptable for metric snapshots).++@since 0.0.1.0+-}+readBucketArray :: AtomicBucketArray -> IO (Vector Word64)+readBucketArray (AtomicBucketArray arr len) = do+ let !n = I# len+ U.generateM n $ \(I# i) -> IO $ \s ->+ case readIntArray# arr i s of+ (# s', v #) -> (# s', fromIntegral (I# v) #)+{-# INLINE readBucketArray #-}+++{- | Read all bucket values and atomically reset each to zero.+Uses fetch-and-add with the negated current value.+Between the read and the subtract another thread may increment,+but the net effect is correct across consecutive delta collections:+no sample is lost, at worst one sample shifts to the next cycle.++@since 0.0.1.0+-}+readAndResetBucketArray :: AtomicBucketArray -> IO (Vector Word64)+readAndResetBucketArray (AtomicBucketArray arr len) = do+ let !n = I# len+ U.generateM n $ \(I# i) -> IO $ \s ->+ case readIntArray# arr i s of+ (# s1, old #) -> case fetchAddIntArray# arr i (negateInt# old) s1 of+ (# s2, _ #) -> (# s2, fromIntegral (I# old) #)+{-# INLINE readAndResetBucketArray #-}
+ src/OpenTelemetry/Internal/AtomicCounter.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}++{- |+Module : OpenTelemetry.Internal.AtomicCounter+Copyright : (c) Ian Duncan, 2024-2026+License : BSD-3+Description : Machine-word atomic counter using hardware fetch-and-add.+Stability : experimental++Unlike @atomicModifyIORef'@ which does a CAS retry loop on the boxed+@IORef@ closure, these operations compile down to a single+@lock xadd@ (x86) or @ldadd@ (AArch64) instruction with no+allocation and no retry.+-}+module OpenTelemetry.Internal.AtomicCounter (+ AtomicCounter,+ newAtomicCounter,+ incrAtomicCounter,+ addAtomicCounter,+ fetchAddAtomicCounter,+ readAtomicCounter,+ writeAtomicCounter,+) where+++#include "MachDeps.h"++import GHC.Exts (+ Int (..),+ MutableByteArray#,+ RealWorld,+ fetchAddIntArray#,+ newByteArray#,+ readIntArray#,+ writeIntArray#,+ (+#),+ )+import GHC.IO (IO (..))+++{- | A mutable atomic counter backed by a single unboxed machine-word 'Int'.++Uses hardware fetch-and-add (@fetchAddIntArray#@) instead of CAS retry+loops, making increment\/add O(1) regardless of contention.+-}+data AtomicCounter = AtomicCounter (MutableByteArray# RealWorld)+++-- | Create a new counter initialized to the given value.+newAtomicCounter :: Int -> IO AtomicCounter+newAtomicCounter (I# n) = IO $ \s ->+ case newByteArray# SIZEOF_HSINT# s of+ (# s1, arr #) -> case writeIntArray# arr 0# n s1 of+ s2 -> (# s2, AtomicCounter arr #)+++-- | Atomically increment the counter by 1. Returns the value /after/ the increment.+incrAtomicCounter :: AtomicCounter -> IO Int+incrAtomicCounter = addAtomicCounter 1+{-# INLINE incrAtomicCounter #-}+++-- | Atomically add to the counter. Returns the value /after/ the add.+addAtomicCounter :: Int -> AtomicCounter -> IO Int+addAtomicCounter (I# incr) (AtomicCounter arr) = IO $ \s ->+ case fetchAddIntArray# arr 0# incr s of+ (# s', old #) -> (# s', I# (old +# incr) #)+{-# INLINE addAtomicCounter #-}+++{- | Atomically add to the counter. Returns the value /before/ the add.+Useful for monotonic ID allocation.+-}+fetchAddAtomicCounter :: Int -> AtomicCounter -> IO Int+fetchAddAtomicCounter (I# incr) (AtomicCounter arr) = IO $ \s ->+ case fetchAddIntArray# arr 0# incr s of+ (# s', old #) -> (# s', I# old #)+{-# INLINE fetchAddAtomicCounter #-}+++{- | Read the current counter value.++This is a relaxed read; no ordering guarantee relative to concurrent adds+on other cores. Fine for diagnostics and metrics.+-}+readAtomicCounter :: AtomicCounter -> IO Int+readAtomicCounter (AtomicCounter arr) = IO $ \s ->+ case readIntArray# arr 0# s of+ (# s', val #) -> (# s', I# val #)+{-# INLINE readAtomicCounter #-}+++-- | Overwrite the counter value. Not atomic with respect to concurrent adds.+writeAtomicCounter :: AtomicCounter -> Int -> IO ()+writeAtomicCounter (AtomicCounter arr) (I# n) = IO $ \s ->+ case writeIntArray# arr 0# n s of+ s' -> (# s', () #)+{-# INLINE writeAtomicCounter #-}
src/OpenTelemetry/Internal/Common/Types.hs view
@@ -8,12 +8,24 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} +{- |+Module : OpenTelemetry.Internal.Common.Types+Description : Internal types shared across API signals: InstrumentationLibrary, ShutdownResult, FlushResult.+Stability : experimental+-} module OpenTelemetry.Internal.Common.Types ( InstrumentationLibrary (..),+ InstrumentationScope,+ instrumentationLibrary,+ instrumentationScope,+ withSchemaUrl,+ withLibraryAttributes, AnyValue (..), ToValue (..), ShutdownResult (..),+ worstShutdown, FlushResult (..),+ worstFlush, ExportResult (..), parseInstrumentationLibrary, detectInstrumentationLibrary,@@ -21,6 +33,7 @@ import Control.Exception (SomeException) import Data.ByteString (ByteString)+import Data.Char (isAlphaNum, isDigit) import Data.Data (Data) import qualified Data.HashMap.Strict as H import Data.Hashable (Hashable)@@ -32,23 +45,17 @@ import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Syntax as TH import OpenTelemetry.Attributes (Attributes, emptyAttributes)-import Text.Regex.TDFA ((=~~)) -{- | An identifier for the library that provides the instrumentation for a given Instrumented Library.- Instrumented Library and Instrumentation Library may be the same library if it has built-in OpenTelemetry instrumentation.-- The inspiration of the OpenTelemetry project is to make every library and application observable out of the box by having them call OpenTelemetry API directly.- However, many libraries will not have such integration, and as such there is a need for a separate library which would inject such calls, using mechanisms such as wrapping interfaces,- subscribing to library-specific callbacks, or translating existing telemetry into the OpenTelemetry model.-- A library that enables OpenTelemetry observability for another library is called an Instrumentation Library.-- An instrumentation library should be named to follow any naming conventions of the instrumented library (e.g. 'middleware' for a web framework).+{- | An instrumentation scope identifies the library or component providing+instrumentation. The OpenTelemetry specification renamed this concept from+\"Instrumentation Library\" to \"Instrumentation Scope\"; this type retains+the old constructor name for backwards compatibility but 'InstrumentationScope'+is the preferred type alias. - If there is no established name, the recommendation is to prefix packages with "hs-opentelemetry-instrumentation", followed by the instrumented library name itself.+Spec: <https://opentelemetry.io/docs/specs/otel/common/instrumentation-scope/> - In general, the simplest way to get the instrumentation library is to use 'detectInstrumentationLibrary', which uses the Haskell package name and version.+@since 0.0.1.0 -} data InstrumentationLibrary = InstrumentationLibrary { libraryName :: {-# UNPACK #-} !Text@@ -69,6 +76,69 @@ fromString str = InstrumentationLibrary (fromString str) "" "" emptyAttributes +{- | Preferred alias matching the current OpenTelemetry specification terminology+(\"Instrumentation Scope\"). Identical to 'InstrumentationLibrary'.++Spec: <https://opentelemetry.io/docs/specs/otel/common/instrumentation-scope/>++@since 0.4.0.0+-}+type InstrumentationScope = InstrumentationLibrary+++{- | Create an 'InstrumentationScope' with a name and version.+Schema URL and attributes default to empty.++@+let scope = instrumentationScope "my-service" "1.2.0"+@++For more fields, chain with 'withSchemaUrl' or 'withLibraryAttributes':++@+let scope = instrumentationScope "my-service" "1.2.0"+ & withSchemaUrl "https:\/\/opentelemetry.io\/schemas\/1.25.0"+@++@since 0.4.0.0+-}+instrumentationScope :: Text -> Text -> InstrumentationScope+instrumentationScope = instrumentationLibrary+++{- | Create an 'InstrumentationLibrary' with a name and version.+Schema URL and attributes default to empty.++Prefer 'instrumentationScope' for new code.++@since 0.4.0.0+-}+instrumentationLibrary :: Text -> Text -> InstrumentationLibrary+instrumentationLibrary name version =+ InstrumentationLibrary+ { libraryName = name+ , libraryVersion = version+ , librarySchemaUrl = ""+ , libraryAttributes = emptyAttributes+ }+++{- | Set the schema URL on an 'InstrumentationLibrary'.++@since 0.4.0.0+-}+withSchemaUrl :: Text -> InstrumentationLibrary -> InstrumentationLibrary+withSchemaUrl url lib = lib {librarySchemaUrl = url}+++{- | Set attributes on an 'InstrumentationLibrary'.++@since 0.4.0.0+-}+withLibraryAttributes :: Attributes -> InstrumentationLibrary -> InstrumentationLibrary+withLibraryAttributes attrs lib = lib {libraryAttributes = attrs}++ {- | An attribute represents user-provided metadata about a span, link, or event. 'Any' values are used in place of 'Standard Attributes' in logs because third-party@@ -76,6 +146,8 @@ Telemetry tools may use this data to support high-cardinality querying, visualization in waterfall diagrams, trace sampling decisions, and more.++@since 0.0.1.0 -} data AnyValue = TextValue Text@@ -106,6 +178,8 @@ toValue Foo = TextValue "Foo" @++@since 0.0.1.0 -} class ToValue a where toValue :: a -> AnyValue@@ -151,45 +225,129 @@ toValue = id +-- | @since 0.0.1.0 data ShutdownResult = ShutdownSuccess | ShutdownFailure | ShutdownTimeout+ deriving stock (Eq, Show) --- | The outcome of a call to @OpenTelemetry.Trace.forceFlush@ or @OpenTelemetry.Logs.forceFlush@+{- | Combine two shutdown results, preferring the "worst" outcome.+Failure > Timeout > Success.++@since 0.4.0.0+-}+worstShutdown :: ShutdownResult -> ShutdownResult -> ShutdownResult+worstShutdown ShutdownFailure _ = ShutdownFailure+worstShutdown _ ShutdownFailure = ShutdownFailure+worstShutdown ShutdownTimeout _ = ShutdownTimeout+worstShutdown _ ShutdownTimeout = ShutdownTimeout+worstShutdown ShutdownSuccess ShutdownSuccess = ShutdownSuccess+++{- | The outcome of a call to @OpenTelemetry.Trace.forceFlush@ or @OpenTelemetry.Log.forceFlush@++@since 0.0.1.0+-} data FlushResult- = -- | One or more spans or @LogRecord@s did not export from all associated exporters- -- within the alotted timeframe.+ = {- | One or more spans or @LogRecord@s did not export from all associated exporters+ within the alotted timeframe.+ -} FlushTimeout | -- | Flushing spans or @LogRecord@s to all associated exporters succeeded. FlushSuccess- | -- | One or more exporters failed to successfully export one or more- -- unexported spans or @LogRecord@s.+ | {- | One or more exporters failed to successfully export one or more+ unexported spans or @LogRecord@s.+ -} FlushError- deriving (Show)+ deriving stock (Eq, Show) +{- | Combine two flush results, preferring the "worst" outcome.+Error > Timeout > Success.++@since 0.0.1.0+-}+worstFlush :: FlushResult -> FlushResult -> FlushResult+worstFlush FlushError _ = FlushError+worstFlush _ FlushError = FlushError+worstFlush FlushTimeout _ = FlushTimeout+worstFlush _ FlushTimeout = FlushTimeout+worstFlush FlushSuccess FlushSuccess = FlushSuccess+++-- | @since 0.0.1.0 data ExportResult = Success | Failure (Maybe SomeException) --- | Parses a package-version string into an InstrumentationLibrary'.+{- | Parses a package-version string like @\"my-lib-1.2.3\"@ into an+ 'InstrumentationLibrary'. Tries to split off a trailing version (digits and+ dots after the rightmost @-@). Falls back to treating the whole string as a+ package name with no version.++@since 0.0.1.0+-} parseInstrumentationLibrary :: (MonadFail m) => String -> m InstrumentationLibrary-parseInstrumentationLibrary packageString = do- let packageNameRegex :: String = "([a-zA-Z0-9-]+[a-zA-Z0-9]+)"- let versionRegex :: String = "([0-9\\.]+)"- -- First try and parse with a mandatory version string on the end. If that fails, try- -- to parse just a package name- let fullRegex :: String = "(" <> packageNameRegex <> "-" <> versionRegex <> ")|" <> packageNameRegex- (_ :: String, _ :: String, _ :: String, groups :: [String]) <- packageString =~~ fullRegex- -- We end up with 5 groups overall- (name, version) <- case groups of- [_, name, version, ""] -> pure (name, version)- [_, _, _, name] -> pure (name, "")- _ -> fail $ "could not parse package string: " <> packageString- pure $ InstrumentationLibrary {libraryName = T.pack name, libraryVersion = T.pack version, librarySchemaUrl = "", libraryAttributes = emptyAttributes}+parseInstrumentationLibrary packageString =+ case splitPackageVersion packageString of+ Just (name, version) ->+ pure $+ InstrumentationLibrary+ { libraryName = T.pack name+ , libraryVersion = T.pack version+ , librarySchemaUrl = ""+ , libraryAttributes = emptyAttributes+ }+ Nothing+ | isValidPackageName packageString ->+ pure $+ InstrumentationLibrary+ { libraryName = T.pack packageString+ , libraryVersion = ""+ , librarySchemaUrl = ""+ , libraryAttributes = emptyAttributes+ }+ | otherwise ->+ fail $ "could not parse package string: " <> packageString --- | Works out the instrumentation library for your package.+{- | Try splitting @\"name-1.2.3\"@ or @\"name-1.2.3-hash\"@ at the rightmost+@-@ that precedes a version. The version is the maximal leading sequence of+digits and dots; any trailing content (e.g. @-inplace@, @-hash@) is+discarded, matching GHC's package-id format.+-}+splitPackageVersion :: String -> Maybe (String, String)+splitPackageVersion s =+ foldr+ (\i acc -> tryAt i acc)+ Nothing+ (reverse dashPositions)+ where+ dashPositions = fmap fst $ filter (\(_, c) -> c == '-') $ zip [0 :: Int ..] s+ tryAt i fallback =+ let name = take i s+ rest = drop (i + 1) s+ version = takeWhile isVersionChar rest+ in if not (null version)+ && isDigit (head version)+ && isValidPackageName name+ then Just (name, version)+ else fallback+ isVersionChar c = isDigit c || c == '.'+++isValidPackageName :: String -> Bool+isValidPackageName [] = False+isValidPackageName [_] = False+isValidPackageName s = all isNameChar s && isAlphaNum (last s)+ where+ isNameChar c = isAlphaNum c || c == '-'+++{- | Works out the instrumentation library for your package.++@since 0.0.1.0+-} detectInstrumentationLibrary :: forall m. (TH.Quasi m, TH.Quote m) => m TH.Exp detectInstrumentationLibrary = do TH.Loc {loc_package} <- TH.qLocation
+ src/OpenTelemetry/Internal/Log/Core.hs view
@@ -0,0 +1,469 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NumericUnderscores #-}++{- |+Module : OpenTelemetry.Internal.Log.Core+Copyright : (c) Ian Duncan, 2026+License : BSD-3+Description : Internal implementation of the Logs API: LoggerProvider creation, Logger, and LogRecord emission.+Stability : experimental+-}+module OpenTelemetry.Internal.Log.Core (+ LoggerProviderOptions (..),+ emptyLoggerProviderOptions,+ createLoggerProvider,+ getLogger,+ setGlobalLoggerProvider,+ getGlobalLoggerProvider,+ shutdownLoggerProvider,+ ShutdownResult (..),+ forceFlushLoggerProvider,+ makeLogger,+ loggerIsEnabled,+ loggerIsEnabled',+ setLoggerMinSeverity,+ getLoggerMinSeverity,+ emitLogRecord,+ addAttribute,+ addAttributes,+ logRecordGetAttributes,+ emitOTelLogRecord,+) where++import Control.Applicative+import Control.Concurrent.Async+import Control.Monad+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as H+import Data.IORef+import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Vector as V+import Data.Version (showVersion)+import GHC.IO (unsafePerformIO)+import qualified OpenTelemetry.Attributes as A+import OpenTelemetry.Common+import OpenTelemetry.Context+import OpenTelemetry.Context.ThreadLocal+import OpenTelemetry.Internal.Common.Types+import OpenTelemetry.Internal.Log.Types+import OpenTelemetry.Internal.Logging (otelLogWarning)+import OpenTelemetry.Internal.Trace.Types (SpanContext (..), getSpanContext)+import OpenTelemetry.Internal.UnpackedMaybe (fromBaseMaybe)+import OpenTelemetry.LogAttributes (LogAttributes)+import qualified OpenTelemetry.LogAttributes as LA+import OpenTelemetry.Resource (MaterializedResources, emptyMaterializedResources)+import Paths_hs_opentelemetry_api (version)+import System.Timeout (timeout)+++foreign import ccall unsafe "hs_otel_gettime_ns"+ getTimestampIO :: IO Timestamp+++-- | @since 0.0.1.0+data LoggerProviderOptions = LoggerProviderOptions+ { loggerProviderOptionsResource :: MaterializedResources+ , loggerProviderOptionsAttributeLimits :: A.AttributeLimits+ , loggerProviderOptionsMinSeverity :: Maybe SeverityNumber+ {- ^ When @Just sev@, log records with severity below @sev@ are+ suppressed (both 'loggerIsEnabled' and 'emitLogRecord' respect+ this). 'Nothing' means no filtering. Can be changed at runtime+ via 'setLoggerMinSeverity'.+ -}+ }+++{- | Options for creating a @LoggerProvider@ with no resources and default limits.++ In effect, logging is a no-op when using this configuration and no-op Processors.++@since 0.0.1.0+-}+emptyLoggerProviderOptions :: LoggerProviderOptions+emptyLoggerProviderOptions =+ LoggerProviderOptions+ { loggerProviderOptionsResource = emptyMaterializedResources+ , loggerProviderOptionsAttributeLimits = A.defaultAttributeLimits+ , loggerProviderOptionsMinSeverity = Nothing+ }+++{- | Initialize a new @LoggerProvider@++ You should generally use @getGlobalLoggerProvider@ for most applications.++@since 0.0.1.0+-}+createLoggerProvider :: (MonadIO m) => [LogRecordProcessor] -> LoggerProviderOptions -> m LoggerProvider+createLoggerProvider ps LoggerProviderOptions {..} = liftIO $ do+ shutRef <- newIORef False+ sevRef <- newIORef loggerProviderOptionsMinSeverity+ loggerCache <- newIORef H.empty+ let !processors = V.fromList ps+ !hasProcs = not (V.null processors)+ !onEmit = case ps of+ [] -> \_ _ -> pure ()+ [p] -> logRecordProcessorOnEmit p+ _ -> \lr ctx -> V.mapM_ (\p -> logRecordProcessorOnEmit p lr ctx) processors+ pure+ LoggerProvider+ { loggerProviderProcessors = processors+ , loggerProviderResource = loggerProviderOptionsResource+ , loggerProviderAttributeLimits = loggerProviderOptionsAttributeLimits+ , loggerProviderIsShutdown = shutRef+ , loggerProviderHasProcessors = hasProcs+ , loggerProviderOnEmit = onEmit+ , loggerProviderMinSeverity = sevRef+ , loggerProviderLoggerCache = loggerCache+ }+++globalLoggerProvider :: IORef LoggerProvider+globalLoggerProvider = unsafePerformIO $ do+ p <- createLoggerProvider [] emptyLoggerProviderOptions+ newIORef p+{-# NOINLINE globalLoggerProvider #-}+++{- | Access the globally configured @LoggerProvider@. This @LoggerProvider@ is no-op until initialized by the SDK++@since 0.0.1.0+-}+getGlobalLoggerProvider :: (MonadIO m) => m LoggerProvider+getGlobalLoggerProvider = liftIO $ readIORef globalLoggerProvider+++{- | Overwrite the globally configured @LoggerProvider@.++ @Logger@s acquired from the previously installed @LoggerProvider@s+ will continue to use that @LoggerProvider@s settings.++@since 0.0.1.0+-}+setGlobalLoggerProvider :: (MonadIO m) => LoggerProvider -> m ()+setGlobalLoggerProvider = liftIO . atomicWriteIORef globalLoggerProvider+++{- | This method provides a way for provider to do any cleanup required.++ This will also trigger shutdowns on all internal processors.++@since 0.0.1.0+-}+shutdownLoggerProvider+ :: (MonadIO m)+ => LoggerProvider+ -> Maybe Int+ -- ^ Optional timeout in microseconds, defaults to 5,000,000 (5s)+ -> m ShutdownResult+shutdownLoggerProvider LoggerProvider {loggerProviderProcessors, loggerProviderIsShutdown} mtimeout = liftIO $ do+ alreadyShut <- atomicModifyIORef' loggerProviderIsShutdown $ \s -> (True, s)+ if alreadyShut+ then pure ShutdownFailure+ else do+ jobs <- V.forM loggerProviderProcessors $ \processor ->+ async (logRecordProcessorShutdown processor)+ mresult <-+ timeout (fromMaybe 5_000_000 mtimeout) $+ V.foldM+ ( \status action -> do+ res <- waitCatch action+ pure $! case res of+ Left _err -> worstShutdown status ShutdownFailure+ Right sr -> worstShutdown status sr+ )+ ShutdownSuccess+ jobs+ case mresult of+ Nothing -> do+ V.mapM_ cancel jobs+ pure ShutdownTimeout+ Just res -> pure res+++{- | This method provides a way for provider to immediately export all @LogRecord@s that have not yet+ been exported for all the internal processors.++@since 0.0.1.0+-}+forceFlushLoggerProvider+ :: (MonadIO m)+ => LoggerProvider+ -> Maybe Int+ -- ^ Optional timeout in microseconds, defaults to 5,000,000 (5s)+ -> m FlushResult+ -- ^ Result that denotes whether the flush action succeeded, failed, or timed out.+forceFlushLoggerProvider LoggerProvider {loggerProviderProcessors} mtimeout = liftIO $ do+ jobs <- V.forM loggerProviderProcessors $ \processor ->+ async $+ logRecordProcessorForceFlush processor+ mresult <-+ timeout (fromMaybe 5_000_000 mtimeout) $+ V.foldM+ ( \status action -> do+ res <- waitCatch action+ pure $! case res of+ Left _err -> FlushError+ Right fr -> worstFlush status fr+ )+ FlushSuccess+ jobs+ case mresult of+ Nothing -> do+ V.mapM_ cancel jobs+ pure FlushTimeout+ Just res -> pure res+++-- | @since 0.0.1.0+makeLogger+ :: LoggerProvider+ -- ^ The @LoggerProvider@ holds the configuration for the @Logger@.+ -> InstrumentationLibrary+ {- ^ The library that the @Logger@ instruments. This uniquely identifies the @Logger@.+ Use a non-empty 'libraryName' per the OpenTelemetry specification; use 'getLogger'+ if you want a warning when the name is empty.+ -}+ -> Logger+makeLogger loggerLoggerProvider loggerInstrumentationScope = Logger {..}+++{- | Like 'makeLogger', but logs a warning when 'libraryName' is empty.++@since 0.0.1.0+-}+getLogger :: (MonadIO m) => LoggerProvider -> InstrumentationLibrary -> m Logger+getLogger lp il = liftIO $ do+ when (T.null (libraryName il)) $+ otelLogWarning "Logger created with empty name; returning working Logger with empty name per spec"+ let !l = makeLogger lp il+ !key = loggerInstrumentationScope l+ atomicModifyIORef' (loggerProviderLoggerCache lp) $ \cache ->+ case H.lookup key cache of+ Just cached -> (cache, cached)+ Nothing -> (H.insert key l cache, l)+++{- | Returns @True@ if a log record with the given severity (and optional+event name) would be forwarded to processors.++Checks, in order:++1. Whether the provider has any registered processors.+2. Whether the provider has been shut down.+3. Whether the record's severity meets the provider's minimum severity+ threshold (set via 'LoggerProviderOptions' or 'setLoggerMinSeverity').++When the caller passes 'Nothing' for severity, the minimum-severity gate+is skipped (the record is allowed through).++Callers SHOULD invoke this before each log emit to get the most up-to-date+response, as the result may change over time.++@since 0.1.0.0+-}+loggerIsEnabled :: Logger -> Maybe SeverityNumber -> Maybe Text -> IO Bool+loggerIsEnabled Logger {loggerLoggerProvider = lp} severity _eventName = do+ if not (loggerProviderHasProcessors lp)+ then pure False+ else do+ isShutdown <- readIORef (loggerProviderIsShutdown lp)+ if isShutdown+ then pure False+ else case severity of+ Nothing -> pure True+ Just sev -> do+ minSev <- readIORef (loggerProviderMinSeverity lp)+ pure $! case minSev of+ Nothing -> True+ Just threshold -> sev >= threshold+{-# INLINE loggerIsEnabled #-}+++{- | Like 'loggerIsEnabled' but accepts an explicit 'Context'.+When 'Nothing', uses the current implicit context.++@since 0.4.0.0+-}+loggerIsEnabled' :: (MonadIO m) => Logger -> Maybe SeverityNumber -> Maybe Text -> Maybe Context -> m Bool+loggerIsEnabled' logger msev mname _mctx = liftIO $ loggerIsEnabled logger msev mname+{-# INLINE loggerIsEnabled' #-}+++{- | Set the minimum severity for a 'LoggerProvider' at runtime.++Log records with a severity below the threshold will be suppressed by+both 'loggerIsEnabled' and 'emitLogRecord'. Pass 'Nothing' to disable+severity filtering (the default).++@since 0.4.0.0+-}+setLoggerMinSeverity :: (MonadIO m) => LoggerProvider -> Maybe SeverityNumber -> m ()+setLoggerMinSeverity lp = liftIO . atomicWriteIORef (loggerProviderMinSeverity lp)+++{- | Read the current minimum severity threshold for a 'LoggerProvider'.++Returns 'Nothing' when no severity filtering is active.++@since 0.4.0.0+-}+getLoggerMinSeverity :: (MonadIO m) => LoggerProvider -> m (Maybe SeverityNumber)+getLoggerMinSeverity = liftIO . readIORef . loggerProviderMinSeverity+++createImmutableLogRecord+ :: LA.AttributeLimits+ -> Context+ -> LogRecordArguments+ -> IO ImmutableLogRecord+createImmutableLogRecord attributeLimits !ctx LogRecordArguments {..} = do+ currentTimestamp <- getTimestampIO+ let !logRecordObservedTimestamp = fromMaybe currentTimestamp observedTimestamp++ logRecordTracingDetails <- case lookupSpan ctx of+ Nothing -> pure NoTracingDetails+ Just s -> do+ SpanContext {traceId, spanId, traceFlags} <- getSpanContext s+ pure $! TracingDetails traceId spanId traceFlags++ let !logRecordAttributes =+ LA.addAttributes+ attributeLimits+ LA.emptyAttributes+ attributes+ !droppedCount = LA.attributesDropped logRecordAttributes++ when (droppedCount > 0) $+ otelLogWarning ("LogRecord dropped " <> show droppedCount <> " attribute(s) due to limits")++ pure+ ImmutableLogRecord+ { logRecordTimestamp = fromBaseMaybe timestamp+ , logRecordObservedTimestamp+ , logRecordTracingDetails+ , logRecordSeverityNumber = fromBaseMaybe severityNumber+ , logRecordSeverityText = fromBaseMaybe (severityText <|> (toShortName =<< severityNumber))+ , logRecordBody = body+ , logRecordAttributes+ , logRecordEventName = fromBaseMaybe eventName+ }+++-- | WARNING: this function should only be used to emit logs from the hs-opentelemetry-api library. DO NOT USE this function in any other context.+emitOTelLogRecord :: (MonadIO m) => H.HashMap Text LA.AnyValue -> SeverityNumber -> Text -> m ReadWriteLogRecord+emitOTelLogRecord attrs severity bodyText = do+ glp <- getGlobalLoggerProvider+ let gl =+ makeLogger glp $+ InstrumentationLibrary+ { libraryName = "hs-opentelemetry-api"+ , libraryVersion = T.pack $ showVersion version+ , librarySchemaUrl = ""+ , libraryAttributes = A.emptyAttributes+ }++ emitLogRecord gl $+ emptyLogRecordArguments+ { severityNumber = Just severity+ , body = toValue bodyText+ , attributes = attrs+ }+++{- | Emits a @LogRecord@ with properties specified by the passed in Logger and LogRecordArguments.+If observedTimestamp is not set in LogRecordArguments, it will default to the current timestamp.+If context is not specified in LogRecordArguments it will default to the current context.++The emitted @LogRecord@ will be passed to any @LogRecordProcessor@s registered on the @LoggerProvider@+that created the @Logger@, provided the record's severity meets the provider's minimum severity+threshold.++@since 0.0.1.0+-}+emitLogRecord+ :: (MonadIO m)+ => Logger+ -> LogRecordArguments+ -> m ReadWriteLogRecord+emitLogRecord l args = liftIO $ do+ let !lp = loggerLoggerProvider l+ ctx <- maybe getContext pure (context args)+ ilr <- createImmutableLogRecord (loggerProviderAttributeLimits lp) ctx args+ lr <- mkReadWriteLogRecord l ilr+ when (loggerProviderHasProcessors lp) $ do+ isShutdown <- readIORef (loggerProviderIsShutdown lp)+ unless isShutdown $ do+ minSev <- readIORef (loggerProviderMinSeverity lp)+ let dominated = case minSev of+ Nothing -> False+ Just threshold -> case severityNumber args of+ Nothing -> False+ Just sev -> sev < threshold+ unless dominated $+ loggerProviderOnEmit lp lr ctx+ pure lr+++{- | Add an attribute to a log record. Not an atomic modification.++See the [OTel attribute naming conventions](https://opentelemetry.io/docs/specs/otel/common/attribute-naming/)+for guidance on choosing attribute names.++@since 0.0.1.0+-}+addAttribute :: (IsReadWriteLogRecord r, MonadIO m, ToValue a) => r -> Text -> a -> m ()+addAttribute lr k v =+ let attributeLimits = readLogRecordAttributeLimits lr+ in liftIO $+ modifyLogRecord+ lr+ ( \ilr@ImmutableLogRecord {logRecordAttributes} ->+ ilr+ { logRecordAttributes =+ LA.addAttribute+ attributeLimits+ logRecordAttributes+ k+ v+ }+ )+++{- | A convenience function related to 'addAttribute' that adds multiple attributes to a @LogRecord@ at the same time.++This function may be slightly more performant than repeatedly calling 'addAttribute'.++This is not an atomic modification++@since 0.0.1.0+-}+addAttributes :: (IsReadWriteLogRecord r, MonadIO m, ToValue a) => r -> HashMap Text a -> m ()+addAttributes lr attrs =+ let attributeLimits = readLogRecordAttributeLimits lr+ in liftIO $+ modifyLogRecord+ lr+ ( \ilr@ImmutableLogRecord {logRecordAttributes} ->+ ilr+ { logRecordAttributes =+ LA.addAttributes+ attributeLimits+ logRecordAttributes+ attrs+ }+ )+++{- | This can be useful for pulling data for attributes and+ using it to copy / otherwise use the data to further enrich+ instrumentation.++@since 0.0.1.0+-}+logRecordGetAttributes :: (IsReadableLogRecord r, MonadIO m) => r -> m LogAttributes+logRecordGetAttributes lr = liftIO $ logRecordAttributes <$> readLogRecord lr
+ src/OpenTelemetry/Internal/Log/Types.hs view
@@ -0,0 +1,597 @@+{-# LANGUAGE NamedFieldPuns #-}++{- |+Module : OpenTelemetry.Internal.Log.Types+Copyright : (c) Ian Duncan, 2026+License : BSD-3+Description : Internal type definitions for the Logs signal: LoggerProvider, Logger, ReadWriteLogRecord, ImmutableLogRecord, SeverityNumber.+Stability : experimental+-}+module OpenTelemetry.Internal.Log.Types (+ -- * UMaybe re-export for consumers of ImmutableLogRecord fields+ UMaybe (..),+ umaybe,+ toBaseMaybe,+ TracingDetails (..),+ LogRecordExporter,+ LogRecordExporterArguments (..),+ mkLogRecordExporter,+ logRecordExporterExport,+ logRecordExporterForceFlush,+ logRecordExporterShutdown,+ LogRecordProcessor (..),+ LoggerProvider (..),+ Logger (..),+ ReadWriteLogRecord,+ mkReadWriteLogRecord,+ ReadableLogRecord,+ mkReadableLogRecord,+ IsReadableLogRecord (..),+ IsReadWriteLogRecord (..),+ ImmutableLogRecord (..),+ LogRecordArguments (..),+ emptyLogRecordArguments,+ SeverityNumber (..),+ toShortName,+) where++import Control.Concurrent (MVar, newMVar, withMVar)+import Data.Function (on)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as H+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Vector (Vector)+import OpenTelemetry.Common (Timestamp, TraceFlags)+import OpenTelemetry.Context.Types (Context)+import OpenTelemetry.Internal.Common.Types (ExportResult, FlushResult, InstrumentationLibrary, ShutdownResult)+import OpenTelemetry.Internal.Trace.Id (SpanId, TraceId)+import OpenTelemetry.Internal.UnpackedMaybe (UMaybe (..), toBaseMaybe, umaybe)+import OpenTelemetry.LogAttributes+import OpenTelemetry.Resource (MaterializedResources)+++{- | See @LogRecordExporter@ for documentation++@since 0.0.1.0+-}+data LogRecordExporterArguments = LogRecordExporterArguments+ { logRecordExporterArgumentsExport :: Vector ReadableLogRecord -> IO ExportResult+ -- ^ See @logRecordExporterExport@ for documentation+ , logRecordExporterArgumentsForceFlush :: IO FlushResult+ {- ^ See @logRecordExporterForceFlush@ for documentation.+ Spec: ForceFlush SHOULD provide a way to let the caller know+ whether it succeeded, failed or timed out.+ <https://opentelemetry.io/docs/specs/otel/logs/sdk/#logrecordexporter>+ -}+ , logRecordExporterArgumentsShutdown :: IO ()+ -- ^ See @logRecordExporterArgumentsShutdown@ for documentation+ }+++{- | Exports log records to a telemetry backend. Thread-safe: the internal+'MVar' serializes concurrent 'logRecordExporterExport' calls.++Spec: <https://opentelemetry.io/docs/specs/otel/logs/sdk/#logrecordexporter>++@since 0.0.1.0+-}+newtype LogRecordExporter = LogRecordExporter {unExporter :: MVar LogRecordExporterArguments}+++-- | @since 0.0.1.0+mkLogRecordExporter :: LogRecordExporterArguments -> IO LogRecordExporter+mkLogRecordExporter = fmap LogRecordExporter . newMVar+++{- | Exports a batch of ReadableLogRecords. Protocol exporters that will implement this function are typically expected to serialize+and transmit the data to the destination.++Export will never be called concurrently for the same exporter instance. Depending on the implementation the result of the export+may be returned to the Processor not in the return value of the call to Export but in a language specific way for signaling completion+of an asynchronous task. This means that while an instance of an exporter will never have it Export called concurrently it does not+mean that the task of exporting can not be done concurrently. How this is done is outside the scope of this specification.+Each implementation MUST document the concurrency characteristics the SDK requires of the exporter.++Export MUST NOT block indefinitely, there MUST be a reasonable upper limit after which the call must time out with an error result (Failure).++Concurrent requests and retry logic is the responsibility of the exporter. The default SDK’s LogRecordProcessors SHOULD NOT implement+retry logic, as the required logic is likely to depend heavily on the specific protocol and backend the logs are being sent to.+For example, the OpenTelemetry Protocol (OTLP) specification defines logic for both sending concurrent requests and retrying requests.++Result:+Success - The batch has been successfully exported. For protocol exporters this typically means that the data is sent over the wire and delivered to the destination server.+Failure - exporting failed. The batch must be dropped. For example, this can happen when the batch contains bad data and cannot be serialized.++@since 0.0.1.0+-}+logRecordExporterExport :: LogRecordExporter -> Vector ReadableLogRecord -> IO ExportResult+logRecordExporterExport exporter lrs = withMVar (unExporter exporter) $ \e -> logRecordExporterArgumentsExport e lrs+++{- | This is a hint to ensure that the export of any ReadableLogRecords the exporter has received prior to the call to ForceFlush SHOULD+be completed as soon as possible, preferably before returning from this method.++ForceFlush SHOULD provide a way to let the caller know whether it succeeded, failed or timed out.++ForceFlush SHOULD only be called in cases where it is absolutely necessary, such as when using some FaaS providers that may suspend+the process after an invocation, but before the exporter exports the ReadlableLogRecords.++ForceFlush SHOULD complete or abort within some timeout. ForceFlush can be implemented as a blocking API or an asynchronous API which+notifies the caller via a callback or an event. OpenTelemetry SDK authors MAY decide if they want to make the flush timeout configurable.++@since 0.0.1.0+-}+logRecordExporterForceFlush :: LogRecordExporter -> IO FlushResult+logRecordExporterForceFlush = flip withMVar logRecordExporterArgumentsForceFlush . unExporter+++{- | Shuts down the exporter. Called when SDK is shut down. This is an opportunity for exporter to do any cleanup required.++Shutdown SHOULD be called only once for each LogRecordExporter instance. After the call to Shutdown subsequent calls to Export are not+allowed and SHOULD return a Failure result.++Shutdown SHOULD NOT block indefinitely (e.g. if it attempts to flush the data and the destination is unavailable).+OpenTelemetry SDK authors MAY decide if they want to make the shutdown timeout configurable.++@since 0.0.1.0+-}+logRecordExporterShutdown :: LogRecordExporter -> IO ()+logRecordExporterShutdown = flip withMVar logRecordExporterArgumentsShutdown . unExporter+++{- | Receives callbacks when log records are emitted. Built-in processors+batch log records and pass them to exporters.++Spec: <https://opentelemetry.io/docs/specs/otel/logs/sdk/#logrecordprocessor>++@since 0.0.1.0+-}+data LogRecordProcessor = LogRecordProcessor+ { logRecordProcessorOnEmit :: ReadWriteLogRecord -> Context -> IO ()+ {- ^ Called when a LogRecord is emitted. This method is called synchronously on the thread that emitted the LogRecord, therefore it SHOULD NOT block or throw exceptions.++ A LogRecordProcessor may freely modify logRecord for the duration of the OnEmit call. If logRecord is needed after OnEmit returns (i.e. for asynchronous processing) only reads are permitted.+ -}+ , logRecordProcessorShutdown :: IO ShutdownResult+ {- ^ Shuts down the processor. Called when SDK is shut down. This is an opportunity for processor to do any cleanup required.++ Shutdown SHOULD be called only once for each LogRecordProcessor instance. After the call to Shutdown, subsequent calls to OnEmit are not allowed. SDKs SHOULD ignore these calls gracefully, if possible.++ Shutdown SHOULD provide a way to let the caller know whether it succeeded, failed or timed out.++ Shutdown MUST include the effects of ForceFlush.++ Shutdown SHOULD complete or abort within some timeout. Shutdown can be implemented as a blocking API or an asynchronous API which notifies the caller via a callback or an event.+ OpenTelemetry SDK authors can decide if they want to make the shutdown timeout configurable.+ -}+ , logRecordProcessorForceFlush :: IO FlushResult+ {- ^ This is a hint to ensure that any tasks associated with LogRecords for which the LogRecordProcessor had already received events prior to the call to ForceFlush SHOULD be completed+ as soon as possible, preferably before returning from this method.++ In particular, if any LogRecordProcessor has any associated exporter, it SHOULD try to call the exporter’s Export with all LogRecords for which this was not already done and then invoke ForceFlush on it.+ The built-in LogRecordProcessors MUST do so. If a timeout is specified (see below), the LogRecordProcessor MUST prioritize honoring the timeout over finishing all calls. It MAY skip or abort some or all+ Export or ForceFlush calls it has made to achieve this goal.++ ForceFlush SHOULD provide a way to let the caller know whether it succeeded, failed or timed out.++ ForceFlush SHOULD only be called in cases where it is absolutely necessary, such as when using some FaaS providers that may suspend the process after an invocation, but before the LogRecordProcessor exports the emitted LogRecords.++ ForceFlush SHOULD complete or abort within some timeout. ForceFlush can be implemented as a blocking API or an asynchronous API which notifies the caller via a callback or an event. OpenTelemetry SDK authors+ can decide if they want to make the flush timeout configurable.+ -}+ }+++{- | Factory for creating 'Logger' instances. Holds processors, resource,+attribute limits, and shutdown state.++All operations on 'LoggerProvider' are safe for concurrent use from multiple threads.++Spec: <https://opentelemetry.io/docs/specs/otel/logs/sdk/#loggerprovider>++@since 0.0.1.0+-}+data LoggerProvider = LoggerProvider+ { loggerProviderProcessors :: Vector LogRecordProcessor+ , loggerProviderResource :: MaterializedResources+ -- ^ Describes the source of the log, aka resource.+ , loggerProviderAttributeLimits :: AttributeLimits+ , loggerProviderIsShutdown :: IORef Bool+ {- ^ Set to 'True' after 'shutdownLoggerProvider'. Spec: after shutdown,+ subsequent 'emitLogRecord' calls SHOULD be no-ops.+ -}+ , loggerProviderHasProcessors :: !Bool+ -- ^ Cached at creation time. Avoids 'V.null' check on every emit.+ , loggerProviderOnEmit :: ReadWriteLogRecord -> Context -> IO ()+ {- ^ Pre-composed processor callback. For 0 processors this is a no-op,+ for 1 processor it's a direct call, for N it's a fused loop.+ Avoids 'V.mapM_' + indirect call overhead on every emit.+ -}+ , loggerProviderMinSeverity :: IORef (Maybe SeverityNumber)+ {- ^ When 'Just sev', 'loggerIsEnabled' returns 'False' and+ 'emitLogRecord' skips processor dispatch for records whose+ severity is below @sev@. Mutable at runtime via+ 'setLoggerMinSeverity'. 'Nothing' means no filtering.+ -}+ , loggerProviderLoggerCache :: IORef (HashMap InstrumentationLibrary Logger)+ {- ^ Cache of 'Logger' instances per instrumentation scope. Spec: the same+ 'Logger' SHOULD be returned for the same scope identity.+ -}+ }+++{- | @LogRecords@ can be created from @Loggers@. @Logger@s are uniquely identified by the @libraryName@, @libraryVersion@, @schemaUrl@ fields of @InstrumentationLibrary@.+Creating two @Logger@s with the same identity but different @libraryAttributes@ is a user error.++All operations on 'Logger' are safe for concurrent use from multiple threads.++@since 0.0.1.0+-}+data Logger = Logger+ { loggerInstrumentationScope :: InstrumentationLibrary+ -- ^ Details about the library that the @Logger@ instruments.+ , loggerLoggerProvider :: LoggerProvider+ -- ^ The @LoggerProvider@ that created this @Logger@. All configuration for the @Logger@ is contained in the @LoggerProvider@.+ }+++{- | This is a data type that can represent logs from various sources: application log files, machine generated events, system logs, etc. [Specification outlined here.](https://opentelemetry.io/docs/specs/otel/logs/data-model/)+Existing log formats can be unambiguously mapped to this data type. Reverse mapping from this data type is also possible to the extent that the target log format has equivalent capabilities.++@since 0.0.1.0+-}+data ReadWriteLogRecord = ReadWriteLogRecord Logger (IORef ImmutableLogRecord)+++-- | @since 0.0.1.0+mkReadWriteLogRecord :: Logger -> ImmutableLogRecord -> IO ReadWriteLogRecord+mkReadWriteLogRecord l = fmap (ReadWriteLogRecord l) . newIORef+++-- | @since 0.0.1.0+data ReadableLogRecord = ReadableLogRecord+ { readableLogRecordSnapshot :: !ImmutableLogRecord+ , readableLogRecordScope :: !InstrumentationLibrary+ , readableLogRecordMaterializedResource :: !MaterializedResources+ }+++{- | Snapshot the current state of a 'ReadWriteLogRecord' into an immutable+'ReadableLogRecord'. Exporters that receive a 'ReadableLogRecord' are+guaranteed to see a consistent point-in-time view.++@since 0.0.1.0+-}+mkReadableLogRecord :: ReadWriteLogRecord -> IO ReadableLogRecord+mkReadableLogRecord (ReadWriteLogRecord logger ref) = do+ snapshot <- readIORef ref+ pure+ ReadableLogRecord+ { readableLogRecordSnapshot = snapshot+ , readableLogRecordScope = loggerInstrumentationScope logger+ , readableLogRecordMaterializedResource = loggerProviderResource (loggerLoggerProvider logger)+ }+++{- | This is a typeclass representing @LogRecord@s that can be read from.++A function receiving this as an argument MUST be able to access all the information added to the LogRecord. It MUST also be able to access the Instrumentation Scope and Resource information (implicitly) associated with the LogRecord.++The trace context fields MUST be populated from the resolved Context (either the explicitly passed Context or the current Context) when emitted.++Counts for attributes due to collection limits MUST be available for exporters to report as described in the transformation to non-OTLP formats specification.++@since 0.0.1.0+-}+class IsReadableLogRecord r where+ -- | Reads the current state of the @LogRecord@ from its internal @IORef@. The implementation mirrors @readIORef@.+ readLogRecord :: r -> IO ImmutableLogRecord+++ -- | Reads the @InstrumentationScope@ from the @Logger@ that emitted the @LogRecord@+ readLogRecordInstrumentationScope :: r -> InstrumentationLibrary+++ -- | Reads the @Resource@ from the @LoggerProvider@ that emitted the @LogRecord@+ readLogRecordResource :: r -> MaterializedResources+++{- | This is a typeclass representing @LogRecord@s that can be read from or written to. All @ReadWriteLogRecord@s are @ReadableLogRecord@s.++A function receiving this as an argument MUST additionally be able to modify the following information added to the LogRecord:++- Timestamp+- ObservedTimestamp+- SeverityText+- SeverityNumber+- Body+- Attributes (addition, modification, removal)+- EventName+- TraceId+- SpanId+- TraceFlags++@since 0.0.1.0+-}+class (IsReadableLogRecord r) => IsReadWriteLogRecord r where+ -- | Reads the attribute limits from the @LoggerProvider@ that emitted the @LogRecord@. These are needed to add more attributes.+ readLogRecordAttributeLimits :: r -> AttributeLimits+++ {- | Atomically modifies the @LogRecord@ using its internal @IORef@.+ Uses @atomicModifyIORef'@ (strict) to avoid thunk buildup and ensure+ thread safety under concurrent mutation.+ -}+ modifyLogRecord :: r -> (ImmutableLogRecord -> ImmutableLogRecord) -> IO ()+++ {- | Atomically modifies the @LogRecord@ and returns a value.+ Uses @atomicModifyIORef'@ (strict) for thread safety.+ -}+ atomicModifyLogRecord :: r -> (ImmutableLogRecord -> (ImmutableLogRecord, b)) -> IO b+++instance IsReadableLogRecord ReadableLogRecord where+ readLogRecord = pure . readableLogRecordSnapshot+ readLogRecordInstrumentationScope = readableLogRecordScope+ readLogRecordResource = readableLogRecordMaterializedResource+++instance IsReadableLogRecord ReadWriteLogRecord where+ readLogRecord (ReadWriteLogRecord _ ref) = readIORef ref+ readLogRecordInstrumentationScope (ReadWriteLogRecord (Logger {loggerInstrumentationScope}) _) = loggerInstrumentationScope+ readLogRecordResource (ReadWriteLogRecord Logger {loggerLoggerProvider = LoggerProvider {loggerProviderResource}} _) = loggerProviderResource+++instance IsReadWriteLogRecord ReadWriteLogRecord where+ readLogRecordAttributeLimits (ReadWriteLogRecord Logger {loggerLoggerProvider = LoggerProvider {loggerProviderAttributeLimits}} _) = loggerProviderAttributeLimits+ modifyLogRecord (ReadWriteLogRecord _ ref) f = atomicModifyIORef' ref (\ilr -> (f ilr, ()))+ atomicModifyLogRecord (ReadWriteLogRecord _ ref) = atomicModifyIORef' ref+++{- | Optional trace context attached to a log record. Uses a dedicated ADT+instead of @UMaybe (TraceId, SpanId, TraceFlags)@ so GHC can unpack all+fields flat into the constructor — no intermediate boxed tuple.++@since 0.4.0.0+-}+data TracingDetails+ = NoTracingDetails+ | TracingDetails+ {-# UNPACK #-} !TraceId+ {-# UNPACK #-} !SpanId+ {-# UNPACK #-} !TraceFlags+ deriving (Eq, Show)+++{- | Point-in-time snapshot of a log record's fields.++Spec: <https://opentelemetry.io/docs/specs/otel/logs/data-model/>++@since 0.0.1.0+-}+data ImmutableLogRecord = ImmutableLogRecord+ { logRecordTimestamp :: {-# UNPACK #-} !(UMaybe Timestamp)+ -- ^ Time when the event occurred. 'UNothing' when unknown.+ , logRecordObservedTimestamp :: !Timestamp+ {- ^ Time when the event was observed by the collection system. For events that originate in OpenTelemetry (e.g. using OpenTelemetry Logging SDK)+ this timestamp is typically set at the generation time and is equal to Timestamp. For events originating externally and collected by OpenTelemetry (e.g. using Collector)+ this is the time when OpenTelemetry’s code observed the event measured by the clock of the OpenTelemetry code. This field SHOULD be set once the event is observed by OpenTelemetry.++ For converting OpenTelemetry log data to formats that support only one timestamp or when receiving OpenTelemetry log data by recipients that support only one timestamp internally the following logic is recommended:+ - Use Timestamp if it is present, otherwise use ObservedTimestamp+ -}+ , logRecordTracingDetails :: !TracingDetails+ {- ^ Trace context for log-trace correlation.++ - Request trace id as defined in W3C Trace Context. Can be set for logs that are part of request processing and have an assigned trace id.+ - Span id. Can be set for logs that are part of a particular processing span.+ - Trace flag as defined in W3C Trace Context specification. At the time of writing the specification defines one flag - the SAMPLED flag.+ -}+ , logRecordSeverityText :: {-# UNPACK #-} !(UMaybe Text)+ -- ^ Severity text (log level). Original string representation from the source.+ , logRecordSeverityNumber :: {-# UNPACK #-} !(UMaybe SeverityNumber)+ {- ^ Severity number (1-24). See spec for severity ranges (TRACE/DEBUG/INFO/WARN/ERROR/FATAL).+ +-----------------------+-------------+------------------------------------------------------------------------------------------++ | 17-20 | ERROR | An error event. Something went wrong. |+ +-----------------------+-------------+------------------------------------------------------------------------------------------++ | 21-24 | FATAL | A fatal error such as application or system crash. |+ +-----------------------+-------------+------------------------------------------------------------------------------------------++ Smaller numerical values in each range represent less important (less severe) events. Larger numerical values in each range represent more important (more severe) events.+ For example SeverityNumber=17 describes an error that is less critical than an error with SeverityNumber=20.++ Mappings from existing logging systems and formats (or source format for short) must define how severity (or log level) of that particular format corresponds to SeverityNumber+ of this data model based on the meaning given for each range in the above table. [More Information](https://opentelemetry.io/docs/specs/otel/logs/data-model/#mapping-of-severitynumber)++ [These short names](https://opentelemetry.io/docs/specs/otel/logs/data-model/#displaying-severity) can be used to represent SeverityNumber in the UI++ In the contexts where severity participates in less-than / greater-than comparisons SeverityNumber field should be used.+ SeverityNumber can be compared to another SeverityNumber or to numbers in the 1..24 range (or to the corresponding short names).+ -}+ , logRecordBody :: AnyValue+ {- ^ A value containing the body of the log record. Can be for example a human-readable string message (including multi-line) describing the event in a free form or it can be a+ structured data composed of arrays and maps of other values. Body MUST support any type to preserve the semantics of structured logs emitted by the applications.+ Can vary for each occurrence of the event coming from the same source. This field is optional.++ Type any+ Value of type any can be one of the following:+ - A scalar value: number, string or boolean,+ - A byte array,+ - An array (a list) of any values,+ - A map<string, any>.+ -}+ , logRecordAttributes :: LogAttributes+ {- ^ Additional information about the specific event occurrence. Unlike the Resource field, which is fixed for a particular source, Attributes can vary for each occurrence of the event coming from the same source.+ Can contain information about the request context (other than Trace Context Fields). The log attribute model MUST support any type, a superset of standard Attribute, to preserve the semantics of structured attributes+ emitted by the applications. This field is optional.+ -}+ , logRecordEventName :: {-# UNPACK #-} !(UMaybe Text)+ -- ^ Optional event name. When set, this identifies the log record as an event.+ }+++{- | Arguments that may be set on LogRecord creation. If observedTimestamp is not set, it will default to the current timestamp.+If context is not specified it will default to the current context. Refer to the documentation of @LogRecord@ for descriptions+of the fields.++@since 0.0.1.0+-}+data LogRecordArguments = LogRecordArguments+ { timestamp :: Maybe Timestamp+ , observedTimestamp :: Maybe Timestamp+ , context :: Maybe Context+ , severityText :: Maybe Text+ , severityNumber :: Maybe SeverityNumber+ , body :: AnyValue+ , attributes :: HashMap Text AnyValue+ , eventName :: Maybe Text+ }+++-- | @since 0.0.1.0+emptyLogRecordArguments :: LogRecordArguments+emptyLogRecordArguments =+ LogRecordArguments+ { timestamp = Nothing+ , observedTimestamp = Nothing+ , context = Nothing+ , severityText = Nothing+ , severityNumber = Nothing+ , body = NullValue+ , attributes = H.empty+ , eventName = Nothing+ }+++{- | Log severity level per the OTel log data model.++Spec: <https://opentelemetry.io/docs/specs/otel/logs/data-model/#severity-fields>++@since 0.0.1.0+-}+data SeverityNumber+ = Trace+ | Trace2+ | Trace3+ | Trace4+ | Debug+ | Debug2+ | Debug3+ | Debug4+ | Info+ | Info2+ | Info3+ | Info4+ | Warn+ | Warn2+ | Warn3+ | Warn4+ | Error+ | Error2+ | Error3+ | Error4+ | Fatal+ | Fatal2+ | Fatal3+ | Fatal4+ | Unknown !Int+++instance Enum SeverityNumber where+ toEnum 1 = Trace+ toEnum 2 = Trace2+ toEnum 3 = Trace3+ toEnum 4 = Trace4+ toEnum 5 = Debug+ toEnum 6 = Debug2+ toEnum 7 = Debug3+ toEnum 8 = Debug4+ toEnum 9 = Info+ toEnum 10 = Info2+ toEnum 11 = Info3+ toEnum 12 = Info4+ toEnum 13 = Warn+ toEnum 14 = Warn2+ toEnum 15 = Warn3+ toEnum 16 = Warn4+ toEnum 17 = Error+ toEnum 18 = Error2+ toEnum 19 = Error3+ toEnum 20 = Error4+ toEnum 21 = Fatal+ toEnum 22 = Fatal2+ toEnum 23 = Fatal3+ toEnum 24 = Fatal4+ toEnum n = Unknown n+++ fromEnum Trace = 1+ fromEnum Trace2 = 2+ fromEnum Trace3 = 3+ fromEnum Trace4 = 4+ fromEnum Debug = 5+ fromEnum Debug2 = 6+ fromEnum Debug3 = 7+ fromEnum Debug4 = 8+ fromEnum Info = 9+ fromEnum Info2 = 10+ fromEnum Info3 = 11+ fromEnum Info4 = 12+ fromEnum Warn = 13+ fromEnum Warn2 = 14+ fromEnum Warn3 = 15+ fromEnum Warn4 = 16+ fromEnum Error = 17+ fromEnum Error2 = 18+ fromEnum Error3 = 19+ fromEnum Error4 = 20+ fromEnum Fatal = 21+ fromEnum Fatal2 = 22+ fromEnum Fatal3 = 23+ fromEnum Fatal4 = 24+ fromEnum (Unknown n) = n+++instance Eq SeverityNumber where+ (==) = on (==) fromEnum+++instance Ord SeverityNumber where+ compare = on compare fromEnum+++-- | @since 0.0.1.0+toShortName :: SeverityNumber -> Maybe Text+toShortName Trace = Just "TRACE"+toShortName Trace2 = Just "TRACE2"+toShortName Trace3 = Just "TRACE3"+toShortName Trace4 = Just "TRACE4"+toShortName Debug = Just "DEBUG"+toShortName Debug2 = Just "DEBUG2"+toShortName Debug3 = Just "DEBUG3"+toShortName Debug4 = Just "DEBUG4"+toShortName Info = Just "INFO"+toShortName Info2 = Just "INFO2"+toShortName Info3 = Just "INFO3"+toShortName Info4 = Just "INFO4"+toShortName Warn = Just "WARN"+toShortName Warn2 = Just "WARN2"+toShortName Warn3 = Just "WARN3"+toShortName Warn4 = Just "WARN4"+toShortName Error = Just "ERROR"+toShortName Error2 = Just "ERROR2"+toShortName Error3 = Just "ERROR3"+toShortName Error4 = Just "ERROR4"+toShortName Fatal = Just "FATAL"+toShortName Fatal2 = Just "FATAL2"+toShortName Fatal3 = Just "FATAL3"+toShortName Fatal4 = Just "FATAL4"+toShortName (Unknown _) = Nothing+++instance Show SeverityNumber where+ show s = case toShortName s of+ Just name -> T.unpack name+ Nothing -> "SeverityNumber " <> show (fromEnum s)
+ src/OpenTelemetry/Internal/Logging.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE LambdaCase #-}++{- |+Module : OpenTelemetry.Internal.Logging+Copyright : (c) Ian Duncan, 2021+License : BSD-3+Description : SDK-internal diagnostic logging, per the OTel specification.+Maintainer : Ian Duncan+Stability : internal+Portability : non-portable (GHC extensions)++The OpenTelemetry specification mandates that the SDK produces+self-diagnostic output controllable via @OTEL_LOG_LEVEL@+(error, warn, info, debug) and that users can plug a custom error+handler.++Output goes to @stderr@ by default so it never interferes with+application stdout. The log level is read once from the environment+on first use and cached for the process lifetime. Users can override+the output sink via 'setGlobalErrorHandler'.++This module is internal. Library authors should not depend on it.++@since 0.4.0.0+-}+module OpenTelemetry.Internal.Logging (+ OTelLogLevel (..),+ otelLogError,+ otelLogWarning,+ otelLogInfo,+ otelLogDebug,+ getOTelLogLevel,+ setGlobalErrorHandler,+ getGlobalErrorHandler,+) where++import Data.Char (toLower)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import System.Environment (lookupEnv)+import System.IO (hPutStrLn, stderr)+import System.IO.Unsafe (unsafePerformIO)+++-- | @since 0.4.0.0+data OTelLogLevel+ = OTelLogNone+ | OTelLogError+ | OTelLogWarning+ | OTelLogInfo+ | OTelLogDebug+ deriving (Eq, Ord, Show)+++parseLogLevel :: String -> OTelLogLevel+parseLogLevel s = case map toLower s of+ "none" -> OTelLogNone+ "error" -> OTelLogError+ "warn" -> OTelLogWarning+ "warning" -> OTelLogWarning+ "info" -> OTelLogInfo+ "debug" -> OTelLogDebug+ _ -> OTelLogInfo+++cachedLogLevel :: IORef OTelLogLevel+cachedLogLevel = unsafePerformIO $ do+ mEnv <- lookupEnv "OTEL_LOG_LEVEL"+ newIORef $ case mEnv of+ Nothing -> OTelLogInfo+ Just v -> parseLogLevel v+{-# NOINLINE cachedLogLevel #-}+++globalErrorHandler :: IORef (String -> IO ())+globalErrorHandler = unsafePerformIO $ newIORef (hPutStrLn stderr)+{-# NOINLINE globalErrorHandler #-}+++{- | Replace the global error handler used by all OTel SDK diagnostic+output. The default writes to @stderr@. The OTel spec requires that+the SDK allow users to plug a custom error handler.++The handler receives a pre-formatted message string including the+severity prefix (e.g. @"OpenTelemetry [ERROR] ..."@).++@since 0.4.0.0+-}+setGlobalErrorHandler :: (String -> IO ()) -> IO ()+setGlobalErrorHandler = writeIORef globalErrorHandler+++{- | Retrieve the current global error handler.++@since 0.4.0.0+-}+getGlobalErrorHandler :: IO (String -> IO ())+getGlobalErrorHandler = readIORef globalErrorHandler+++{- | Retrieve the currently configured log level.++@since 0.4.0.0+-}+getOTelLogLevel :: IO OTelLogLevel+getOTelLogLevel = readIORef cachedLogLevel+{-# INLINE getOTelLogLevel #-}+++otelLog :: OTelLogLevel -> String -> String -> IO ()+otelLog minLevel prefix msg = do+ level <- getOTelLogLevel+ if level >= minLevel+ then do+ handler <- getGlobalErrorHandler+ handler (prefix <> msg)+ else pure ()+{-# INLINE otelLog #-}+++{- | Log at ERROR level. Always emitted unless @OTEL_LOG_LEVEL=none@.++@since 0.4.0.0+-}+otelLogError :: String -> IO ()+otelLogError = otelLog OTelLogError "OpenTelemetry [ERROR] "+{-# INLINE otelLogError #-}+++{- | Log at WARNING level.++@since 0.4.0.0+-}+otelLogWarning :: String -> IO ()+otelLogWarning = otelLog OTelLogWarning "OpenTelemetry [WARN] "+{-# INLINE otelLogWarning #-}+++{- | Log at INFO level.++@since 0.4.0.0+-}+otelLogInfo :: String -> IO ()+otelLogInfo = otelLog OTelLogInfo "OpenTelemetry [INFO] "+{-# INLINE otelLogInfo #-}+++{- | Log at DEBUG level.++@since 0.4.0.0+-}+otelLogDebug :: String -> IO ()+otelLogDebug = otelLog OTelLogDebug "OpenTelemetry [DEBUG] "+{-# INLINE otelLogDebug #-}
− src/OpenTelemetry/Internal/Logs/Core.hs
@@ -1,311 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE NumericUnderscores #-}-{-# LANGUAGE TypeApplications #-}--module OpenTelemetry.Internal.Logs.Core (- LoggerProviderOptions (..),- emptyLoggerProviderOptions,- createLoggerProvider,- setGlobalLoggerProvider,- getGlobalLoggerProvider,- shutdownLoggerProvider,- forceFlushLoggerProvider,- makeLogger,- emitLogRecord,- addAttribute,- addAttributes,- logRecordGetAttributes,- logDroppedAttributes,- emitOTelLogRecord,-) where--import Control.Applicative-import Control.Concurrent.Async-import Control.Monad-import Control.Monad.Trans-import Control.Monad.Trans.Maybe-import Data.Coerce-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as H-import Data.IORef-import Data.Maybe-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Vector as V-import Data.Version (showVersion)-import GHC.IO (unsafePerformIO)-import qualified OpenTelemetry.Attributes as A-import OpenTelemetry.Common-import OpenTelemetry.Context-import OpenTelemetry.Context.ThreadLocal-import OpenTelemetry.Internal.Common.Types-import OpenTelemetry.Internal.Logs.Types-import OpenTelemetry.Internal.Trace.Types (SpanContext (..), getSpanContext)-import OpenTelemetry.LogAttributes (LogAttributes)-import qualified OpenTelemetry.LogAttributes as LA-import OpenTelemetry.Resource (MaterializedResources, emptyMaterializedResources)-import Paths_hs_opentelemetry_api (version)-import System.Clock-import System.Timeout (timeout)---getCurrentTimestamp :: (MonadIO m) => m Timestamp-getCurrentTimestamp = liftIO $ coerce @(IO TimeSpec) @(IO Timestamp) $ getTime Realtime---data LoggerProviderOptions = LoggerProviderOptions- { loggerProviderOptionsResource :: MaterializedResources- , loggerProviderOptionsAttributeLimits :: A.AttributeLimits- }---{- | Options for creating a @LoggerProvider@ with no resources and default limits.-- In effect, logging is a no-op when using this configuration and no-op Processors.--}-emptyLoggerProviderOptions :: LoggerProviderOptions-emptyLoggerProviderOptions =- LoggerProviderOptions- { loggerProviderOptionsResource = emptyMaterializedResources- , loggerProviderOptionsAttributeLimits = A.defaultAttributeLimits- }---{- | Initialize a new @LoggerProvider@-- You should generally use @getGlobalLoggerProvider@ for most applications.--}-createLoggerProvider :: [LogRecordProcessor] -> LoggerProviderOptions -> LoggerProvider-createLoggerProvider ps LoggerProviderOptions {..} =- LoggerProvider- { loggerProviderProcessors = V.fromList ps- , loggerProviderResource = loggerProviderOptionsResource- , loggerProviderAttributeLimits = loggerProviderOptionsAttributeLimits- }----- | Logging is no-op when using this @LoggerProvider@ because it has no processors and empty options.-noOpLoggerProvider :: LoggerProvider-noOpLoggerProvider = createLoggerProvider [] emptyLoggerProviderOptions---globalLoggerProvider :: IORef LoggerProvider-globalLoggerProvider = unsafePerformIO $ newIORef noOpLoggerProvider-{-# NOINLINE globalLoggerProvider #-}----- | Access the globally configured @LoggerProvider@. This @LoggerProvider@ is no-op until initialized by the SDK-getGlobalLoggerProvider :: (MonadIO m) => m LoggerProvider-getGlobalLoggerProvider = liftIO $ readIORef globalLoggerProvider---{- | Overwrite the globally configured @LoggerProvider@.-- @Logger@s acquired from the previously installed @LoggerProvider@s- will continue to use that @LoggerProvider@s settings.--}-setGlobalLoggerProvider :: (MonadIO m) => LoggerProvider -> m ()-setGlobalLoggerProvider = liftIO . writeIORef globalLoggerProvider---{- | This method provides a way for provider to do any cleanup required.-- This will also trigger shutdowns on all internal processors.--}-shutdownLoggerProvider :: (MonadIO m) => LoggerProvider -> m ()-shutdownLoggerProvider LoggerProvider {loggerProviderProcessors} = liftIO $ do- asyncShutdownResults <- V.forM loggerProviderProcessors $ \processor -> do- logRecordProcessorShutdown processor- mapM_ wait asyncShutdownResults---{- | This method provides a way for provider to immediately export all @LogRecord@s that have not yet- been exported for all the internal processors.--}-forceFlushLoggerProvider- :: (MonadIO m)- => LoggerProvider- -> Maybe Int- -- ^ Optional timeout in microseconds, defaults to 5,000,000 (5s)- -> m FlushResult- -- ^ Result that denotes whether the flush action succeeded, failed, or timed out.-forceFlushLoggerProvider LoggerProvider {loggerProviderProcessors} mtimeout = liftIO $ do- jobs <- V.forM loggerProviderProcessors $ \processor -> async $ do- logRecordProcessorForceFlush processor- mresult <-- timeout (fromMaybe 5_000_000 mtimeout) $- V.foldM- ( \status action -> do- res <- waitCatch action- pure $! case res of- Left _err -> FlushError- Right _ok -> status- )- FlushSuccess- jobs- case mresult of- Nothing -> pure FlushTimeout- Just res -> pure res---makeLogger- :: LoggerProvider- -- ^ The @LoggerProvider@ holds the configuration for the @Logger@.- -> InstrumentationLibrary- -- ^ The library that the @Logger@ instruments. This uniquely identifies the @Logger@.- -> Logger-makeLogger loggerLoggerProvider loggerInstrumentationScope = Logger {..}---createImmutableLogRecord- :: (MonadIO m)- => LA.AttributeLimits- -> LogRecordArguments- -> m ImmutableLogRecord-createImmutableLogRecord attributeLimits LogRecordArguments {..} = do- currentTimestamp <- getCurrentTimestamp- let logRecordObservedTimestamp = fromMaybe currentTimestamp observedTimestamp-- logRecordTracingDetails <- runMaybeT $ do- currentContext <- liftIO getContext- currentSpan <- MaybeT $ pure $ lookupSpan $ fromMaybe currentContext context- SpanContext {traceId, spanId, traceFlags} <- getSpanContext currentSpan- pure (traceId, spanId, traceFlags)-- let logRecordAttributes =- LA.addAttributes- attributeLimits- LA.emptyAttributes- attributes-- when (LA.attributesDropped logRecordAttributes > 0) $ void logDroppedAttributes-- pure- ImmutableLogRecord- { logRecordTimestamp = timestamp- , logRecordObservedTimestamp- , logRecordTracingDetails- , logRecordSeverityNumber = severityNumber- , logRecordSeverityText = severityText <|> (toShortName =<< severityNumber)- , logRecordBody = body- , logRecordAttributes- }----- | WARNING: this function should only be used to emit logs from the hs-opentelemetry-api library. DO NOT USE this function in any other context.-logDroppedAttributes :: (MonadIO m) => m ReadWriteLogRecord-logDroppedAttributes = emitOTelLogRecord H.empty Warn "At least 1 attribute was discarded due to the attribute limits set in the logger provider."----- | WARNING: this function should only be used to emit logs from the hs-opentelemetry-api library. DO NOT USE this function in any other context.-emitOTelLogRecord :: (MonadIO m) => H.HashMap Text LA.AnyValue -> SeverityNumber -> Text -> m ReadWriteLogRecord-emitOTelLogRecord attrs severity bodyText = do- glp <- getGlobalLoggerProvider- let gl =- makeLogger glp $- InstrumentationLibrary- { libraryName = "hs-opentelemetry-api"- , libraryVersion = T.pack $ showVersion version- , librarySchemaUrl = ""- , libraryAttributes = A.emptyAttributes- }-- emitLogRecord gl $- emptyLogRecordArguments- { severityNumber = Just severity- , body = toValue bodyText- , attributes = attrs- }---{- | Emits a @LogRecord@ with properties specified by the passed in Logger and LogRecordArguments.-If observedTimestamp is not set in LogRecordArguments, it will default to the current timestamp.-If context is not specified in LogRecordArguments it will default to the current context.--The emitted @LogRecord@ will be passed to any @LogRecordProcessor@s registered on the @LoggerProvider@-that created the @Logger@.--}-emitLogRecord- :: (MonadIO m)- => Logger- -> LogRecordArguments- -> m ReadWriteLogRecord-emitLogRecord l args = do- let LoggerProvider {loggerProviderProcessors, loggerProviderAttributeLimits} = loggerLoggerProvider l-- ilr <- createImmutableLogRecord loggerProviderAttributeLimits args- lr <- liftIO $ mkReadWriteLogRecord l ilr-- ctxt <- getContext- mapM_ (\processor -> liftIO $ logRecordProcessorOnEmit processor lr ctxt) loggerProviderProcessors-- pure lr---{- | Add an attribute to a @LogRecord@.--This is not an atomic modification--As an application developer when you need to record an attribute first consult existing semantic conventions for Resources, Spans, and Metrics. If an appropriate name does not exists you will need to come up with a new name. To do that consider a few options:--The name is specific to your company and may be possibly used outside the company as well. To avoid clashes with names introduced by other companies (in a distributed system that uses applications from multiple vendors) it is recommended to prefix the new name by your company’s reverse domain name, e.g. 'com.acme.shopname'.--The name is specific to your application that will be used internally only. If you already have an internal company process that helps you to ensure no name clashes happen then feel free to follow it. Otherwise it is recommended to prefix the attribute name by your application name, provided that the application name is reasonably unique within your organization (e.g. 'myuniquemapapp.longitude' is likely fine). Make sure the application name does not clash with an existing semantic convention namespace.--The name may be generally applicable to applications in the industry. In that case consider submitting a proposal to this specification to add a new name to the semantic conventions, and if necessary also to add a new namespace.--It is recommended to limit names to printable Basic Latin characters (more precisely to 'U+0021' .. 'U+007E' subset of Unicode code points), although the Haskell OpenTelemetry specification DOES provide full Unicode support.--Attribute names that start with 'otel.' are reserved to be defined by OpenTelemetry specification. These are typically used to express OpenTelemetry concepts in formats that don’t have a corresponding concept.--For example, the 'otel.library.name' attribute is used to record the instrumentation library name, which is an OpenTelemetry concept that is natively represented in OTLP, but does not have an equivalent in other telemetry formats and protocols.--Any additions to the 'otel.*' namespace MUST be approved as part of OpenTelemetry specification.--}-addAttribute :: (IsReadWriteLogRecord r, MonadIO m, ToValue a) => r -> Text -> a -> m ()-addAttribute lr k v =- let attributeLimits = readLogRecordAttributeLimits lr- in liftIO $- modifyLogRecord- lr- ( \ilr@ImmutableLogRecord {logRecordAttributes} ->- ilr- { logRecordAttributes =- LA.addAttribute- attributeLimits- logRecordAttributes- k- v- }- )---{- | A convenience function related to 'addAttribute' that adds multiple attributes to a @LogRecord@ at the same time.--This function may be slightly more performant than repeatedly calling 'addAttribute'.--This is not an atomic modification--}-addAttributes :: (IsReadWriteLogRecord r, MonadIO m, ToValue a) => r -> HashMap Text a -> m ()-addAttributes lr attrs =- let attributeLimits = readLogRecordAttributeLimits lr- in liftIO $- modifyLogRecord- lr- ( \ilr@ImmutableLogRecord {logRecordAttributes} ->- ilr- { logRecordAttributes =- LA.addAttributes- attributeLimits- logRecordAttributes- attrs- }- )---{- | This can be useful for pulling data for attributes and- using it to copy / otherwise use the data to further enrich- instrumentation.--}-logRecordGetAttributes :: (IsReadableLogRecord r, MonadIO m) => r -> m LogAttributes-logRecordGetAttributes lr = liftIO $ logRecordAttributes <$> readLogRecord lr
− src/OpenTelemetry/Internal/Logs/Types.hs
@@ -1,491 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}--module OpenTelemetry.Internal.Logs.Types (- LogRecordExporter,- LogRecordExporterArguments (..),- mkLogRecordExporter,- logRecordExporterExport,- logRecordExporterForceFlush,- logRecordExporterShutdown,- LogRecordProcessor (..),- LoggerProvider (..),- Logger (..),- ReadWriteLogRecord,- mkReadWriteLogRecord,- ReadableLogRecord,- mkReadableLogRecord,- IsReadableLogRecord (..),- IsReadWriteLogRecord (..),- ImmutableLogRecord (..),- LogRecordArguments (..),- emptyLogRecordArguments,- SeverityNumber (..),- toShortName,-) where--import Control.Concurrent (MVar, newMVar, withMVar)-import Control.Concurrent.Async-import Data.Function (on)-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as H-import Data.IORef (IORef, atomicModifyIORef, modifyIORef, newIORef, readIORef)-import Data.Text (Text)-import Data.Vector (Vector)-import OpenTelemetry.Common (Timestamp, TraceFlags)-import OpenTelemetry.Context.Types (Context)-import OpenTelemetry.Internal.Common.Types (ExportResult, InstrumentationLibrary, ShutdownResult)-import OpenTelemetry.Internal.Trace.Id (SpanId, TraceId)-import OpenTelemetry.LogAttributes-import OpenTelemetry.Resource (MaterializedResources)----- | See @LogRecordExporter@ for documentation-data LogRecordExporterArguments = LogRecordExporterArguments- { logRecordExporterArgumentsExport :: Vector ReadableLogRecord -> IO ExportResult- -- ^ See @logRecordExporterExport@ for documentation- , logRecordExporterArgumentsForceFlush :: IO ()- -- ^ See @logRecordExporterArgumentsForceFlush@ for documentation- , logRecordExporterArgumentsShutdown :: IO ()- -- ^ See @logRecordExporterArgumentsShutdown@ for documentation- }---{- | @LogRecordExporter@ defines the interface that protocol-specific exporters must implement so that they can be plugged into OpenTelemetry SDK and support sending of telemetry data.--The goal of the interface is to minimize burden of implementation for protocol-dependent telemetry exporters. The protocol exporter is expected to be primarily a simple telemetry data encoder and transmitter.--@LogRecordExporter@s provide thread safety when calling @logRecordExporterExport@--}-newtype LogRecordExporter = LogRecordExporter {unExporter :: MVar LogRecordExporterArguments}---mkLogRecordExporter :: LogRecordExporterArguments -> IO LogRecordExporter-mkLogRecordExporter = fmap LogRecordExporter . newMVar---{- | Exports a batch of ReadableLogRecords. Protocol exporters that will implement this function are typically expected to serialize-and transmit the data to the destination.--Export will never be called concurrently for the same exporter instance. Depending on the implementation the result of the export-may be returned to the Processor not in the return value of the call to Export but in a language specific way for signaling completion-of an asynchronous task. This means that while an instance of an exporter will never have it Export called concurrently it does not-mean that the task of exporting can not be done concurrently. How this is done is outside the scope of this specification.-Each implementation MUST document the concurrency characteristics the SDK requires of the exporter.--Export MUST NOT block indefinitely, there MUST be a reasonable upper limit after which the call must time out with an error result (Failure).--Concurrent requests and retry logic is the responsibility of the exporter. The default SDK’s LogRecordProcessors SHOULD NOT implement-retry logic, as the required logic is likely to depend heavily on the specific protocol and backend the logs are being sent to.-For example, the OpenTelemetry Protocol (OTLP) specification defines logic for both sending concurrent requests and retrying requests.--Result:-Success - The batch has been successfully exported. For protocol exporters this typically means that the data is sent over the wire and delivered to the destination server.-Failure - exporting failed. The batch must be dropped. For example, this can happen when the batch contains bad data and cannot be serialized.--}-logRecordExporterExport :: LogRecordExporter -> Vector ReadableLogRecord -> IO ExportResult-logRecordExporterExport exporter lrs = withMVar (unExporter exporter) $ \e -> logRecordExporterArgumentsExport e lrs---{- | This is a hint to ensure that the export of any ReadableLogRecords the exporter has received prior to the call to ForceFlush SHOULD-be completed as soon as possible, preferably before returning from this method.--ForceFlush SHOULD provide a way to let the caller know whether it succeeded, failed or timed out.--ForceFlush SHOULD only be called in cases where it is absolutely necessary, such as when using some FaaS providers that may suspend-the process after an invocation, but before the exporter exports the ReadlableLogRecords.--ForceFlush SHOULD complete or abort within some timeout. ForceFlush can be implemented as a blocking API or an asynchronous API which-notifies the caller via a callback or an event. OpenTelemetry SDK authors MAY decide if they want to make the flush timeout configurable.--}-logRecordExporterForceFlush :: LogRecordExporter -> IO ()-logRecordExporterForceFlush = flip withMVar logRecordExporterArgumentsForceFlush . unExporter---{- | Shuts down the exporter. Called when SDK is shut down. This is an opportunity for exporter to do any cleanup required.--Shutdown SHOULD be called only once for each LogRecordExporter instance. After the call to Shutdown subsequent calls to Export are not-allowed and SHOULD return a Failure result.--Shutdown SHOULD NOT block indefinitely (e.g. if it attempts to flush the data and the destination is unavailable).-OpenTelemetry SDK authors MAY decide if they want to make the shutdown timeout configurable.--}-logRecordExporterShutdown :: LogRecordExporter -> IO ()-logRecordExporterShutdown = flip withMVar logRecordExporterArgumentsShutdown . unExporter---{- | LogRecordProcessor is an interface which allows hooks for LogRecord emitting.--Built-in processors are responsible for batching and conversion of LogRecords to exportable representation and passing batches to exporters.--LogRecordProcessors can be registered directly on SDK LoggerProvider and they are invoked in the same order as they were registered.--Each processor registered on LoggerProvider is part of a pipeline that consists of a processor and optional exporter. The SDK MUST allow each pipeline to end with an individual exporter.--The SDK MUST allow users to implement and configure custom processors and decorate built-in processors for advanced scenarios such as enriching with attributes.--The following diagram shows LogRecordProcessor’s relationship to other components in the SDK:--+-----+------------------------+ +------------------------------+ +-------------------------+-| | | | | | |-| | | | Batching LogRecordProcessor | | LogRecordExporter |-| | +---> Simple LogRecordProcessor +---> (OtlpExporter) |-| | | | | | |-| SDK | Logger.emit(LogRecord) | +------------------------------+ +-------------------------+-| | |-| | |-| | |-| | |-| | |-+-----+------------------------+--}-data LogRecordProcessor = LogRecordProcessor- { logRecordProcessorOnEmit :: ReadWriteLogRecord -> Context -> IO ()- -- ^ Called when a LogRecord is emitted. This method is called synchronously on the thread that emitted the LogRecord, therefore it SHOULD NOT block or throw exceptions.- --- -- A LogRecordProcessor may freely modify logRecord for the duration of the OnEmit call. If logRecord is needed after OnEmit returns (i.e. for asynchronous processing) only reads are permitted.- , logRecordProcessorShutdown :: IO (Async ShutdownResult)- -- ^ Shuts down the processor. Called when SDK is shut down. This is an opportunity for processor to do any cleanup required.- --- -- Shutdown SHOULD be called only once for each LogRecordProcessor instance. After the call to Shutdown, subsequent calls to OnEmit are not allowed. SDKs SHOULD ignore these calls gracefully, if possible.- --- -- Shutdown SHOULD provide a way to let the caller know whether it succeeded, failed or timed out.- --- -- Shutdown MUST include the effects of ForceFlush.- --- -- Shutdown SHOULD complete or abort within some timeout. Shutdown can be implemented as a blocking API or an asynchronous API which notifies the caller via a callback or an event.- -- OpenTelemetry SDK authors can decide if they want to make the shutdown timeout configurable.- , logRecordProcessorForceFlush :: IO ()- -- ^ This is a hint to ensure that any tasks associated with LogRecords for which the LogRecordProcessor had already received events prior to the call to ForceFlush SHOULD be completed- -- as soon as possible, preferably before returning from this method.- --- -- In particular, if any LogRecordProcessor has any associated exporter, it SHOULD try to call the exporter’s Export with all LogRecords for which this was not already done and then invoke ForceFlush on it.- -- The built-in LogRecordProcessors MUST do so. If a timeout is specified (see below), the LogRecordProcessor MUST prioritize honoring the timeout over finishing all calls. It MAY skip or abort some or all- -- Export or ForceFlush calls it has made to achieve this goal.- --- -- ForceFlush SHOULD provide a way to let the caller know whether it succeeded, failed or timed out.- --- -- ForceFlush SHOULD only be called in cases where it is absolutely necessary, such as when using some FaaS providers that may suspend the process after an invocation, but before the LogRecordProcessor exports the emitted LogRecords.- --- -- ForceFlush SHOULD complete or abort within some timeout. ForceFlush can be implemented as a blocking API or an asynchronous API which notifies the caller via a callback or an event. OpenTelemetry SDK authors- -- can decide if they want to make the flush timeout configurable.- }----- | @Logger@s can be created from @LoggerProvider@s-data LoggerProvider = LoggerProvider- { loggerProviderProcessors :: Vector LogRecordProcessor- , loggerProviderResource :: MaterializedResources- -- ^ Describes the source of the log, aka resource. Multiple occurrences of events coming from the same event source can happen across time and they all have the same value of Resource.- -- Can contain for example information about the application that emits the record or about the infrastructure where the application runs. Data formats that represent this data model- -- may be designed in a manner that allows the Resource field to be recorded only once per batch of log records that come from the same source. SHOULD follow OpenTelemetry semantic conventions for Resources.- -- This field is optional.- , loggerProviderAttributeLimits :: AttributeLimits- }---{- | @LogRecords@ can be created from @Loggers@. @Logger@s are uniquely identified by the @libraryName@, @libraryVersion@, @schemaUrl@ fields of @InstrumentationLibrary@.-Creating two @Logger@s with the same identity but different @libraryAttributes@ is a user error.--}-data Logger = Logger- { loggerInstrumentationScope :: InstrumentationLibrary- -- ^ Details about the library that the @Logger@ instruments.- , loggerLoggerProvider :: LoggerProvider- -- ^ The @LoggerProvider@ that created this @Logger@. All configuration for the @Logger@ is contained in the @LoggerProvider@.- }---{- | This is a data type that can represent logs from various sources: application log files, machine generated events, system logs, etc. [Specification outlined here.](https://opentelemetry.io/docs/specs/otel/logs/data-model/)-Existing log formats can be unambiguously mapped to this data type. Reverse mapping from this data type is also possible to the extent that the target log format has equivalent capabilities.-Uses an IORef under the hood to allow mutability.--}-data ReadWriteLogRecord = ReadWriteLogRecord Logger (IORef ImmutableLogRecord)---mkReadWriteLogRecord :: Logger -> ImmutableLogRecord -> IO ReadWriteLogRecord-mkReadWriteLogRecord l = fmap (ReadWriteLogRecord l) . newIORef---newtype ReadableLogRecord = ReadableLogRecord {readableLogRecord :: ReadWriteLogRecord}---mkReadableLogRecord :: ReadWriteLogRecord -> ReadableLogRecord-mkReadableLogRecord = ReadableLogRecord---{- | This is a typeclass representing @LogRecord@s that can be read from.--A function receiving this as an argument MUST be able to access all the information added to the LogRecord. It MUST also be able to access the Instrumentation Scope and Resource information (implicitly) associated with the LogRecord.--The trace context fields MUST be populated from the resolved Context (either the explicitly passed Context or the current Context) when emitted.--Counts for attributes due to collection limits MUST be available for exporters to report as described in the transformation to non-OTLP formats specification.--}-class IsReadableLogRecord r where- -- | Reads the current state of the @LogRecord@ from its internal @IORef@. The implementation mirrors @readIORef@.- readLogRecord :: r -> IO ImmutableLogRecord--- -- | Reads the @InstrumentationScope@ from the @Logger@ that emitted the @LogRecord@- readLogRecordInstrumentationScope :: r -> InstrumentationLibrary--- -- | Reads the @Resource@ from the @LoggerProvider@ that emitted the @LogRecord@- readLogRecordResource :: r -> MaterializedResources---{- | This is a typeclass representing @LogRecord@s that can be read from or written to. All @ReadWriteLogRecord@s are @ReadableLogRecord@s.--A function receiving this as an argument MUST additionally be able to modify the following information added to the LogRecord:--- Timestamp-- ObservedTimestamp-- SeverityText-- SeverityNumber-- Body-- Attributes (addition, modification, removal)-- TraceId-- SpanId-- TraceFlags--}-class (IsReadableLogRecord r) => IsReadWriteLogRecord r where- -- | Reads the attribute limits from the @LoggerProvider@ that emitted the @LogRecord@. These are needed to add more attributes.- readLogRecordAttributeLimits :: r -> AttributeLimits--- -- | Modifies the @LogRecord@ using its internal @IORef@. This is lazy and is not an atomic operation. The implementation mirrors @modifyIORef@.- modifyLogRecord :: r -> (ImmutableLogRecord -> ImmutableLogRecord) -> IO ()--- -- | An atomic version of @modifyLogRecord@. This function is lazy. The implementation mirrors @atomicModifyIORef@.- atomicModifyLogRecord :: r -> (ImmutableLogRecord -> (ImmutableLogRecord, b)) -> IO b---instance IsReadableLogRecord ReadableLogRecord where- readLogRecord = readLogRecord . readableLogRecord- readLogRecordInstrumentationScope = readLogRecordInstrumentationScope . readableLogRecord- readLogRecordResource = readLogRecordResource . readableLogRecord---instance IsReadableLogRecord ReadWriteLogRecord where- readLogRecord (ReadWriteLogRecord _ ref) = readIORef ref- readLogRecordInstrumentationScope (ReadWriteLogRecord (Logger {loggerInstrumentationScope}) _) = loggerInstrumentationScope- readLogRecordResource (ReadWriteLogRecord Logger {loggerLoggerProvider = LoggerProvider {loggerProviderResource}} _) = loggerProviderResource---instance IsReadWriteLogRecord ReadWriteLogRecord where- readLogRecordAttributeLimits (ReadWriteLogRecord Logger {loggerLoggerProvider = LoggerProvider {loggerProviderAttributeLimits}} _) = loggerProviderAttributeLimits- modifyLogRecord (ReadWriteLogRecord _ ref) = modifyIORef ref- atomicModifyLogRecord (ReadWriteLogRecord _ ref) = atomicModifyIORef ref---data ImmutableLogRecord = ImmutableLogRecord- { logRecordTimestamp :: Maybe Timestamp- -- ^ Time when the event occurred measured by the origin clock. This field is optional, it may be missing if the timestamp is unknown.- , logRecordObservedTimestamp :: Timestamp- -- ^ Time when the event was observed by the collection system. For events that originate in OpenTelemetry (e.g. using OpenTelemetry Logging SDK)- -- this timestamp is typically set at the generation time and is equal to Timestamp. For events originating externally and collected by OpenTelemetry (e.g. using Collector)- -- this is the time when OpenTelemetry’s code observed the event measured by the clock of the OpenTelemetry code. This field SHOULD be set once the event is observed by OpenTelemetry.- --- -- For converting OpenTelemetry log data to formats that support only one timestamp or when receiving OpenTelemetry log data by recipients that support only one timestamp internally the following logic is recommended:- -- - Use Timestamp if it is present, otherwise use ObservedTimestamp- , logRecordTracingDetails :: Maybe (TraceId, SpanId, TraceFlags)- -- ^ Tuple contains three fields:- --- -- - Request trace id as defined in W3C Trace Context. Can be set for logs that are part of request processing and have an assigned trace id.- -- - Span id. Can be set for logs that are part of a particular processing span.- -- - Trace flag as defined in W3C Trace Context specification. At the time of writing the specification defines one flag - the SAMPLED flag.- , logRecordSeverityText :: Maybe Text- -- ^ severity text (also known as log level). This is the original string representation of the severity as it is known at the source. If this field is missing- -- and SeverityNumber is present then the short name that corresponds to the SeverityNumber may be used as a substitution. This field is optional.- , logRecordSeverityNumber :: Maybe SeverityNumber- -- ^ SeverityNumber is an integer number. Smaller numerical values correspond to less severe events (such as debug events), larger numerical values correspond to- -- more severe events (such as errors and critical events). The following table defines the meaning of SeverityNumber value:- --- -- +-----------------------+-------------+------------------------------------------------------------------------------------------+- -- | SeverityNumber range | Range name | Meaning |- -- +=======================+=============+==========================================================================================+- -- | 1-4 | TRACE | A fine-grained debugging event. Typically disabled in default configurations. |- -- +-----------------------+-------------+------------------------------------------------------------------------------------------+- -- | 5-8 | DEBUG | A debugging event. |- -- +-----------------------+-------------+------------------------------------------------------------------------------------------+- -- | 9-12 | INFO | An informational event. Indicates that an event happened. |- -- +-----------------------+-------------+------------------------------------------------------------------------------------------+- -- | 13-16 | WARN | A warning event. Not an error but is likely more important than an informational event. |- -- +-----------------------+-------------+------------------------------------------------------------------------------------------+- -- | 17-20 | ERROR | An error event. Something went wrong. |- -- +-----------------------+-------------+------------------------------------------------------------------------------------------+- -- | 21-24 | FATAL | A fatal error such as application or system crash. |- -- +-----------------------+-------------+------------------------------------------------------------------------------------------+- -- Smaller numerical values in each range represent less important (less severe) events. Larger numerical values in each range represent more important (more severe) events.- -- For example SeverityNumber=17 describes an error that is less critical than an error with SeverityNumber=20.- --- -- Mappings from existing logging systems and formats (or source format for short) must define how severity (or log level) of that particular format corresponds to SeverityNumber- -- of this data model based on the meaning given for each range in the above table. [More Information](https://opentelemetry.io/docs/specs/otel/logs/data-model/#mapping-of-severitynumber)- --- -- [These short names](https://opentelemetry.io/docs/specs/otel/logs/data-model/#displaying-severity) can be used to represent SeverityNumber in the UI- --- -- In the contexts where severity participates in less-than / greater-than comparisons SeverityNumber field should be used.- -- SeverityNumber can be compared to another SeverityNumber or to numbers in the 1..24 range (or to the corresponding short names).- , logRecordBody :: AnyValue- -- ^ A value containing the body of the log record. Can be for example a human-readable string message (including multi-line) describing the event in a free form or it can be a- -- structured data composed of arrays and maps of other values. Body MUST support any type to preserve the semantics of structured logs emitted by the applications.- -- Can vary for each occurrence of the event coming from the same source. This field is optional.- --- -- Type any- -- Value of type any can be one of the following:- -- - A scalar value: number, string or boolean,- -- - A byte array,- -- - An array (a list) of any values,- -- - A map<string, any>.- , logRecordAttributes :: LogAttributes- -- ^ Additional information about the specific event occurrence. Unlike the Resource field, which is fixed for a particular source, Attributes can vary for each occurrence of the event coming from the same source.- -- Can contain information about the request context (other than Trace Context Fields). The log attribute model MUST support any type, a superset of standard Attribute, to preserve the semantics of structured attributes- -- emitted by the applications. This field is optional.- }---{- | Arguments that may be set on LogRecord creation. If observedTimestamp is not set, it will default to the current timestamp.-If context is not specified it will default to the current context. Refer to the documentation of @LogRecord@ for descriptions-of the fields.--}-data LogRecordArguments = LogRecordArguments- { timestamp :: Maybe Timestamp- , observedTimestamp :: Maybe Timestamp- , context :: Maybe Context- , severityText :: Maybe Text- , severityNumber :: Maybe SeverityNumber- , body :: AnyValue- , attributes :: HashMap Text AnyValue- }---emptyLogRecordArguments :: LogRecordArguments-emptyLogRecordArguments =- LogRecordArguments- { timestamp = Nothing- , observedTimestamp = Nothing- , context = Nothing- , severityText = Nothing- , severityNumber = Nothing- , body = NullValue- , attributes = H.empty- }---data SeverityNumber- = Trace- | Trace2- | Trace3- | Trace4- | Debug- | Debug2- | Debug3- | Debug4- | Info- | Info2- | Info3- | Info4- | Warn- | Warn2- | Warn3- | Warn4- | Error- | Error2- | Error3- | Error4- | Fatal- | Fatal2- | Fatal3- | Fatal4- | Unknown !Int---instance Enum SeverityNumber where- toEnum 1 = Trace- toEnum 2 = Trace2- toEnum 3 = Trace3- toEnum 4 = Trace4- toEnum 5 = Debug- toEnum 6 = Debug2- toEnum 7 = Debug3- toEnum 8 = Debug4- toEnum 9 = Info- toEnum 10 = Info2- toEnum 11 = Info3- toEnum 12 = Info4- toEnum 13 = Warn- toEnum 14 = Warn2- toEnum 15 = Warn3- toEnum 16 = Warn4- toEnum 17 = Error- toEnum 18 = Error2- toEnum 19 = Error3- toEnum 20 = Error4- toEnum 21 = Fatal- toEnum 22 = Fatal2- toEnum 23 = Fatal3- toEnum 24 = Fatal4- toEnum n = Unknown n--- fromEnum Trace = 1- fromEnum Trace2 = 2- fromEnum Trace3 = 3- fromEnum Trace4 = 4- fromEnum Debug = 5- fromEnum Debug2 = 6- fromEnum Debug3 = 7- fromEnum Debug4 = 8- fromEnum Info = 9- fromEnum Info2 = 10- fromEnum Info3 = 11- fromEnum Info4 = 12- fromEnum Warn = 13- fromEnum Warn2 = 14- fromEnum Warn3 = 15- fromEnum Warn4 = 16- fromEnum Error = 17- fromEnum Error2 = 18- fromEnum Error3 = 19- fromEnum Error4 = 20- fromEnum Fatal = 21- fromEnum Fatal2 = 22- fromEnum Fatal3 = 23- fromEnum Fatal4 = 24- fromEnum (Unknown n) = n---instance Eq SeverityNumber where- (==) = on (==) fromEnum---instance Ord SeverityNumber where- compare = on compare fromEnum---toShortName :: SeverityNumber -> Maybe Text-toShortName Trace = Just "TRACE"-toShortName Trace2 = Just "TRACE2"-toShortName Trace3 = Just "TRACE3"-toShortName Trace4 = Just "TRACE4"-toShortName Debug = Just "DEBUG"-toShortName Debug2 = Just "DEBUG2"-toShortName Debug3 = Just "DEBUG3"-toShortName Debug4 = Just "DEBUG4"-toShortName Info = Just "INFO"-toShortName Info2 = Just "INFO2"-toShortName Info3 = Just "INFO3"-toShortName Info4 = Just "INFO4"-toShortName Warn = Just "WARN"-toShortName Warn2 = Just "WARN2"-toShortName Warn3 = Just "WARN3"-toShortName Warn4 = Just "WARN4"-toShortName Error = Just "ERROR"-toShortName Error2 = Just "ERROR2"-toShortName Error3 = Just "ERROR3"-toShortName Error4 = Just "ERROR4"-toShortName Fatal = Just "FATAL"-toShortName Fatal2 = Just "FATAL2"-toShortName Fatal3 = Just "FATAL3"-toShortName Fatal4 = Just "FATAL4"-toShortName (Unknown _) = Nothing
+ src/OpenTelemetry/Internal/Metric/Export.hs view
@@ -0,0 +1,274 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE StrictData #-}++{- |+Module : OpenTelemetry.Internal.Metric.Export+Copyright : (c) Ian Duncan, 2026+License : BSD-3+Description : Export data types for metric data points and aggregations.+Stability : experimental++Defines the Haskell representation of metric data as seen by exporters:+sum/gauge/histogram/exponential-histogram data points, exemplars, resource+and scope wrappers. Not intended for direct import; use+"OpenTelemetry.Exporter.Metric" instead.++Spec: <https://opentelemetry.io/docs/specs/otel/metrics/sdk/>+-}+module OpenTelemetry.Internal.Metric.Export (+ AggregationTemporality (..),+ NumberValue (..),+ OptionalDouble (..),+ toMaybeDouble,+ MetricExemplar (..),+ SumDataPoint (..),+ HistogramDataPoint (..),+ ExponentialHistogramDataPoint (..),+ GaugeDataPoint (..),+ MetricExport (..),+ ScopeMetricsExport (..),+ ResourceMetricsExport (..),+ MetricExporter (..),+ filterAttributesByKeys,+ complementAttributesByKeys,+) where++import Data.ByteString (ByteString)+import qualified Data.HashMap.Strict as H+import qualified Data.HashSet as HS+import Data.Int (Int32, Int64)+import Data.Text (Text)+import Data.Vector (Vector)+import Data.Word (Word64)+import GHC.Generics (Generic)+import OpenTelemetry.Attributes (Attributes, emptyAttributes, getAttributeMap, unsafeAttributesFromMapIgnoringLimits)+import OpenTelemetry.Internal.Common.Types (ExportResult, FlushResult, InstrumentationLibrary, ShutdownResult)+import OpenTelemetry.Resource (MaterializedResources)+++{- | Export-time aggregation temporality (maps to OTLP 'AggregationTemporality').++@since 0.0.1.0+-}+data AggregationTemporality+ = AggregationDelta+ | AggregationCumulative+ deriving stock (Eq, Show, Generic)+++{- | A numeric metric value, either integral or floating-point.+Uses UNPACK to avoid the extra indirection that 'Either' 'Int64' 'Double' incurs.++@since 0.0.1.0+-}+data NumberValue+ = IntNumber {-# UNPACK #-} !Int64+ | DoubleNumber {-# UNPACK #-} !Double+ deriving stock (Eq, Show, Generic)+++{- | An optional 'Double', using UNPACK to avoid the extra box that @Maybe Double@ incurs.+2 words for 'SomeDouble' vs 4 for @Just (D# x)@.++@since 0.0.1.0+-}+data OptionalDouble+ = NoDouble+ | SomeDouble {-# UNPACK #-} !Double+ deriving stock (Eq, Show, Generic)+++{- | Convert to the standard @Maybe Double@ (e.g. for OTLP export).++@since 0.0.1.0+-}+toMaybeDouble :: OptionalDouble -> Maybe Double+toMaybeDouble NoDouble = Nothing+toMaybeDouble (SomeDouble d) = Just d+{-# INLINE toMaybeDouble #-}+++{- | Exemplar (trace link + optional measurement) for OTLP 'Exemplar'.++@since 0.0.1.0+-}+data MetricExemplar = MetricExemplar+ { metricExemplarTraceId :: !ByteString+ , metricExemplarSpanId :: !ByteString+ , metricExemplarTimeUnixNano :: !Word64+ , metricExemplarFilteredAttributes :: !Attributes+ , metricExemplarValue :: !(Maybe NumberValue)+ }+ deriving stock (Eq, Show, Generic)+++{- | One sum data point (cumulative or delta depending on reader temporality in SDK).++@since 0.0.1.0+-}+data SumDataPoint = SumDataPoint+ { sumDataPointStartTimeUnixNano :: !Word64+ , sumDataPointTimeUnixNano :: !Word64+ , sumDataPointValue :: !NumberValue+ , sumDataPointAttributes :: !Attributes+ , sumDataPointExemplars :: !(Vector MetricExemplar)+ }+ deriving stock (Eq, Show, Generic)+++{- | Histogram bucket counts (explicit boundaries) + sum + count.++@since 0.0.1.0+-}+data HistogramDataPoint = HistogramDataPoint+ { histogramDataPointStartTimeUnixNano :: !Word64+ , histogramDataPointTimeUnixNano :: !Word64+ , histogramDataPointCount :: !Word64+ , histogramDataPointSum :: !Double+ , histogramDataPointBucketCounts :: !(Vector Word64)+ , histogramDataPointExplicitBounds :: !(Vector Double)+ , histogramDataPointAttributes :: !Attributes+ , histogramDataPointMin :: !(Maybe Double)+ , histogramDataPointMax :: !(Maybe Double)+ , histogramDataPointExemplars :: !(Vector MetricExemplar)+ }+ deriving stock (Eq, Show, Generic)+++{- | Exponential histogram data point (OTLP native exponential layout).++@since 0.0.1.0+-}+data ExponentialHistogramDataPoint = ExponentialHistogramDataPoint+ { exponentialHistogramDataPointStartTimeUnixNano :: !Word64+ , exponentialHistogramDataPointTimeUnixNano :: !Word64+ , exponentialHistogramDataPointCount :: !Word64+ , exponentialHistogramDataPointSum :: !(Maybe Double)+ , exponentialHistogramDataPointScale :: !Int32+ , exponentialHistogramDataPointZeroCount :: !Word64+ , exponentialHistogramDataPointPositiveOffset :: !Int32+ , exponentialHistogramDataPointPositiveBucketCounts :: !(Vector Word64)+ , exponentialHistogramDataPointNegativeOffset :: !Int32+ , exponentialHistogramDataPointNegativeBucketCounts :: !(Vector Word64)+ , exponentialHistogramDataPointAttributes :: !Attributes+ , exponentialHistogramDataPointMin :: !(Maybe Double)+ , exponentialHistogramDataPointMax :: !(Maybe Double)+ , exponentialHistogramDataPointExemplars :: !(Vector MetricExemplar)+ , exponentialHistogramDataPointZeroThreshold :: !Double+ }+ deriving stock (Eq, Show, Generic)+++{- | Last-value gauge point.++@since 0.0.1.0+-}+data GaugeDataPoint = GaugeDataPoint+ { gaugeDataPointStartTimeUnixNano :: !Word64+ , gaugeDataPointTimeUnixNano :: !Word64+ , gaugeDataPointValue :: !NumberValue+ , gaugeDataPointAttributes :: !Attributes+ , gaugeDataPointExemplars :: !(Vector MetricExemplar)+ }+ deriving stock (Eq, Show, Generic)+++{- | One exported metric (all points share name/unit/description/scope).++@since 0.0.1.0+-}+data MetricExport+ = MetricExportSum+ { mesName :: !Text+ , mesDescription :: !Text+ , mesUnit :: !Text+ , mesScope :: !InstrumentationLibrary+ , mesMonotonic :: !Bool+ , mesIsInt :: !Bool+ , mesAggregationTemporality :: !AggregationTemporality+ , mesSumPoints :: !(Vector SumDataPoint)+ }+ | MetricExportHistogram+ { mehName :: !Text+ , mehDescription :: !Text+ , mehUnit :: !Text+ , mehScope :: !InstrumentationLibrary+ , mehAggregationTemporality :: !AggregationTemporality+ , mehPoints :: !(Vector HistogramDataPoint)+ }+ | MetricExportExponentialHistogram+ { meehName :: !Text+ , meehDescription :: !Text+ , meehUnit :: !Text+ , meehScope :: !InstrumentationLibrary+ , meehAggregationTemporality :: !AggregationTemporality+ , meehPoints :: !(Vector ExponentialHistogramDataPoint)+ }+ | MetricExportGauge+ { megName :: !Text+ , megDescription :: !Text+ , megUnit :: !Text+ , megScope :: !InstrumentationLibrary+ , megIsInt :: !Bool+ , megGaugePoints :: !(Vector GaugeDataPoint)+ }+ deriving stock (Eq, Show, Generic)+++-- | @since 0.0.1.0+data ScopeMetricsExport = ScopeMetricsExport+ { scopeMetricsScope :: !InstrumentationLibrary+ , scopeMetricsExports :: !(Vector MetricExport)+ }+ deriving stock (Eq, Show, Generic)+++-- | @since 0.0.1.0+data ResourceMetricsExport = ResourceMetricsExport+ { resourceMetricsResource :: !MaterializedResources+ , resourceMetricsScopes :: !(Vector ScopeMetricsExport)+ }+ deriving stock (Eq, Show, Generic)+++-- | @since 0.0.1.0+data MetricExporter = MetricExporter+ { metricExporterExport :: !(Vector ResourceMetricsExport -> IO ExportResult)+ , metricExporterShutdown :: !(IO ShutdownResult)+ , metricExporterForceFlush :: !(IO FlushResult)+ }+++{- | When a view selects attribute keys, drop other keys at export time+(series identity unchanged).++The 'HashSet' should be pre-built at instrument creation time so that+this function avoids allocating a new set on every data point.++@since 0.0.1.0+-}+filterAttributesByKeys :: Maybe (HS.HashSet Text) -> Attributes -> Attributes+filterAttributesByKeys Nothing attrs = attrs+filterAttributesByKeys (Just keep) attrs =+ let m = getAttributeMap attrs+ m' = H.filterWithKey (\k _ -> k `HS.member` keep || k == "otel.metric.overflow") m+ in unsafeAttributesFromMapIgnoringLimits m'+++{- | Complement of 'filterAttributesByKeys': returns attributes whose keys+are NOT in the export set. Used for exemplar @filtered_attributes@ per spec+§ metrics/sdk.md "Exemplar": "the set of attributes that were filtered out+by the aggregator".++The 'HashSet' should be pre-built at instrument creation time so that+this function avoids allocating a new set on every data point.++@since 0.0.1.0+-}+complementAttributesByKeys :: Maybe (HS.HashSet Text) -> Attributes -> Attributes+complementAttributesByKeys Nothing _ = emptyAttributes+complementAttributesByKeys (Just keep) attrs =+ let m = getAttributeMap attrs+ m' = H.filterWithKey (\k _ -> not (k `HS.member` keep)) m+ in unsafeAttributesFromMapIgnoringLimits m'
+ src/OpenTelemetry/Internal/Metric/Types.hs view
@@ -0,0 +1,275 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE StrictData #-}++{- |+Module : OpenTelemetry.Internal.Metric.Types+Copyright : (c) Ian Duncan, 2026+License : BSD-3+Description : Internal types for the OpenTelemetry Metrics API.+Stability : experimental++Core metric types: instrument kinds, counters, histograms, gauges (sync and+async), meters, and meter providers. Not intended for direct import; use+"OpenTelemetry.Metric.Core" instead.++Spec: <https://opentelemetry.io/docs/specs/otel/metrics/api/>+-}+module OpenTelemetry.Internal.Metric.Types (+ InstrumentKind (..),+ HistogramAggregation (..),+ AdvisoryParameters (..),+ defaultAdvisoryParameters,+ Counter (..),+ UpDownCounter (..),+ Histogram (..),+ Gauge (..),+ ObservableResult (..),+ ObservableCallbackHandle (..),+ ObservableCounter (..),+ ObservableUpDownCounter (..),+ ObservableGauge (..),+ Meter (..),+ MeterProvider (..),+) where++import Data.Hashable (Hashable (hashWithSalt))+import Data.Int (Int32, Int64)+import Data.Text (Text)+import Data.Vector (Vector)+import qualified Data.Vector as V+import GHC.Generics (Generic)+import OpenTelemetry.Attributes (Attributes)+import OpenTelemetry.Internal.Common.Types (FlushResult, InstrumentationLibrary, ShutdownResult)+++{- | Instrument kinds from the metrics API specification.++@since 0.0.1.0+-}+data InstrumentKind+ = KindCounter+ | KindAsyncCounter+ | KindUpDownCounter+ | KindAsyncUpDownCounter+ | KindHistogram+ | KindGauge+ | KindAsyncGauge+ deriving stock (Eq, Show, Ord, Generic)+ deriving anyclass (Hashable)+++{- | Histogram aggregation chosen for an instrument (explicit bounds vs exponential).++@since 0.0.1.0+-}+data HistogramAggregation+ = HistogramAggregationExplicit !(Vector Double)+ | -- | Exponential histogram scale (OTel mapping index uses @2^scale@).+ HistogramAggregationExponential !Int32+ deriving stock (Eq, Show, Generic)+++instance Hashable HistogramAggregation where+ hashWithSalt s (HistogramAggregationExplicit v) =+ V.foldl' hashWithSalt (s `hashWithSalt` (0 :: Int) `hashWithSalt` V.length v) v+ hashWithSalt s (HistogramAggregationExponential sc) =+ s `hashWithSalt` (1 :: Int) `hashWithSalt` sc+++{- | Advisory parameters (spec: implementations MAY ignore; SDK SHOULD honor where defined).++@since 0.0.1.0+-}+data AdvisoryParameters = AdvisoryParameters+ { advisoryExplicitBucketBoundaries :: !(Maybe [Double])+ -- ^ Histogram explicit bucket boundaries (sorted ascending in SDK when applied).+ , advisoryAttributeKeys :: !(Maybe [Text])+ -- ^ Recommended attribute keys for the resulting metric stream (development in spec).+ , advisoryHistogramAggregation :: !(Maybe HistogramAggregation)+ -- ^ Prefer explicit buckets or exponential histogram when set; views may override.+ }+ deriving stock (Eq, Show, Generic)+++-- | @since 0.0.1.0+defaultAdvisoryParameters :: AdvisoryParameters+defaultAdvisoryParameters =+ AdvisoryParameters+ { advisoryExplicitBucketBoundaries = Nothing+ , advisoryAttributeKeys = Nothing+ , advisoryHistogramAggregation = Nothing+ }+++{- | Synchronous counter (non-negative increments). @a@ is 'Int64' or 'Double'.++@since 0.0.1.0+-}+data Counter a = Counter+ { counterAdd :: !(a -> Attributes -> IO ())+ -- ^ Record an increment. Negative values are silently dropped for monotonic counters.+ , counterEnabled :: !(IO Bool)+ -- ^ Whether this instrument is active. Noop instruments return @False@.+ }+++{- | Synchronous additive instrument that may increase or decrease.++@since 0.0.1.0+-}+data UpDownCounter a = UpDownCounter+ { upDownCounterAdd :: !(a -> Attributes -> IO ())+ -- ^ Record an increment (positive) or decrement (negative).+ , upDownCounterEnabled :: !(IO Bool)+ -- ^ Whether this instrument is active.+ }+++{- | Synchronous histogram (records 'Double' measurements).++@since 0.0.1.0+-}+data Histogram = Histogram+ { histogramRecord :: !(Double -> Attributes -> IO ())+ -- ^ Record a measurement. NaN and Infinity are silently dropped.+ , histogramEnabled :: !(IO Bool)+ -- ^ Whether this instrument is active.+ }+++{- | Synchronous gauge (last value wins per collect cycle semantics in SDK).++@since 0.0.1.0+-}+data Gauge a = Gauge+ { gaugeRecord :: !(a -> Attributes -> IO ())+ -- ^ Record a value. The last value per attribute set wins at collection time.+ , gaugeEnabled :: !(IO Bool)+ -- ^ Whether this instrument is active.+ }+++{- | Result handle passed to observable callbacks (spec: observe measurements at one logical instant).++@since 0.0.1.0+-}+newtype ObservableResult a = ObservableResult+ { observe :: a -> Attributes -> IO ()+ -- ^ Report a measurement for the given attribute set.+ }+++{- | Handle to unregister a callback registered after instrument creation.++@since 0.0.1.0+-}+newtype ObservableCallbackHandle = ObservableCallbackHandle+ { unregisterObservableCallback :: IO ()+ -- ^ Remove this callback so it is no longer invoked during collection.+ }+++{- | Asynchronous counter: monotonic cumulative values observed per collection.++@since 0.0.1.0+-}+data ObservableCounter a = ObservableCounter+ { observableCounterRegisterCallback :: !((ObservableResult a -> IO ()) -> IO ObservableCallbackHandle)+ -- ^ Register an additional callback after creation; returns a handle to unregister it.+ , observableCounterInstrumentScope :: !InstrumentationLibrary+ -- ^ The instrumentation scope that created this instrument.+ , observableCounterInstrumentName :: !Text+ -- ^ The instrument name (case-insensitive for matching in the SDK).+ , observableCounterEnabled :: !(IO Bool)+ -- ^ Whether this instrument is active.+ }+++{- | Asynchronous up-down counter.++@since 0.0.1.0+-}+data ObservableUpDownCounter a = ObservableUpDownCounter+ { observableUpDownCounterRegisterCallback :: !((ObservableResult a -> IO ()) -> IO ObservableCallbackHandle)+ -- ^ Register an additional callback after creation.+ , observableUpDownCounterInstrumentScope :: !InstrumentationLibrary+ -- ^ The instrumentation scope that created this instrument.+ , observableUpDownCounterInstrumentName :: !Text+ -- ^ The instrument name.+ , observableUpDownCounterEnabled :: !(IO Bool)+ -- ^ Whether this instrument is active.+ }+++{- | Asynchronous gauge.++@since 0.0.1.0+-}+data ObservableGauge a = ObservableGauge+ { observableGaugeRegisterCallback :: !((ObservableResult a -> IO ()) -> IO ObservableCallbackHandle)+ -- ^ Register an additional callback after creation.+ , observableGaugeInstrumentScope :: !InstrumentationLibrary+ -- ^ The instrumentation scope that created this instrument.+ , observableGaugeInstrumentName :: !Text+ -- ^ The instrument name.+ , observableGaugeEnabled :: !(IO Bool)+ -- ^ Whether this instrument is active.+ }+++{- | Creates instruments for a single instrumentation scope.++@since 0.0.1.0+| All instrument factory functions take: name, optional unit, optional description, advisory parameters.+Observable factories additionally take initial callbacks.+-}+data Meter = Meter+ { meterInstrumentationScope :: !InstrumentationLibrary+ -- ^ The scope that owns instruments created by this meter.+ , meterCreateCounterInt64 :: !(Text -> Maybe Text -> Maybe Text -> AdvisoryParameters -> IO (Counter Int64))+ -- ^ Create a synchronous monotonic Int64 counter.+ , meterCreateCounterDouble :: !(Text -> Maybe Text -> Maybe Text -> AdvisoryParameters -> IO (Counter Double))+ -- ^ Create a synchronous monotonic Double counter.+ , meterCreateUpDownCounterInt64 :: !(Text -> Maybe Text -> Maybe Text -> AdvisoryParameters -> IO (UpDownCounter Int64))+ -- ^ Create a synchronous Int64 up-down counter.+ , meterCreateUpDownCounterDouble :: !(Text -> Maybe Text -> Maybe Text -> AdvisoryParameters -> IO (UpDownCounter Double))+ -- ^ Create a synchronous Double up-down counter.+ , meterCreateHistogram :: !(Text -> Maybe Text -> Maybe Text -> AdvisoryParameters -> IO Histogram)+ -- ^ Create a synchronous histogram.+ , meterCreateGaugeInt64 :: !(Text -> Maybe Text -> Maybe Text -> AdvisoryParameters -> IO (Gauge Int64))+ -- ^ Create a synchronous Int64 gauge.+ , meterCreateGaugeDouble :: !(Text -> Maybe Text -> Maybe Text -> AdvisoryParameters -> IO (Gauge Double))+ -- ^ Create a synchronous Double gauge.+ , meterCreateObservableCounterInt64 :: !(Text -> Maybe Text -> Maybe Text -> AdvisoryParameters -> [ObservableResult Int64 -> IO ()] -> IO (ObservableCounter Int64))+ -- ^ Create an asynchronous Int64 counter with initial callbacks.+ , meterCreateObservableCounterDouble :: !(Text -> Maybe Text -> Maybe Text -> AdvisoryParameters -> [ObservableResult Double -> IO ()] -> IO (ObservableCounter Double))+ -- ^ Create an asynchronous Double counter with initial callbacks.+ , meterCreateObservableUpDownCounterInt64 :: !(Text -> Maybe Text -> Maybe Text -> AdvisoryParameters -> [ObservableResult Int64 -> IO ()] -> IO (ObservableUpDownCounter Int64))+ -- ^ Create an asynchronous Int64 up-down counter with initial callbacks.+ , meterCreateObservableUpDownCounterDouble :: !(Text -> Maybe Text -> Maybe Text -> AdvisoryParameters -> [ObservableResult Double -> IO ()] -> IO (ObservableUpDownCounter Double))+ -- ^ Create an asynchronous Double up-down counter with initial callbacks.+ , meterCreateObservableGaugeInt64 :: !(Text -> Maybe Text -> Maybe Text -> AdvisoryParameters -> [ObservableResult Int64 -> IO ()] -> IO (ObservableGauge Int64))+ -- ^ Create an asynchronous Int64 gauge with initial callbacks.+ , meterCreateObservableGaugeDouble :: !(Text -> Maybe Text -> Maybe Text -> AdvisoryParameters -> [ObservableResult Double -> IO ()] -> IO (ObservableGauge Double))+ -- ^ Create an asynchronous Double gauge with initial callbacks.+ }+++{- | Entry point for metrics API (spec: global default SHOULD exist).++@since 0.0.1.0+-}+data MeterProvider = MeterProvider+ { meterProviderGetMeter :: !(InstrumentationLibrary -> IO Meter)+ -- ^ Get or create a Meter for the given instrumentation scope.+ , meterProviderShutdown :: !(Maybe Int -> IO ShutdownResult)+ {- ^ Shut down the provider, flushing and releasing resources.+ Optional timeout in microseconds; @Nothing@ uses the SDK default (5s).+ -}+ , meterProviderForceFlush :: !(Maybe Int -> IO FlushResult)+ {- ^ Force a collection and export cycle. Optional timeout in microseconds;+ @Nothing@ uses the SDK default (5s).+ -}+ }
src/OpenTelemetry/Internal/Trace/Id.hs view
@@ -1,10 +1,12 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE UnboxedTuples #-} +{- |+Module : OpenTelemetry.Internal.Trace.Id+Description : Internal representation of trace and span identifiers with hex encoding via C FFI.+Stability : experimental+-} module OpenTelemetry.Internal.Trace.Id ( TraceId (..), newTraceId,@@ -17,6 +19,7 @@ traceIdBaseEncodedText, SpanId (..), newSpanId,+ newTraceAndSpanId, isEmptySpanId, spanIdBytes, bytesToSpanId,@@ -25,62 +28,82 @@ spanIdBaseEncodedBuilder, spanIdBaseEncodedByteString, spanIdBaseEncodedText,++ -- * Nil (all-zero) IDs+ nilTraceId,+ nilSpanId,++ -- * Traceparent codec (C FFI)+ decodeTraceparent,+ encodeTraceparent, ) where import Control.Monad.IO.Class (MonadIO (liftIO))-import Data.ByteArray.Encoding (- Base (Base16),- convertFromBase,- convertToBase,- )+import Data.Bits (shiftR, (.&.), (.|.)) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Builder as B-import Data.ByteString.Short.Internal (- ShortByteString (SBS),- fromShort,- toShort,- )-import Data.Hashable (Hashable)+import qualified Data.ByteString.Internal as BI+import Data.ByteString.Short (ShortByteString, fromShort)+import qualified Data.ByteString.Unsafe as BU+import Data.Hashable (Hashable (..)) import Data.Text (Text) import Data.Text.Encoding (decodeUtf8)-import GHC.Exts (- IsString (fromString),- eqWord#,- indexWord64Array#,- int2Word#,- isTrue#,- or#,- )+import Data.Word (Word64, Word8)+import Foreign.C.Types (CInt (..), CSize (..))+import Foreign.Marshal.Alloc (allocaBytes)+import Foreign.Ptr (Ptr, castPtr, plusPtr)+import Foreign.Storable (peek, peekElemOff, poke)+import GHC.Exts (IsString (fromString))+import GHC.Generics (Generic)+import OpenTelemetry.Trace.Id.Generator (IdGenerator (..))+import System.IO.Unsafe (unsafeDupablePerformIO)+import Prelude hiding (length) -#if MIN_VERSION_base(4,17,0)-import GHC.Exts (word64ToWord#)-#endif+-- * C FFI -import GHC.Generics (Generic)-import OpenTelemetry.Trace.Id.Generator (- IdGenerator (generateSpanIdBytes, generateTraceIdBytes),- )-import Prelude hiding (length) +foreign import ccall unsafe "hs_otel_encode_trace_id"+ c_encodeTraceId :: Ptr Word8 -> Ptr Word8 -> IO () --- TODO faster encoding decoding via something like--- https://github.com/lemire/Code-used-on-Daniel-Lemire-s-blog/blob/03fc2e82fdef2c6fd25721203e1654428fee123d/2019/04/17/hexparse.cpp#L390 --- | A valid trace identifier is a 16-byte array with at least one non-zero byte.-newtype TraceId = TraceId ShortByteString- deriving stock (Ord, Eq, Generic)- deriving newtype (Hashable)+foreign import ccall unsafe "hs_otel_encode_span_id"+ c_encodeSpanId :: Ptr Word8 -> Ptr Word8 -> IO () --- | A valid span identifier is an 8-byte array with at least one non-zero byte.-newtype SpanId = SpanId ShortByteString- deriving stock (Ord, Eq)- deriving newtype (Hashable)+foreign import ccall unsafe "hs_otel_decode_hex"+ c_decodeHex :: Ptr Word8 -> Ptr Word8 -> CSize -> IO CInt +foreign import ccall unsafe "hs_otel_xoshiro_next"+ c_xoshiroNext :: IO Word64+++-- * TraceId+++{- | A valid trace identifier is a 16-byte array with at least one non-zero byte.++Stored as two machine-word @Word64@ values in native byte order.+When @UNPACK@ed into a containing record (e.g. 'SpanContext'), both+words are stored inline. No separate heap object, no pointer chase.++ @since 0.0.1.0+-}+data TraceId+ = TraceId+ {-# UNPACK #-} !Word64+ {-# UNPACK #-} !Word64+ deriving stock (Eq, Ord, Generic)+++instance Hashable TraceId where+ hashWithSalt s (TraceId hi lo) = s `hashWithSalt` hi `hashWithSalt` lo+ {-# INLINE hashWithSalt #-}++ instance Show TraceId where showsPrec d i = showParen (d > 10) $ showString "TraceId " . showsPrec 11 (traceIdBaseEncodedText Base16 i) @@ -91,57 +114,37 @@ Right ok -> ok -instance Show SpanId where- showsPrec d i = showParen (d > 10) $ showString "SpanId " . showsPrec 11 (spanIdBaseEncodedText Base16 i)-+{- | All-zero 'TraceId'. -instance IsString SpanId where- fromString str = case baseEncodedToSpanId Base16 (fromString str) of- Left err -> error err- Right ok -> ok+@since 0.0.1.0+-}+nilTraceId :: TraceId+nilTraceId = TraceId 0 0+{-# INLINE nilTraceId #-} -{- | Generate a 'TraceId' using the provided 'IdGenerator'-- This function is generally called by the @hs-opentelemetry-sdk@,- but may be useful in some testing situations.+{- | Generate a 'TraceId' using the provided 'IdGenerator'. @since 0.1.0.0 -} newTraceId :: (MonadIO m) => IdGenerator -> m TraceId-newTraceId gen = liftIO (TraceId . toShort <$> generateTraceIdBytes gen)+newTraceId DefaultIdGenerator = liftIO generateTraceId+newTraceId (CustomIdGenerator _ genTrace) = liftIO $ sbsToTraceId <$> genTrace+{-# INLINE newTraceId #-} -{- | Check whether all bytes in the 'TraceId' are zero.-- @since 0.1.0.0--}+-- | @since 0.1.0.0 isEmptyTraceId :: TraceId -> Bool-#if MIN_VERSION_base(4,17,0)-isEmptyTraceId (TraceId (SBS arr)) =- isTrue#- (eqWord#- (or#- (word64ToWord# (indexWord64Array# arr 0#))- (word64ToWord# (indexWord64Array# arr 1#)))- (int2Word# 0#))-#else-isEmptyTraceId (TraceId (SBS arr)) =- isTrue#- (eqWord#- (or#- (indexWord64Array# arr 0#)- (indexWord64Array# arr 1#))- (int2Word# 0#))-#endif+isEmptyTraceId (TraceId hi lo) = (hi .|. lo) == 0+{-# INLINE isEmptyTraceId #-} -{- | Access the byte-level representation of the provided 'TraceId'-- @since 0.1.0.0--}+-- | @since 0.1.0.0 traceIdBytes :: TraceId -> ByteString-traceIdBytes (TraceId bytes) = fromShort bytes+traceIdBytes (TraceId hi lo) =+ BI.unsafeCreate 16 $ \ptr -> do+ poke (castPtr ptr) hi+ poke (castPtr (ptr `plusPtr` 8)) lo {- | Convert a 'ByteString' to a 'TraceId'. Will fail if the 'ByteString'@@ -150,126 +153,290 @@ @since 0.1.0.0 -} bytesToTraceId :: ByteString -> Either String TraceId-bytesToTraceId bs =- if BS.length bs == 16- then Right $ TraceId $ toShort bs- else Left "bytesToTraceId: TraceId must be 16 bytes long"+bytesToTraceId bs+ | BS.length bs /= 16 = Left "bytesToTraceId: TraceId must be 16 bytes long"+ | otherwise = unsafeDupablePerformIO $+ BU.unsafeUseAsCString bs $ \src -> do+ let !p = castPtr src :: Ptr Word64+ !hi <- peekElemOff p 0+ !lo <- peekElemOff p 1+ pure $! Right $! TraceId hi lo -{- | Convert a 'ByteString' of a specified base-encoding into a 'TraceId'.- Will fail if the decoded value is not exactly 16 bytes long.+{- | Convert a hex-encoded 'ByteString' into a 'TraceId'. @since 0.1.0.0 -} baseEncodedToTraceId :: Base -> ByteString -> Either String TraceId-baseEncodedToTraceId b bs = do- r <- convertFromBase b bs- bytesToTraceId r+baseEncodedToTraceId Base16 bs+ | BS.length bs /= 32 = Left "baseEncodedToTraceId: expected 32 hex chars"+ | otherwise = unsafeDupablePerformIO $+ BU.unsafeUseAsCStringLen bs $ \(src, _) ->+ allocaBytes 16 $ \dst -> do+ rc <- c_decodeHex (castPtr src) dst 16+ if rc == 0+ then do+ let !p = castPtr dst :: Ptr Word64+ !hi <- peekElemOff p 0+ !lo <- peekElemOff p 1+ pure $! Right $! TraceId hi lo+ else pure $ Left "invalid hex character" -{- | Output a 'TraceId' into a base-encoded bytestring 'Builder'.-- @since 0.1.0.0--}+-- | @since 0.1.0.0 traceIdBaseEncodedBuilder :: Base -> TraceId -> Builder-traceIdBaseEncodedBuilder b = B.byteString . convertToBase b . traceIdBytes+traceIdBaseEncodedBuilder Base16 = B.byteString . traceIdBaseEncodedByteString Base16 -{- | Output a 'TraceId' into a base-encoded 'ByteString'.+{- | SIMD-accelerated hex encoding (SSSE3 on x86_64, NEON on aarch64). @since 0.1.0.0 -} traceIdBaseEncodedByteString :: Base -> TraceId -> ByteString-traceIdBaseEncodedByteString b = convertToBase b . traceIdBytes+traceIdBaseEncodedByteString Base16 (TraceId hi lo) =+ BI.unsafeCreate 32 $ \dst ->+ allocaBytes 16 $ \src -> do+ poke (castPtr src :: Ptr Word64) hi+ poke (castPtr (src `plusPtr` 8) :: Ptr Word64) lo+ c_encodeTraceId src dst -{- | Output a 'TraceId' into a base-encoded 'Text'.-- @since 0.1.0.0--}+-- | @since 0.1.0.0 traceIdBaseEncodedText :: Base -> TraceId -> Text traceIdBaseEncodedText b = decodeUtf8 . traceIdBaseEncodedByteString b -{- | Generate a 'SpanId' using the provided 'IdGenerator'+-- * SpanId - This function is generally called by the @hs-opentelemetry-sdk@,- but may be useful in some testing situations. - @since 0.1.0.0+{- | A valid span identifier is an 8-byte array with at least one non-zero byte.++Stored as a single machine-word @Word64@ in native byte order.++ @since 0.0.1.0 -}-newSpanId :: (MonadIO m) => IdGenerator -> m SpanId-newSpanId gen = liftIO (SpanId . toShort <$> generateSpanIdBytes gen)+data SpanId+ = SpanId+ {-# UNPACK #-} !Word64+ deriving stock (Eq, Ord, Generic) -{- | Check whether all bytes in the 'SpanId' are zero.+instance Hashable SpanId where+ hashWithSalt s (SpanId w) = hashWithSalt s w+ {-# INLINE hashWithSalt #-} - @since 0.1.0.0++instance Show SpanId where+ showsPrec d i = showParen (d > 10) $ showString "SpanId " . showsPrec 11 (spanIdBaseEncodedText Base16 i)+++instance IsString SpanId where+ fromString str = case baseEncodedToSpanId Base16 (fromString str) of+ Left err -> error err+ Right ok -> ok+++{- | All-zero 'SpanId'.++@since 0.0.1.0 -}-isEmptySpanId :: SpanId -> Bool-#if MIN_VERSION_base(4,17,0)-isEmptySpanId (SpanId (SBS arr)) = isTrue#- (eqWord#- (word64ToWord# (indexWord64Array# arr 0#))- (int2Word# 0#))-#else-isEmptySpanId (SpanId (SBS arr)) = isTrue#- (eqWord#- (indexWord64Array# arr 0#)- (int2Word# 0#))-#endif+nilSpanId :: SpanId+nilSpanId = SpanId 0+{-# INLINE nilSpanId #-} -{- | Access the byte-level representation of the provided 'SpanId'+{- | Generate a 'SpanId' using the provided 'IdGenerator'. @since 0.1.0.0 -}+newSpanId :: (MonadIO m) => IdGenerator -> m SpanId+newSpanId DefaultIdGenerator = liftIO generateSpanId+newSpanId (CustomIdGenerator genSpan _) = liftIO $ sbsToSpanId <$> genSpan+{-# INLINE newSpanId #-}+++{- | Generate both a TraceId and SpanId. For 'DefaultIdGenerator', this is a+single FFI call (3 xoshiro steps) instead of 3 separate calls. Used for+root spans where both IDs need generating.+-}+newTraceAndSpanId :: (MonadIO m) => IdGenerator -> m (TraceId, SpanId)+newTraceAndSpanId DefaultIdGenerator = liftIO generateTraceAndSpanId+newTraceAndSpanId gen = liftIO $ do+ !tid <- newTraceId gen+ !sid <- newSpanId gen+ pure (tid, sid)+{-# INLINE newTraceAndSpanId #-}+++-- | @since 0.1.0.0+isEmptySpanId :: SpanId -> Bool+isEmptySpanId (SpanId w) = w == 0+{-# INLINE isEmptySpanId #-}+++-- | @since 0.1.0.0 spanIdBytes :: SpanId -> ByteString-spanIdBytes (SpanId bytes) = fromShort bytes+spanIdBytes (SpanId w) =+ BI.unsafeCreate 8 $ \ptr -> poke (castPtr ptr) w -{- | Convert a 'ByteString' of a specified base-encoding into a 'SpanId'.- Will fail if the decoded value is not exactly 8 bytes long.+-- | @since 0.1.0.0+bytesToSpanId :: ByteString -> Either String SpanId+bytesToSpanId bs+ | BS.length bs /= 8 = Left "bytesToSpanId: SpanId must be 8 bytes long"+ | otherwise = unsafeDupablePerformIO $+ BU.unsafeUseAsCString bs $ \src -> do+ !w <- peek (castPtr src :: Ptr Word64)+ pure $! Right $! SpanId w - @since 0.1.0.0++-- | @since 0.1.0.0+baseEncodedToSpanId :: Base -> ByteString -> Either String SpanId+baseEncodedToSpanId Base16 bs+ | BS.length bs /= 16 = Left "baseEncodedToSpanId: expected 16 hex chars"+ | otherwise = unsafeDupablePerformIO $+ BU.unsafeUseAsCStringLen bs $ \(src, _) ->+ allocaBytes 8 $ \dst -> do+ rc <- c_decodeHex (castPtr src) dst 8+ if rc == 0+ then do+ !w <- peek (castPtr dst :: Ptr Word64)+ pure $! Right $! SpanId w+ else pure $ Left "invalid hex character"+++-- | @since 0.1.0.0+spanIdBaseEncodedBuilder :: Base -> SpanId -> Builder+spanIdBaseEncodedBuilder Base16 = B.byteString . spanIdBaseEncodedByteString Base16+++-- | @since 0.1.0.0+spanIdBaseEncodedByteString :: Base -> SpanId -> ByteString+spanIdBaseEncodedByteString Base16 (SpanId w) =+ BI.unsafeCreate 16 $ \dst ->+ allocaBytes 8 $ \src -> do+ poke (castPtr src :: Ptr Word64) w+ c_encodeSpanId src dst+++-- | @since 0.1.0.0+spanIdBaseEncodedText :: Base -> SpanId -> Text+spanIdBaseEncodedText b = decodeUtf8 . spanIdBaseEncodedByteString b+++-- * Generation: xoshiro256++ (DefaultIdGenerator)+++{- | Generate a 'TraceId' via thread-local xoshiro256++.+Two FFI calls returning Word64 directly. No buffer, no ByteArray#. -}-bytesToSpanId :: ByteString -> Either String SpanId-bytesToSpanId bs =- if BS.length bs == 8- then Right $ SpanId $ toShort bs- else Left "bytesToSpanId: SpanId must be 8 bytes long"+generateTraceId :: IO TraceId+generateTraceId = do+ !hi <- c_xoshiroNext+ !lo <- c_xoshiroNext+ pure $! TraceId hi lo+{-# INLINE generateTraceId #-} -{- | Convert a 'ByteString' of a specified base-encoding into a 'SpanId'.- Will fail if the decoded value is not exactly 8 bytes long.+-- | Generate a 'SpanId' via thread-local xoshiro256++.+generateSpanId :: IO SpanId+generateSpanId = do+ !w <- c_xoshiroNext+ pure $! SpanId w+{-# INLINE generateSpanId #-} - @since 0.1.0.0++{- | Generate a TraceId + SpanId for root spans.++Three sequential @unsafe@ FFI calls to xoshiro256++ (~9 ns total).+A Cmm primop returning an unboxed triple via Sp-allocated out-pointers+was benchmarked at the same cost (~9.7 ns) because the per-call FFI+overhead (~3 ns) is already lower than the Cmm stack manipulation. -}-baseEncodedToSpanId :: Base -> ByteString -> Either String SpanId-baseEncodedToSpanId b bs = do- r <- convertFromBase b bs- bytesToSpanId r+generateTraceAndSpanId :: IO (TraceId, SpanId)+generateTraceAndSpanId = do+ !hi <- c_xoshiroNext+ !lo <- c_xoshiroNext+ !sid <- c_xoshiroNext+ pure (TraceId hi lo, SpanId sid)+{-# INLINE generateTraceAndSpanId #-} -{- | Output a 'SpanId' into a base-encoded bytestring 'Builder'.+-- * CustomIdGenerator SBS -> Word64 conversion - @since 0.1.0.0++sbsToTraceId :: ShortByteString -> TraceId+sbsToTraceId sbs =+ let !bs = fromShort sbs+ in case bytesToTraceId bs of+ Right tid -> tid+ Left _ -> nilTraceId+++sbsToSpanId :: ShortByteString -> SpanId+sbsToSpanId sbs =+ let !bs = fromShort sbs+ in case bytesToSpanId bs of+ Right sid -> sid+ Left _ -> nilSpanId+++{- | Base encoding scheme. Only 'Base16' (hexadecimal) is supported.++@since 0.0.1.0 -}-spanIdBaseEncodedBuilder :: Base -> SpanId -> Builder-spanIdBaseEncodedBuilder b = B.byteString . convertToBase b . spanIdBytes+data Base = Base16+ deriving (Show, Eq) -{- | Output a 'SpanId' into a base-encoded 'ByteString'.+-- * Traceparent codec (C FFI) - @since 0.1.0.0++foreign import ccall unsafe "hs_otel_parse_traceparent"+ c_parseTraceparent :: Ptr Word8 -> CSize -> Ptr Word64 -> IO CInt+++foreign import ccall unsafe "hs_otel_encode_traceparent"+ c_encodeTraceparent+ :: Word64+ -> Word64+ -> Word64+ -> Word8+ -> Word8+ -> Ptr Word8+ -> IO ()+++{- | Parse a W3C traceparent header in a single SIMD-accelerated C call.++ Returns the version, trace ID, span ID, and flags byte, or 'Nothing'+ on any format error (bad hex, wrong length, missing dashes, all-zero IDs).++ @since 0.4.0.0 -}-spanIdBaseEncodedByteString :: Base -> SpanId -> ByteString-spanIdBaseEncodedByteString b = convertToBase b . spanIdBytes+decodeTraceparent :: ByteString -> Maybe (Word8, TraceId, SpanId, Word8)+decodeTraceparent bs = unsafeDupablePerformIO $+ BU.unsafeUseAsCStringLen bs $ \(src, len) ->+ allocaBytes 32 $ \buf -> do+ let !p = castPtr buf :: Ptr Word64+ rc <- c_parseTraceparent (castPtr src) (fromIntegral len) p+ if rc == 0+ then do+ !hi <- peekElemOff p 0+ !lo <- peekElemOff p 1+ !sid <- peekElemOff p 2+ !meta <- peekElemOff p 3+ let !ver = fromIntegral (meta `shiftR` 8) :: Word8+ !fl = fromIntegral (meta .&. 0xFF) :: Word8+ pure $! Just (ver, TraceId hi lo, SpanId sid, fl)+ else pure Nothing -{- | Output a 'SpanId' into a base-encoded 'Text'.+{- | Encode a traceparent header (55 bytes) in a single SIMD-accelerated C call. - @since 0.1.0.0+ @since 0.4.0.0 -}-spanIdBaseEncodedText :: Base -> SpanId -> Text-spanIdBaseEncodedText b = decodeUtf8 . spanIdBaseEncodedByteString b+encodeTraceparent :: Word8 -> TraceId -> SpanId -> Word8 -> ByteString+encodeTraceparent ver (TraceId hi lo) (SpanId sid) fl =+ BI.unsafeCreate 55 $ \dst ->+ c_encodeTraceparent hi lo sid ver fl dst
src/OpenTelemetry/Internal/Trace/Types.hs view
@@ -5,23 +5,27 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StrictData #-} +{- |+Module : OpenTelemetry.Internal.Trace.Types+Description : Internal type definitions for the Traces signal: Span, ImmutableSpan, SpanContext, SpanArguments, TracerProvider, Tracer.+Stability : experimental+-} module OpenTelemetry.Internal.Trace.Types where -import Control.Concurrent.Async (Async)+import Control.Exception (SomeException) import Control.Monad.IO.Class import Data.Bits import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as H-import Data.IORef (IORef, readIORef)+import Data.IORef (IORef) import Data.Text (Text) import Data.Vector (Vector)-import Data.Word (Word8)-import Network.HTTP.Types (RequestHeaders)+import Data.Word (Word64, Word8) import OpenTelemetry.Attributes import OpenTelemetry.Common import OpenTelemetry.Context.Types import OpenTelemetry.Internal.Common.Types-import OpenTelemetry.Propagator (Propagator)+import OpenTelemetry.Propagator (TextMapPropagator) import OpenTelemetry.Resource import OpenTelemetry.Trace.Id import OpenTelemetry.Trace.Id.Generator@@ -29,75 +33,221 @@ import OpenTelemetry.Util +{- | How an exception should be treated by the tracing system when caught+by 'inSpan' and similar bracket-style functions.++@since 0.4.0.0+-}+data ExceptionClassification+ = {- | Set span status to 'Error', record an exception event. This is the+ default behavior for all exceptions.+ -}+ ErrorException+ | {- | Record an exception event on the span, but do not set the span status+ to 'Error'. Useful for exceptions that represent expected control flow+ (e.g. a cache miss exception) that you still want visibility into.+ -}+ RecordedException+ | {- | Do not record an exception event and do not set the span status to+ 'Error'. The exception is completely invisible to the tracing system.+ Useful for 'System.Exit.ExitSuccess', 'Control.Exception.AsyncCancelled',+ and similar non-error exceptions.+ -}+ IgnoredException+ deriving (Show, Eq, Ord)+++{- | The result of classifying an exception via an 'ExceptionHandler'.++@since 0.4.0.0+-}+data ExceptionResponse = ExceptionResponse+ { exceptionClassification :: !ExceptionClassification+ , exceptionAdditionalAttributes :: !AttributeMap+ {- ^ Extra attributes to add to the exception event (when classification is+ 'ErrorException' or 'RecordedException') or directly to the span.+ -}+ }+++{- | A function that inspects a 'SomeException' and optionally classifies it.++Returns 'Nothing' to indicate this handler does not recognize the exception,+deferring to the next handler in the chain. Returns @'Just' 'ExceptionResponse'@+to provide a classification and optional extra attributes.++Multiple handlers are chained: tracer-level handlers are consulted first,+then provider-level handlers. The first @Just@ result wins. If all handlers+return 'Nothing', the default behavior ('ErrorException' with no extra+attributes) applies.++@since 0.4.0.0+-}+type ExceptionHandler = SomeException -> Maybe ExceptionResponse+++{- | The default response when no handler matches: classify as 'ErrorException'+with no additional attributes.++@since 0.4.0.0+-}+defaultExceptionResponse :: ExceptionResponse+defaultExceptionResponse = ExceptionResponse ErrorException H.empty+++{- | Exports completed spans to a telemetry backend.++Spec: <https://opentelemetry.io/docs/specs/otel/trace/sdk/#span-exporter>++@since 0.0.1.0+-} data SpanExporter = SpanExporter { spanExporterExport :: HashMap InstrumentationLibrary (Vector ImmutableSpan) -> IO ExportResult- , spanExporterShutdown :: IO ()+ , spanExporterShutdown :: IO ShutdownResult+ , spanExporterForceFlush :: IO FlushResult } +{- | Span processors receive callbacks on span start and end.++Spec: <https://opentelemetry.io/docs/specs/otel/trace/sdk/#span-processor>++@since 0.0.1.0+-} data SpanProcessor = SpanProcessor- { spanProcessorOnStart :: IORef ImmutableSpan -> Context -> IO ()- -- ^ Called when a span is started. This method is called synchronously on the thread that started the span, therefore it should not block or throw exceptions.- , spanProcessorOnEnd :: IORef ImmutableSpan -> IO ()- -- ^ Called after a span is ended (i.e., the end timestamp is already set). This method is called synchronously within the 'OpenTelemetry.Trace.endSpan' API, therefore it should not block or throw an exception.- , spanProcessorShutdown :: IO (Async ShutdownResult)- -- ^ Shuts down the processor. Called when SDK is shut down. This is an opportunity for processor to do any cleanup required.- --- -- Shutdown SHOULD be called only once for each SpanProcessor instance. After the call to Shutdown, subsequent calls to OnStart, OnEnd, or ForceFlush are not allowed. SDKs SHOULD ignore these calls gracefully, if possible.- --- -- Shutdown SHOULD let the caller know whether it succeeded, failed or timed out.- --- -- Shutdown MUST include the effects of ForceFlush.- --- -- Shutdown SHOULD complete or abort within some timeout. Shutdown can be implemented as a blocking API or an asynchronous API which notifies the caller via a callback or an event. OpenTelemetry client authors can decide if they want to make the shutdown timeout configurable.- , spanProcessorForceFlush :: IO ()- -- ^ This is a hint to ensure that any tasks associated with Spans for which the SpanProcessor had already received events prior to the call to ForceFlush SHOULD be completed as soon as possible, preferably before returning from this method.- --- -- In particular, if any Processor has any associated exporter, it SHOULD try to call the exporter's Export with all spans for which this was not already done and then invoke ForceFlush on it. The built-in SpanProcessors MUST do so. If a timeout is specified (see below), the SpanProcessor MUST prioritize honoring the timeout over finishing all calls. It MAY skip or abort some or all Export or ForceFlush calls it has made to achieve this goal.- --- -- ForceFlush SHOULD provide a way to let the caller know whether it succeeded, failed or timed out.- --- -- ForceFlush SHOULD only be called in cases where it is absolutely necessary, such as when using some FaaS providers that may suspend the process after an invocation, but before the SpanProcessor exports the completed spans.- --- -- ForceFlush SHOULD complete or abort within some timeout. ForceFlush can be implemented as a blocking API or an asynchronous API which notifies the caller via a callback or an event. OpenTelemetry client authors can decide if they want to make the flush timeout configurable.+ { spanProcessorOnStart :: ImmutableSpan -> Context -> IO ()+ -- ^ Called when a span is started with a snapshot of the initial span state.+ , spanProcessorOnEnd :: ImmutableSpan -> IO ()+ -- ^ Called after a span is ended with the final frozen span state.+ , spanProcessorShutdown :: IO ShutdownResult+ {- ^ Shuts down the processor. Called when SDK is shut down. This is an opportunity for processor to do any cleanup required.++ Shutdown SHOULD be called only once for each SpanProcessor instance. After the call to Shutdown, subsequent calls to OnStart, OnEnd, or ForceFlush are not allowed. SDKs SHOULD ignore these calls gracefully, if possible.++ Shutdown SHOULD let the caller know whether it succeeded, failed or timed out.++ Shutdown MUST include the effects of ForceFlush.++ Shutdown SHOULD complete or abort within some timeout. Shutdown can be implemented as a blocking API or an asynchronous API which notifies the caller via a callback or an event. OpenTelemetry client authors can decide if they want to make the shutdown timeout configurable.+ -}+ , spanProcessorForceFlush :: IO FlushResult+ {- ^ This is a hint to ensure that any tasks associated with Spans for which the SpanProcessor had already received events prior to the call to ForceFlush SHOULD be completed as soon as possible, preferably before returning from this method.++ In particular, if any Processor has any associated exporter, it SHOULD try to call the exporter's Export with all spans for which this was not already done and then invoke ForceFlush on it. The built-in SpanProcessors MUST do so. If a timeout is specified (see below), the SpanProcessor MUST prioritize honoring the timeout over finishing all calls. It MAY skip or abort some or all Export or ForceFlush calls it has made to achieve this goal.++ ForceFlush SHOULD provide a way to let the caller know whether it succeeded, failed or timed out.++ ForceFlush SHOULD only be called in cases where it is absolutely necessary, such as when using some FaaS providers that may suspend the process after an invocation, but before the SpanProcessor exports the completed spans.++ ForceFlush SHOULD complete or abort within some timeout. ForceFlush can be implemented as a blocking API or an asynchronous API which notifies the caller via a callback or an event. OpenTelemetry client authors can decide if they want to make the flush timeout configurable.+ -} } -{- |-'Tracer's can be created from a 'TracerProvider'.+{- | Factory for creating 'Tracer' instances. Holds configuration shared+across all tracers: processors, sampler, resource, limits, and propagators.++Spec: <https://opentelemetry.io/docs/specs/otel/trace/api/#tracerprovider>++@since 0.0.1.0 -} data TracerProvider = TracerProvider- { tracerProviderProcessors :: !(Vector SpanProcessor)+ { tracerProviderOnStart :: !(ImmutableSpan -> Context -> IO ())+ {- ^ Pre-composed span-start callback. Built from the processor list at+ construction time so the hot path does one indirect call, no vector.+ -}+ , tracerProviderOnEnd :: !(ImmutableSpan -> IO ())+ -- ^ Pre-composed span-end callback (same idea).+ , tracerProviderProcessors :: !(Vector SpanProcessor)+ -- ^ Raw processor vector, used only for shutdown\/flush (cold path).+ , tracerProviderHasProcessor :: !Bool+ {- ^ 'True' when at least one processor was registered. Used for the+ fast-path Dropped check without touching the vector.+ -} , tracerProviderIdGenerator :: !IdGenerator , tracerProviderSampler :: !Sampler , tracerProviderResources :: !MaterializedResources , tracerProviderAttributeLimits :: !AttributeLimits , tracerProviderSpanLimits :: !SpanLimits- , tracerProviderPropagators :: !(Propagator Context RequestHeaders RequestHeaders)+ , tracerProviderPropagators :: !TextMapPropagator+ , tracerProviderExceptionHandlers :: ![ExceptionHandler]+ {- ^ Ordered list of exception handlers consulted when 'inSpan' catches an+ exception. These are checked after any tracer-level handlers.+ -}+ , tracerProviderIsShutdown :: !(IORef Bool)+ {- ^ Set to 'True' after 'shutdownTracerProvider'. Spec: after shutdown,+ subsequent 'createSpan' calls SHOULD return non-recording spans.+ -}+ , tracerProviderTracerCache :: !(IORef (HashMap InstrumentationLibrary Tracer))+ {- ^ Spec SHOULD: return the same Tracer instance for a given+ InstrumentationScope (name+version+schema+attributes).+ -} } -{- | The 'Tracer' is responsible for creating 'Span's.+{- | Creates and manages 'Span's for a specific instrumentation scope. - Each 'Tracer' should be associated with the library or application that- it instruments.+Spec: <https://opentelemetry.io/docs/specs/otel/trace/api/#tracer>++@since 0.0.1.0 -} data Tracer = Tracer { tracerName :: {-# UNPACK #-} !InstrumentationLibrary- -- ^ Get the name of the 'Tracer'- --- -- @since 0.0.10+ {- ^ Get the name of the 'Tracer'++ @since 0.0.10+ -} , tracerProvider :: !TracerProvider- -- ^ Get the TracerProvider from which the 'Tracer' was created- --- -- @since 0.0.10+ {- ^ Get the TracerProvider from which the 'Tracer' was created++ @since 0.0.10+ -}+ , tracerExceptionHandlers :: ![ExceptionHandler]+ {- ^ Tracer-level exception handlers, consulted before provider-level handlers.++ @since 0.4.0.0+ -}+ , tracerSpanAttributeLimits :: !AttributeLimits+ {- ^ Pre-resolved attribute limits for span attributes, avoiding repeated+ pointer chasing through TracerProvider on every addAttribute call.+ -}+ , tracerEventAttributeLimits :: !AttributeLimits+ -- ^ Pre-resolved attribute limits for event attributes.+ , tracerLinkAttributeLimits :: !AttributeLimits+ -- ^ Pre-resolved attribute limits for link attributes.+ , tracerEventCountLimit :: {-# UNPACK #-} !Int+ -- ^ Pre-resolved max event count per span (default 128).+ , tracerLinkCountLimit :: {-# UNPACK #-} !Int+ -- ^ Pre-resolved max link count per span (default 128). } +-- \^ Get the TracerProvider from which the 'Tracer' was created+--+-- @since 0.0.10+--+ instance Show Tracer where showsPrec d Tracer {tracerName = name} = showParen (d > 10) $ showString "Tracer {tracerName = " . shows name . showString "}" +{- | Resolve exception classification by consulting tracer-level handlers first,+then provider-level handlers. Returns 'defaultExceptionResponse' if no handler+matches.++@since 0.4.0.0+-}+resolveException :: Tracer -> SomeException -> ExceptionResponse+resolveException t ex =+ let allHandlers = tracerExceptionHandlers t <> tracerProviderExceptionHandlers (tracerProvider t)+ in go allHandlers+ where+ go [] = defaultExceptionResponse+ go (h : hs) = case h ex of+ Just resp -> resp+ Nothing -> go hs++ {- | This is a link that is being added to a span which is going to be created. @@ -118,6 +268,8 @@ It is recommended, however, to not set parent of the Span in this scenario as semantically the parent field represents a single parent scenario, in many cases the parent Span fully encloses the child Span. This is not the case in scatter/gather and batch scenarios.++@since 0.0.1.0 -} data NewLink = NewLink { linkContext :: !SpanContext@@ -128,26 +280,11 @@ deriving (Show) -{- |-This is an immutable link for an existing span.--A @Span@ may be linked to zero or more other @Spans@ (defined by @SpanContext@) that are causally related.-@Link@s can point to Spans inside a single Trace or across different Traces. @Link@s can be used to represent-batched operations where a @Span@ was initiated by multiple initiating Spans, each representing a single incoming-item being processed in the batch.--Another example of using a Link is to declare the relationship between the originating and following trace.-This can be used when a Trace enters trusted boundaries of a service and service policy requires the generation-of a new Trace rather than trusting the incoming Trace context. The new linked Trace may also represent a long-running asynchronous data processing operation that was initiated by one of many fast incoming requests.+{- | Frozen (immutable) version of 'NewLink', stored on completed spans.+Created internally by freezing a 'NewLink'; attributes are truncated per the+configured limits. See 'NewLink' for full documentation on link semantics. -When using the scatter/gather (also called fork/join) pattern, the root operation starts multiple downstream-processing operations and all of them are aggregated back in a single Span.-This last Span is linked to many operations it aggregates.-All of them are the Spans from the same Trace. And similar to the Parent field of a Span.-It is recommended, however, to not set parent of the Span in this scenario as semantically the parent field-represents a single parent scenario, in many cases the parent Span fully encloses the child Span.-This is not the case in scatter/gather and batch scenarios.+@since 0.0.1.0 -} data Link = Link { frozenLinkContext :: !SpanContext@@ -158,16 +295,26 @@ deriving (Show) --- | Non-name fields that may be set on initial creation of a 'Span'.+{- | Non-name fields that may be set on initial creation of a 'Span'.++@since 0.0.1.0+-} data SpanArguments = SpanArguments { kind :: SpanKind- -- ^ The kind of the span. See 'SpanKind's documentation for the semantics- -- of the various values that may be specified.+ {- ^ The kind of the span. See 'SpanKind's documentation for the semantics+ of the various values that may be specified.+ -} , attributes :: AttributeMap- -- ^ An initial set of attributes that may be set on initial 'Span' creation.- -- These attributes are provided to 'Processor's, so they may be useful in some- -- scenarios where calling `addAttribute` or `addAttributes` is too late.- , links :: [NewLink]+ {- ^ An initial set of attributes set at 'Span' creation time. Adding+ attributes at span creation is preferred to calling 'addAttribute' later,+ because samplers can only consider information already present during+ span creation.+ -}+ , -- \^ An initial set of attributes that may be set on initial 'Span' creation.+ -- These attributes are provided to 'Processor's, so they may be useful in some+ -- scenarios where calling `addAttribute` or `addAttributes` is too late.+ --+ links :: [NewLink] -- ^ A collection of `Link`s that point to causally related 'Span's. , startTime :: Maybe Timestamp -- ^ An explicit start time, if the span has already begun.@@ -198,32 +345,46 @@ +-------------+--------------+---------------+------------------+------------------+ | `Internal` | | | | | +-------------+--------------+---------------+------------------+------------------+++@since 0.0.1.0 -} data SpanKind- = -- | Indicates that the span covers server-side handling of a synchronous RPC or other remote request.- -- This span is the child of a remote @Client@ span that was expected to wait for a response.+ = {- | Indicates that the span covers server-side handling of a synchronous RPC or other remote request.+ This span is the child of a remote @Client@ span that was expected to wait for a response.+ -} Server- | -- | Indicates that the span describes a synchronous request to some remote service.- -- This span is the parent of a remote @Server@ span and waits for its response.+ | {- | Indicates that the span describes a synchronous request to some remote service.+ This span is the parent of a remote @Server@ span and waits for its response.+ -} Client- | -- | Indicates that the span describes the parent of an asynchronous request.- -- This parent span is expected to end before the corresponding child @Producer@ span,- -- possibly even before the child span starts. In messaging scenarios with batching,- -- tracing individual messages requires a new @Producer@ span per message to be created.+ | {- | Indicates that the span describes the parent of an asynchronous request.+ This parent span is expected to end before the corresponding child @Producer@ span,+ possibly even before the child span starts. In messaging scenarios with batching,+ tracing individual messages requires a new @Producer@ span per message to be created.+ -} Producer | -- | Indicates that the span describes the child of an asynchronous @Producer@ request. Consumer- | -- | Default value. Indicates that the span represents an internal operation within an application,- -- as opposed to an operations with remote parents or children.+ | {- | Default value. Indicates that the span represents an internal operation within an application,+ as opposed to an operations with remote parents or children.+ -} Internal- deriving (Show)+ deriving (Show, Eq) -{- | The status of a @Span@. This may be used to indicate the successful completion of a span.+{- | The status of a @Span@. This may be used to indicate the successful+completion of a span. - The default is @Unset@+The default is @Unset@. - These values form a total order: Ok > Error > Unset. This means that setting Status with StatusCode=Ok will override any prior or future attempts to set span Status with StatusCode=Error or StatusCode=Unset.+@Ok@ is /final/: once a span's status is @Ok@, subsequent 'setStatus' calls+are ignored. @Error@ can be set from @Unset@, and @Ok@ can override @Error@+(or @Unset@). Transitions: @Unset -> Error@, @Unset -> Ok@, @Error -> Ok@.++An @Ord@ instance is provided (Ok > Error > Unset) for convenience but+does /not/ govern status-setting precedence.++@since 0.0.1.0 -} data SpanStatus = -- | The default status.@@ -235,113 +396,198 @@ deriving (Show, Eq) +{- | Ok > Error > Unset. This ordering is for sorting\/display; status-setting+precedence is handled by 'mergeStatus' in "OpenTelemetry.Trace.Core".+-} instance Ord SpanStatus where compare Unset Unset = EQ compare Unset (Error _) = LT compare Unset Ok = LT compare (Error _) Unset = GT- compare (Error _) (Error _) = GT -- This is a weird one, but last writer wins for errors+ compare (Error _) (Error _) = EQ compare (Error _) Ok = LT compare Ok Unset = GT compare Ok (Error _) = GT compare Ok Ok = EQ -{- | The frozen representation of a 'Span' that originates from the currently running process.+{- | Mutable fields of a span, stored behind an 'IORef' and updated via CAS.+Only ~48 bytes, so each CAS allocates much less than copying the full span. - Only 'Processor's and 'Exporter's should use rely on this interface.+@since 0.0.1.0 -}-data ImmutableSpan = ImmutableSpan- { spanName :: Text- -- ^ A name identifying the role of the span (like function or method name).- , spanParent :: Maybe Span- , spanContext :: SpanContext- -- ^ A `SpanContext` represents the portion of a `Span` which must be serialized and- -- propagated along side of a distributed context. `SpanContext`s are immutable.- , spanKind :: SpanKind- -- ^ The kind of the span. See 'SpanKind's documentation for the semantics- -- of the various values that may be specified.- , spanStart :: Timestamp- -- ^ A timestamp that corresponds to the start of the span- , spanEnd :: Maybe Timestamp- -- ^ A timestamp that corresponds to the end of the span, if the span has ended.- , spanAttributes :: Attributes- , spanLinks :: AppendOnlyBoundedCollection Link- -- ^ Zero or more links to related spans. Links can be useful for connecting causal relationships between things like web requests that enqueue asynchronous tasks to be processed.- , spanEvents :: AppendOnlyBoundedCollection Event- -- ^ Events, which denote a point in time occurrence. These can be useful for recording data about a span such as when an exception was thrown, or to emit structured logs into the span tree.- , spanStatus :: SpanStatus- , spanTracer :: Tracer- -- ^ Creator of the span+data SpanHot = SpanHot+ { hotName :: !Text+ , hotEnd :: !OptionalTimestamp+ , hotAttributes :: !Attributes+ , hotLinks :: !(AppendOnlyBoundedCollection Link)+ , hotEvents :: !(AppendOnlyBoundedCollection Event)+ , hotStatus :: !SpanStatus } deriving (Show) -{- | A 'Span' is the fundamental type you'll work with to trace your systems.+{- | The representation of a 'Span' for processors and exporters. - A span is a single piece of instrumentation from a single location in your code or infrastructure. A span represents a single "unit of work" done by a service. Each span contains several key pieces of data:+Cold (immutable) fields live directly in the record and are never copied.+Hot (mutable) fields sit behind an 'IORef' so that CAS operations only+allocate a fresh 'SpanHot' instead of the entire span. - - A service name identifying the service the span is from- - A name identifying the role of the span (like function or method name)- - A timestamp that corresponds to the start of the span- - A duration that describes how long that unit of work took to complete- - An ID that uniquely identifies the span- - A trace ID identifying which trace the span belongs to- - A parent ID representing the parent span that called this span. (There is no parent ID for the root span of a given trace, which denotes that it's the start of the trace.)- - Any additional metadata that might be helpful.- - Zero or more links to related spans. Links can be useful for connecting causal relationships between things like web requests that enqueue asynchronous tasks to be processed.- - Events, which denote a point in time occurrence. These can be useful for recording data about a span such as when an exception was thrown, or to emit structured logs into the span tree.+@since 0.0.1.0+-}+data ImmutableSpan = ImmutableSpan+ { spanContext :: !SpanContext+ {- ^ A @SpanContext@ represents the portion of a @Span@ which must be serialized and+ propagated along side of a distributed context. @SpanContext@s are immutable.+ -}+ , spanKind :: !SpanKind+ -- ^ The kind of the span.+ , spanStart :: !Timestamp+ -- ^ Timestamp corresponding to the start of the span.+ , spanParent :: !(Maybe Span)+ , spanTracer :: !Tracer+ -- ^ Creator of the span.+ , spanHot :: {-# UNPACK #-} !(IORef SpanHot)+ {- ^ Mutable span fields (name, end time, attributes, links, events, status).+ Updated via CAS during the span's lifetime.+ -}+ } - A trace is made up of multiple spans. Tracing vendors such as Zipkin, Jaeger, Honeycomb, Datadog, Lightstep, etc. use the metadata from each span to reconstruct the relationships between them and generate a trace diagram.++-- \^ A `SpanContext` represents the portion of a `Span` which must be serialized and+-- propagated along side of a distributed context. `SpanContext`s are immutable.+--+-- \^ The kind of the span. See 'SpanKind's documentation for the semantics+-- of the various values that may be specified.+--++instance Show ImmutableSpan where+ showsPrec d imm =+ showParen (d > 10) $+ showString "ImmutableSpan {spanContext = "+ . showsPrec 11 (spanContext imm)+ . showString ", spanKind = "+ . showsPrec 11 (spanKind imm)+ . showString ", spanStart = "+ . showsPrec 11 (spanStart imm)+ . showString ", spanHot = <IORef>}"+++{- | A single unit of work in a distributed trace.++A span carries a name, timestamps, attributes, events, links, and a+'SpanContext' (trace ID + span ID). The three constructors represent:++ * 'Span': a live, recording span created by this process.+ * 'FrozenSpan': a non-recording wrapper around a remote 'SpanContext',+ used as a parent when continuing a trace from another process.+ * 'Dropped': a span that was not sampled. Carries enough context+ (trace ID, span ID) for propagation but records nothing.++Spec: <https://opentelemetry.io/docs/specs/otel/trace/api/#span>++@since 0.0.1.0 -} data Span- = Span (IORef ImmutableSpan)- | FrozenSpan SpanContext- | Dropped SpanContext+ = Span !ImmutableSpan+ | FrozenSpan !SpanContext+ | Dropped !SpanContext instance Show Span where- showsPrec d (Span _ioref) = showParen (d > 10) $ showString "Span _ioref"+ showsPrec d (Span imm) = showParen (d > 10) $ showString "Span " . showsPrec 11 imm showsPrec d (FrozenSpan ctx) = showParen (d > 10) $ showString "FrozenSpan " . showsPrec 11 ctx showsPrec d (Dropped ctx) = showParen (d > 10) $ showString "Dropped " . showsPrec 11 ctx +-- | @since 0.0.1.0 data FrozenOrDropped = SpanFrozen | SpanDropped deriving (Show, Eq) --- | Extracts the values from a @Span@ if it is still mutable. Returns a @Left@ with @FrozenOrDropped@ if the @Span@ is frozen or dropped.+{- | Extracts the values from a @Span@ if it is still mutable. Returns a @Left@ with @FrozenOrDropped@ if the @Span@ is frozen or dropped.++@since 0.0.1.0+-} toImmutableSpan :: MonadIO m => Span -> m (Either FrozenOrDropped ImmutableSpan)-toImmutableSpan s = case s of- Span ioref -> Right <$> liftIO (readIORef ioref)- FrozenSpan _ctx -> pure $ Left SpanFrozen- Dropped _ctx -> pure $ Left SpanDropped+toImmutableSpan (Span imm) = pure (Right imm)+toImmutableSpan (FrozenSpan _ctx) = pure $ Left SpanFrozen+toImmutableSpan (Dropped _ctx) = pure $ Left SpanDropped+{-# INLINE toImmutableSpan #-} {- | TraceFlags with the @sampled@ flag not set. This means that it is up to the sampling configuration to decide whether or not to sample the trace.++@since 0.0.1.0 -} defaultTraceFlags :: TraceFlags defaultTraceFlags = TraceFlags 0+{-# INLINE defaultTraceFlags #-} --- | Will the trace associated with this @TraceFlags@ value be sampled?+{- | Will the trace associated with this @TraceFlags@ value be sampled?++@since 0.0.1.0+-} isSampled :: TraceFlags -> Bool isSampled (TraceFlags flags) = flags `testBit` 0+{-# INLINE isSampled #-} --- | Set the @sampled@ flag on the @TraceFlags@+{- | Set the @sampled@ flag on the @TraceFlags@++@since 0.0.1.0+-} setSampled :: TraceFlags -> TraceFlags setSampled (TraceFlags flags) = TraceFlags (flags `setBit` 0)+{-# INLINE setSampled #-} {- | Unset the @sampled@ flag on the @TraceFlags@. This means that the application may choose whether or not to emit this Trace.++@since 0.0.1.0 -} unsetSampled :: TraceFlags -> TraceFlags unsetSampled (TraceFlags flags) = TraceFlags (flags `clearBit` 0) --- | Get the current bitmask for the @TraceFlags@, useful for serialization purposes.+{- | Test the W3C Level 2 @random@ flag (bit 1). When set, the trace-id+has sufficient randomness for probabilistic sampling decisions.++See <https://www.w3.org/TR/trace-context-2/#random-trace-id-flag>.++@since 0.4.0.0+-}+isRandom :: TraceFlags -> Bool+isRandom (TraceFlags flags) = flags `testBit` 1+{-# INLINE isRandom #-}+++{- | Set the W3C Level 2 @random@ flag (bit 1) on the @TraceFlags@.+Indicates that the trace-id was generated with a CSPRNG or equivalent+and has sufficient randomness for probabilistic sampling.++@since 0.4.0.0+-}+setRandom :: TraceFlags -> TraceFlags+setRandom (TraceFlags flags) = TraceFlags (flags `setBit` 1)+{-# INLINE setRandom #-}+++{- | Unset the W3C Level 2 @random@ flag (bit 1).++@since 0.4.0.0+-}+unsetRandom :: TraceFlags -> TraceFlags+unsetRandom (TraceFlags flags) = TraceFlags (flags `clearBit` 1)+{-# INLINE unsetRandom #-}+++{- | Get the current bitmask for the @TraceFlags@, useful for serialization purposes.++@since 0.0.1.0+-} traceFlagsValue :: TraceFlags -> Word8 traceFlagsValue (TraceFlags flags) = flags @@ -349,13 +595,20 @@ {- | Create a @TraceFlags@, from an arbitrary @Word8@. Note that for backwards-compatibility reasons, no checking is performed to determine whether the @TraceFlags@ bitmask provided is valid.++@since 0.0.1.0 -} traceFlagsFromWord8 :: Word8 -> TraceFlags traceFlagsFromWord8 = TraceFlags -{- | A `SpanContext` represents the portion of a `Span` which must be serialized and- propagated along side of a distributed context. `SpanContext`s are immutable.+{- | The serializable portion of a 'Span': trace ID, span ID, trace flags,+and trace state. Immutable once created.++Spec: <https://opentelemetry.io/docs/specs/otel/trace/api/#spancontext>+W3C: <https://www.w3.org/TR/trace-context/>++@since 0.0.1.0 -} -- The OpenTelemetry `SpanContext` representation conforms to the [W3C TraceContext@@ -382,17 +635,16 @@ -- create a `SpanContext`. This functionality MUST be fully implemented in the API, and SHOULD NOT be -- overridable. data SpanContext = SpanContext- { traceFlags :: TraceFlags- , isRemote :: Bool- , traceId :: TraceId- , spanId :: SpanId- , traceState :: TraceState -- TODO have to move TraceState impl from W3CTraceContext to here- -- list of up to 32, remove rightmost if exceeded- -- see w3c trace-context spec+ { traceFlags :: {-# UNPACK #-} !TraceFlags+ , isRemote :: !Bool+ , traceId :: {-# UNPACK #-} !TraceId+ , spanId :: {-# UNPACK #-} !SpanId+ , traceState :: !TraceState } deriving (Show, Eq) +-- | @since 0.0.1.0 newtype NonRecordingSpan = NonRecordingSpan SpanContext @@ -411,15 +663,18 @@ , newEventAttributes :: AttributeMap -- ^ Additional context or metadata related to the event, (stack traces, callsites, etc.). , newEventTimestamp :: Maybe Timestamp- -- ^ The time that the event occurred.- --- -- If not specified, 'OpenTelemetry.Trace.getTimestamp' will be used to get a timestamp.+ {- ^ The time that the event occurred.++ If not specified, 'OpenTelemetry.Trace.getTimestamp' will be used to get a timestamp.+ -} } {- | A “log” that happens as part of a span. An operation that is too fast for its own span, but too unique to roll up into its parent span. Events contain a name, a timestamp, and an optional set of Attributes, along with a timestamp. Events represent an event that occurred at a specific time within a span’s workload.++ @since 0.0.1.0 -} data Event = Event { eventName :: Text@@ -432,16 +687,22 @@ deriving (Show) --- | Utility class to format arbitrary values to events.+{- | Utility class to format arbitrary values to events.++@since 0.0.1.0+-} class ToEvent a where- -- | Convert a value to an 'Event'- --- -- @since 0.0.1.0+ {- | Convert a value to an 'Event'++ @since 0.0.1.0+ -} toEvent :: a -> Event -{- | The outcome of a call to 'Sampler' indicating+{- | The outcome of a call to 'shouldSample' indicating whether the 'Tracer' should sample a 'Span'.++@since 0.0.1.0 -} data SamplingResult = -- | isRecording == false. Span will not be recorded and all events and attributes will be dropped.@@ -453,16 +714,76 @@ deriving (Show, Eq) -{- | Interface that allows users to create custom samplers which will return a sampling SamplingResult based on information that- is typically available just before the Span was created.+{- | The result of sampling, with strict fields for unboxing.+Replaces the @(SamplingResult, AttributeMap, TraceState)@ tuple so GHC+can unbox through strict fields rather than boxing a 3-tuple.++@since 0.0.1.0 -}-data Sampler = Sampler- { getDescription :: Text- -- ^ Returns the sampler name or short description with the configuration. This may be displayed on debug pages or in the logs.- , shouldSample :: Context -> TraceId -> Text -> SpanArguments -> IO (SamplingResult, AttributeMap, TraceState)+data SamplingDecision = SamplingDecision+ { samplingOutcome :: !SamplingResult+ , samplingAttributes :: !AttributeMap+ , samplingTraceState :: !TraceState } +{- | Samplers control whether a span is recorded and\/or sampled.++The built-in constructors cover the standard OTel samplers. Custom+samplers use the 'CustomSampler' fallback.++Spec: <https://opentelemetry.io/docs/specs/otel/trace/sdk/#sampler>++@since 0.0.1.0+-}+data Sampler+ = -- | Always returns 'RecordAndSample'.+ AlwaysOnSampler+ | -- | Always returns 'Drop'.+ AlwaysOffSampler+ | {- | Sample based on the lower 63 bits of the trace ID (bytes 8-15).+ Fields: clamped fraction, precomputed upper bound, precomputed sampleRate attribute.+ -}+ TraceIdRatioSampler !Double !Word64 !Attribute+ | {- | Delegates to child samplers depending on whether the parent span+ is remote/local and sampled/unsampled.+ -}+ ParentBasedSampler !ParentBasedOptions+ | -- | Wraps another sampler, upgrading 'Drop' to 'RecordOnly'.+ AlwaysRecordSampler !Sampler+ | {- | Escape hatch for user-defined samplers.+ The 'InstrumentationLibrary' parameter is the instrumentation scope of the+ 'Tracer' creating the span, per spec §Sampling.+ Spec: <https://opentelemetry.io/docs/specs/otel/trace/sdk/#shouldsample>+ -}+ CustomSampler !Text !(Context -> TraceId -> Text -> SpanArguments -> InstrumentationLibrary -> IO SamplingDecision)+++{- | Options for 'ParentBasedSampler'. Each field designates which sampler+to delegate to depending on the parent span's state.++@since 0.0.1.0+-}+data ParentBasedOptions = ParentBasedOptions+ { rootSampler :: Sampler+ -- ^ Sampler called for spans with no parent (root spans)+ , remoteParentSampled :: Sampler+ -- ^ default: alwaysOn+ , remoteParentNotSampled :: Sampler+ -- ^ default: alwaysOff+ , localParentSampled :: Sampler+ -- ^ default: alwaysOn+ , localParentNotSampled :: Sampler+ -- ^ default: alwaysOff+ }+++{- | Configurable limits on span attributes, events, and links.++Spec: <https://opentelemetry.io/docs/specs/otel/trace/sdk/#span-limits>++@since 0.0.1.0+-} data SpanLimits = SpanLimits { spanAttributeValueLengthLimit :: Maybe Int , spanAttributeCountLimit :: Maybe Int@@ -474,6 +795,7 @@ deriving (Show, Eq) +-- | @since 0.0.1.0 defaultSpanLimits :: SpanLimits defaultSpanLimits = SpanLimits@@ -485,16 +807,21 @@ Nothing +-- | @since 0.0.1.0 type Lens s t a b = forall f. (Functor f) => (a -> f b) -> s -> f t +-- | @since 0.0.1.0 type Lens' s a = Lens s s a a {- | When sending tracing information across process boundaries, the @SpanContext@ is used to serialize the relevant information.++@since 0.0.1.0 -} getSpanContext :: (MonadIO m) => Span -> m SpanContext-getSpanContext (Span s) = liftIO (spanContext <$> readIORef s)+getSpanContext (Span imm) = pure (spanContext imm) getSpanContext (FrozenSpan c) = pure c getSpanContext (Dropped c) = pure c+{-# INLINE getSpanContext #-}
+ src/OpenTelemetry/Internal/UnpackedMaybe.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE UnboxedSums #-}+{-# LANGUAGE UnboxedTuples #-}++{- | Unboxed @Maybe@ using @UnboxedSums@ to eliminate the @Just@/@Nothing@+heap indirection. When stored as @{\-\# UNPACK \#-\} !(UMaybe a)@ in a+parent record, GHC can inline the tag + pointer directly into the parent+closure, so there is zero extra indirection for the Maybe layer.++Based on unpacked-maybe by Kyle McKean & Daniel Cartwright (BSD-3).+-}+module OpenTelemetry.Internal.UnpackedMaybe (+ UMaybe (UMaybe, UJust, UNothing),+ umaybe,+ isUJust,+ isUNothing,+ fromUMaybe,+ toBaseMaybe,+ fromBaseMaybe,+) where++import Data.Function (id)+import Prelude (Bool (..), Maybe (..))+++{- | An unboxed optional value. Single-constructor wrapper around an unboxed+sum, so @{\-\# UNPACK \#-\}@ can flatten it into a parent record.++@since 0.0.1.0+-}+data UMaybe a = UMaybe (# (# #) | a #)+++pattern UJust :: a -> UMaybe a+pattern UJust a = UMaybe (# | a #)+++pattern UNothing :: UMaybe a+pattern UNothing = UMaybe (# (# #) | #)+++{-# COMPLETE UJust, UNothing #-}+++-- | @since 0.0.1.0+umaybe :: b -> (a -> b) -> UMaybe a -> b+umaybe def f (UMaybe x) = case x of+ (# (# #) | #) -> def+ (# | a #) -> f a+{-# INLINE umaybe #-}+++-- | @since 0.0.1.0+isUJust :: UMaybe a -> Bool+isUJust (UJust _) = True+isUJust _ = False+{-# INLINE isUJust #-}+++-- | @since 0.0.1.0+isUNothing :: UMaybe a -> Bool+isUNothing UNothing = True+isUNothing _ = False+{-# INLINE isUNothing #-}+++-- | @since 0.0.1.0+fromUMaybe :: a -> UMaybe a -> a+fromUMaybe def = umaybe def id+{-# INLINE fromUMaybe #-}+++-- | @since 0.0.1.0+toBaseMaybe :: UMaybe a -> Maybe a+toBaseMaybe = umaybe Nothing Just+{-# INLINE toBaseMaybe #-}+++-- | @since 0.0.1.0+fromBaseMaybe :: Maybe a -> UMaybe a+fromBaseMaybe (Just x) = UJust x+fromBaseMaybe Nothing = UNothing+{-# INLINE fromBaseMaybe #-}
+ src/OpenTelemetry/Log/Core.hs view
@@ -0,0 +1,111 @@+{- |+Module : OpenTelemetry.Log.Core+Copyright : (c) Ian Duncan, 2026+License : BSD-3+Description : Public API for OpenTelemetry Logs+Stability : experimental++= Overview++This module provides the Logs Bridge API for connecting existing logging+systems (e.g. @monad-logger@, @katip@, @co-log@) to OpenTelemetry. It is+/not/ intended as a direct logging API for end users; instead, it gives+logging library authors the hooks to route log records through the+OpenTelemetry pipeline (processors, exporters, and correlation with traces).++= Quick example++@+import OpenTelemetry.Log.Core++main :: IO ()+main = do+ -- Create a provider (typically done by the SDK during initialization)+ lp <- createLoggerProvider processors emptyLoggerProviderOptions+ let logger = makeLogger lp "my-app"++ -- Emit a log record+ emitLogRecord logger $ LogRecordArguments+ { severityNumber = Just SeverityNumberInfo+ , severityText = Just "INFO"+ , body = Just (toValue ("User logged in" :: Text))+ , attributes = mempty+ , timestamp = Nothing+ , observedTimestamp = Nothing+ , traceContext = Nothing+ , instrumentationAttributes = Nothing+ }+@++= Key concepts++[@LoggerProvider@] Factory for 'Logger's. Holds processors, resource info,+and attribute limits. Create with 'createLoggerProvider'.++[@Logger@] Obtained from a 'LoggerProvider', scoped to an instrumentation+library. Use 'makeLogger' or 'getLogger'.++[@LogRecord@] A single log entry with severity, body, attributes, and+optional correlation to a trace span. Emitted via 'emitLogRecord'.++= Severity filtering++You can set a minimum severity level to suppress low-priority logs:++@+setLoggerMinSeverity lp (Just SeverityNumberWarn)+-- Now only WARN and above are emitted+@++Both 'loggerIsEnabled' and 'emitLogRecord' respect this threshold.+Use 'Nothing' to disable filtering.++= Spec reference++<https://opentelemetry.io/docs/specs/otel/logs/bridge-api/>+-}+module OpenTelemetry.Log.Core (+ -- * @LoggerProvider@ operations+ LoggerProvider (..),+ LoggerProviderOptions (..),+ emptyLoggerProviderOptions,+ createLoggerProvider,+ setGlobalLoggerProvider,+ getGlobalLoggerProvider,+ shutdownLoggerProvider,+ ShutdownResult (..),+ forceFlushLoggerProvider,++ -- * @Logger@ operations+ InstrumentationLibrary (..),+ instrumentationLibrary,+ withSchemaUrl,+ withLibraryAttributes,+ Logger (..),+ makeLogger,+ getLogger,+ loggerIsEnabled,+ loggerIsEnabled',+ setLoggerMinSeverity,+ getLoggerMinSeverity,++ -- * @LogRecord@ operations+ ReadableLogRecord,+ ReadWriteLogRecord,+ IsReadableLogRecord (..),+ IsReadWriteLogRecord (..),+ LogRecordArguments (..),+ AnyValue (..),+ ToValue (..),+ SeverityNumber (..),+ toShortName,+ emitLogRecord,+ addAttribute,+ addAttributes,+ logRecordGetAttributes,+) where++import OpenTelemetry.Internal.Common.Types+import OpenTelemetry.Internal.Log.Core+import OpenTelemetry.Internal.Log.Types+
src/OpenTelemetry/LogAttributes.hs view
@@ -2,6 +2,11 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} +{- |+Module : OpenTelemetry.LogAttributes+Description : Re-exports of log-specific attribute types.+Stability : experimental+-} module OpenTelemetry.LogAttributes ( LogAttributes (..), emptyAttributes,@@ -48,7 +53,8 @@ then LogAttributes attributes attributesCount (attributesDropped + 1) else LogAttributes newAttrs newCount attributesDropped where- newAttrs = H.insert k (maybe id limitLengths attributeCountLimit $ toValue v) attributes+ value = maybe id limitLengths attributeLengthLimit (toValue v)+ newAttrs = H.insert k value attributes newCount = H.size newAttrs {-# INLINE addAttribute #-} @@ -61,7 +67,8 @@ then LogAttributes attributes attributesCount (attributesDropped + H.size attrs) else LogAttributes newAttrs newCount attributesDropped where- newAttrs = H.union attributes $ H.map toValue attrs+ limitedVal x = maybe id limitLengths attributeLengthLimit (toValue x)+ newAttrs = H.union (H.map limitedVal attrs) attributes newCount = H.size newAttrs {-# INLINE addAttributes #-}
− src/OpenTelemetry/Logs/Core.hs
@@ -1,36 +0,0 @@-module OpenTelemetry.Logs.Core (- -- * @LoggerProvider@ operations- LoggerProvider (..),- LoggerProviderOptions (..),- emptyLoggerProviderOptions,- createLoggerProvider,- setGlobalLoggerProvider,- getGlobalLoggerProvider,- shutdownLoggerProvider,- forceFlushLoggerProvider,-- -- * @Logger@ operations- InstrumentationLibrary (..),- Logger (..),- makeLogger,-- -- * @LogRecord@ operations- ReadableLogRecord,- ReadWriteLogRecord,- IsReadableLogRecord (..),- IsReadWriteLogRecord (..),- LogRecordArguments (..),- AnyValue (..),- ToValue (..),- SeverityNumber (..),- toShortName,- emitLogRecord,- addAttribute,- addAttributes,- logRecordGetAttributes,-) where--import OpenTelemetry.Internal.Common.Types-import OpenTelemetry.Internal.Logs.Core-import OpenTelemetry.Internal.Logs.Types-
+ src/OpenTelemetry/Metric/Core.hs view
@@ -0,0 +1,264 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : OpenTelemetry.Metric.Core+Copyright : (c) Ian Duncan, 2026+License : BSD-3+Description : OpenTelemetry Metrics API+Stability : experimental++= Overview++This module defines the Metrics API for recording measurements in your+application. Libraries use this API to record metrics; the SDK provides+the actual aggregation and export.++Application authors should import @OpenTelemetry.Metric@ from the SDK+package instead, which re-exports everything here plus SDK initialization.++= Quick example++@+import OpenTelemetry.Metric.Core++main :: IO ()+main = do+ -- Obtain the global MeterProvider (set up by the SDK)+ mp <- getGlobalMeterProvider+ meter <- getMeter mp myInstrumentationLibrary++ -- Create instruments+ requestCounter <- meterCreateCounterInt64 meter "http.requests" "" Nothing defaultAdvisoryParameters+ latencyHist <- meterCreateHistogram meter "http.request.duration" "ms" Nothing defaultAdvisoryParameters++ -- Record measurements+ counterAdd requestCounter 1 [("method", toAttribute "GET")]+ histogramRecord latencyHist 42.5 [("method", toAttribute "GET")]+@++= Instrument types++== Synchronous instruments++These are called inline with your application code:++* 'Counter' : monotonically increasing sum (e.g. request count, bytes sent).+ Use @counterAdd counter value attrs@.+* 'UpDownCounter' : sum that can increase or decrease (e.g. active connections,+ queue depth). Use @upDownCounterAdd counter value attrs@.+* 'Histogram' : distribution of values (e.g. request latency, payload size).+ Use @histogramRecord histogram value attrs@.+* 'Gauge' : point-in-time value (e.g. CPU temperature, memory usage).+ Use @gaugeRecord gauge value attrs@.++== Asynchronous (observable) instruments++These are read by callbacks during export:++* 'ObservableCounter' : monotonic sum read on demand (e.g. CPU time).+* 'ObservableUpDownCounter' : bidirectional sum read on demand.+* 'ObservableGauge' : snapshot value read on demand (e.g. disk free space).++Register a callback when creating the instrument:++@+obsGauge <- meterCreateObservableGaugeDouble meter+ "system.memory.usage" "By" Nothing defaultAdvisoryParameters+ (\result -> do+ memInfo <- getMemoryUsage+ observeDouble result memInfo [("state", toAttribute "used")]+ )+@++= No-op behavior++Before the SDK is installed, 'noopMeterProvider' is the global default.+All measurements are silently discarded. This makes it safe for libraries+to instrument unconditionally.++= Spec reference++<https://opentelemetry.io/docs/specs/otel/metrics/api/>+-}+module OpenTelemetry.Metric.Core (+ -- * Provider+ MeterProvider (..),+ getMeter,+ noopMeterProvider,+ noopMeter,+ shutdownMeterProvider,+ forceFlushMeterProvider,+ getGlobalMeterProvider,+ setGlobalMeterProvider,++ -- * Meter+ Meter (..),++ -- * Instruments+ InstrumentKind (..),+ HistogramAggregation (..),+ AdvisoryParameters (..),+ defaultAdvisoryParameters,+ Counter (..),+ UpDownCounter (..),+ Histogram (..),+ Gauge (..),+ ObservableResult (..),+ ObservableCallbackHandle (..),+ ObservableCounter (..),+ ObservableUpDownCounter (..),+ ObservableGauge (..),++ -- * Instrument name validation (for SDK implementers)+ InstrumentName.validateInstrumentName,+ InstrumentName.validateInstrumentUnit,+) where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.IORef (IORef, atomicWriteIORef, newIORef, readIORef)+import Data.Int (Int64)+import Data.Text (Text)+import OpenTelemetry.Internal.Common.Types (FlushResult (..), InstrumentationLibrary (..), ShutdownResult (..))+import OpenTelemetry.Internal.Metric.Types+import qualified OpenTelemetry.Metric.InstrumentName as InstrumentName+import System.IO.Unsafe (unsafePerformIO)+++{- | Preferred accessor for obtaining a 'Meter' (spec: Get a Meter).++@since 0.0.1.0+-}+getMeter :: MeterProvider -> InstrumentationLibrary -> IO Meter+getMeter = meterProviderGetMeter+++-- | @since 0.0.1.0+shutdownMeterProvider+ :: MeterProvider+ -> Maybe Int+ -- ^ Optional timeout in microseconds. @Nothing@ uses the SDK default (5s).+ -> IO ShutdownResult+shutdownMeterProvider = meterProviderShutdown+++-- | @since 0.0.1.0+forceFlushMeterProvider+ :: MeterProvider+ -> Maybe Int+ -- ^ Optional timeout in microseconds. @Nothing@ uses the SDK default (5s).+ -> IO FlushResult+forceFlushMeterProvider mp = meterProviderForceFlush mp+++noopCounterI64 :: Counter Int64+noopCounterI64 = Counter (\_ _ -> pure ()) (pure False)+++noopCounterDbl :: Counter Double+noopCounterDbl = Counter (\_ _ -> pure ()) (pure False)+++noopUpDownI64 :: UpDownCounter Int64+noopUpDownI64 = UpDownCounter (\_ _ -> pure ()) (pure False)+++noopUpDownDbl :: UpDownCounter Double+noopUpDownDbl = UpDownCounter (\_ _ -> pure ()) (pure False)+++noopHistogram :: Histogram+noopHistogram = Histogram (\_ _ -> pure ()) (pure False)+++noopGaugeI64 :: Gauge Int64+noopGaugeI64 = Gauge (\_ _ -> pure ()) (pure False)+++noopGaugeDbl :: Gauge Double+noopGaugeDbl = Gauge (\_ _ -> pure ()) (pure False)+++noopReg :: IO ObservableCallbackHandle+noopReg = pure (ObservableCallbackHandle (pure ()))+++noopObservableCounter :: InstrumentationLibrary -> Text -> ObservableCounter a+noopObservableCounter scope name =+ ObservableCounter+ { observableCounterRegisterCallback = \_ -> noopReg+ , observableCounterInstrumentScope = scope+ , observableCounterInstrumentName = name+ , observableCounterEnabled = pure False+ }+++noopObservableUpDown :: InstrumentationLibrary -> Text -> ObservableUpDownCounter a+noopObservableUpDown scope name =+ ObservableUpDownCounter+ { observableUpDownCounterRegisterCallback = \_ -> noopReg+ , observableUpDownCounterInstrumentScope = scope+ , observableUpDownCounterInstrumentName = name+ , observableUpDownCounterEnabled = pure False+ }+++noopObservableGauge :: InstrumentationLibrary -> Text -> ObservableGauge a+noopObservableGauge scope name =+ ObservableGauge+ { observableGaugeRegisterCallback = \_ -> noopReg+ , observableGaugeInstrumentScope = scope+ , observableGaugeInstrumentName = name+ , observableGaugeEnabled = pure False+ }+++{- | A 'Meter' that records no telemetry (used by 'noopMeterProvider').++@since 0.0.1.0+-}+noopMeter :: InstrumentationLibrary -> Meter+noopMeter scope =+ Meter+ { meterInstrumentationScope = scope+ , meterCreateCounterInt64 = \_ _ _ _ -> pure noopCounterI64+ , meterCreateCounterDouble = \_ _ _ _ -> pure noopCounterDbl+ , meterCreateUpDownCounterInt64 = \_ _ _ _ -> pure noopUpDownI64+ , meterCreateUpDownCounterDouble = \_ _ _ _ -> pure noopUpDownDbl+ , meterCreateHistogram = \_ _ _ _ -> pure noopHistogram+ , meterCreateGaugeInt64 = \_ _ _ _ -> pure noopGaugeI64+ , meterCreateGaugeDouble = \_ _ _ _ -> pure noopGaugeDbl+ , meterCreateObservableCounterInt64 = \name _ _ _ _ -> pure (noopObservableCounter scope name)+ , meterCreateObservableCounterDouble = \name _ _ _ _ -> pure (noopObservableCounter scope name)+ , meterCreateObservableUpDownCounterInt64 = \name _ _ _ _ -> pure (noopObservableUpDown scope name)+ , meterCreateObservableUpDownCounterDouble = \name _ _ _ _ -> pure (noopObservableUpDown scope name)+ , meterCreateObservableGaugeInt64 = \name _ _ _ _ -> pure (noopObservableGauge scope name)+ , meterCreateObservableGaugeDouble = \name _ _ _ _ -> pure (noopObservableGauge scope name)+ }+++{- | No-op provider: safe for libraries; all measurements are discarded.++@since 0.0.1.0+-}+noopMeterProvider :: MeterProvider+noopMeterProvider =+ MeterProvider+ { meterProviderGetMeter = \scope -> pure (noopMeter scope)+ , meterProviderShutdown = \_ -> pure ShutdownSuccess+ , meterProviderForceFlush = \_ -> pure FlushSuccess+ }+++globalMeterProvider :: IORef MeterProvider+{-# NOINLINE globalMeterProvider #-}+globalMeterProvider = unsafePerformIO $ newIORef noopMeterProvider+++-- | @since 0.0.1.0+getGlobalMeterProvider :: (MonadIO m) => m MeterProvider+getGlobalMeterProvider = liftIO $ readIORef globalMeterProvider+++-- | @since 0.0.1.0+setGlobalMeterProvider :: (MonadIO m) => MeterProvider -> m ()+setGlobalMeterProvider p = liftIO $ atomicWriteIORef globalMeterProvider p
+ src/OpenTelemetry/Metric/InstrumentName.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : OpenTelemetry.Metric.InstrumentName+Copyright : (c) Ian Duncan, 2026+License : BSD-3+Description : Instrument name and unit validation per the metrics API spec.+Stability : experimental++The SDK validates instrument names and units at creation time. The API itself+does not validate (per spec), but these functions are used by the SDK to reject+invalid names before registering instruments.++Spec: <https://opentelemetry.io/docs/specs/otel/metrics/api/#instrument-name-syntax>+-}+module OpenTelemetry.Metric.InstrumentName (+ validateInstrumentName,+ validateInstrumentUnit,+) where++import Data.Char (isAscii)+import Data.Text (Text)+import qualified Data.Text as T+++{- | @Nothing@ if valid; @Just err@ with a short English reason if invalid.+Implements the stable rules from specification/metrics/api.md (instrument name ABNF; ASCII only).++@since 0.0.1.0+-}+validateInstrumentName :: Text -> Maybe Text+validateInstrumentName t+ | T.null t = Just "instrument name must not be empty"+ | T.length t > 255 = Just "instrument name exceeds 255 characters"+ | otherwise =+ let c0 = T.index t 0+ in if not (isAsciiAlpha c0)+ then Just "instrument name must start with an ASCII letter"+ else go 1+ where+ go :: Int -> Maybe Text+ go i+ | i >= T.length t = Nothing+ | otherwise =+ let c = T.index t i+ in if isValidChar c+ then go (i + 1)+ else Just "instrument name contains invalid characters"+ isAsciiAlpha c =+ isAscii c+ && ((c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z'))+ isAsciiDigit c = c >= '0' && c <= '9'+ isValidChar c =+ isAscii c+ && ( isAsciiAlpha c+ || isAsciiDigit c+ || c == '_'+ || c == '.'+ || c == '-'+ || c == '/'+ )+++{- | Unit is optional; when present it must be ASCII and at most 63 code units (specification/metrics/api.md).++@since 0.0.1.0+-}+validateInstrumentUnit :: Text -> Maybe Text+validateInstrumentUnit u+ | T.null u = Nothing+ | T.length u > 63 = Just "instrument unit exceeds 63 characters"+ | otherwise =+ let step i+ | i >= T.length u = Nothing+ | otherwise =+ let c = T.index u i+ in if isAscii c then step (i + 1) else Just "instrument unit must be ASCII"+ in step 0
src/OpenTelemetry/Processor.hs view
@@ -1,5 +1,12 @@ {-# LANGUAGE PatternSynonyms #-} +{- |+Module : OpenTelemetry.Processor+Description : Re-exports of span processor types.+Stability : experimental++This module is deprecated; prefer 'OpenTelemetry.Processor.Span'.+-} module OpenTelemetry.Processor {-# DEPRECATED "use OpenTelemetry.Processor.Span instead" #-} ( Processor,@@ -13,8 +20,6 @@ ShutdownResult (..), ) where -import Control.Concurrent.Async (Async)-import Data.IORef (IORef) import OpenTelemetry.Context (Context) import OpenTelemetry.Internal.Trace.Types (ImmutableSpan) import OpenTelemetry.Processor.Span@@ -27,10 +32,10 @@ pattern Processor- :: (IORef ImmutableSpan -> Context -> IO ())- -> (IORef ImmutableSpan -> IO ())- -> IO (Async ShutdownResult)- -> IO ()+ :: (ImmutableSpan -> Context -> IO ())+ -> (ImmutableSpan -> IO ())+ -> IO ShutdownResult+ -> IO FlushResult -> SpanProcessor pattern Processor {processorOnStart, processorOnEnd, processorShutdown, processorForceFlush} = SpanProcessor
src/OpenTelemetry/Processor/LogRecord.hs view
@@ -1,8 +1,14 @@+{- |+Module : OpenTelemetry.Processor.LogRecord+Description : Re-exports of log record processor types.+Stability : experimental+-} module OpenTelemetry.Processor.LogRecord ( LogRecordProcessor (..), ShutdownResult (..),+ FlushResult (..), ) where import OpenTelemetry.Internal.Common.Types-import OpenTelemetry.Internal.Logs.Types+import OpenTelemetry.Internal.Log.Types
src/OpenTelemetry/Processor/Span.hs view
@@ -1,7 +1,3 @@-------------------------------------------------------------------------------------------------------------------------------------------------------------- {- | Module : OpenTelemetry.Processor.Span Copyright : (c) Ian Duncan, 2021@@ -23,6 +19,7 @@ -} module OpenTelemetry.Processor.Span ( SpanProcessor (..),+ FlushResult (..), ShutdownResult (..), ) where
src/OpenTelemetry/Propagator.hs view
@@ -1,56 +1,140 @@ {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} ------------------------------------------------------------------------------+{- |+Module : OpenTelemetry.Propagator+Copyright : (c) Ian Duncan, 2021-2026+License : BSD-3+Description : Context propagation across process boundaries+Stability : experimental ------------------------------------------------------------------------------+= Overview -{- |- Module : OpenTelemetry.Trace.Propagator- Copyright : (c) Ian Duncan, 2021- License : BSD-3- Description : Sending and receiving state between system boundaries- Maintainer : Ian Duncan- Stability : experimental- Portability : non-portable (GHC extensions)+Propagators serialize and deserialize 'Context' (trace state and baggage)+into carrier formats like HTTP headers. This is how distributed tracing+works across service boundaries. - Cross-cutting concerns send their state to the next process using Propagators, which are defined as objects used to- read and write context data to and from messages exchanged by the applications.- Each concern creates a set of Propagators for every supported Propagator type.+= Built-in propagators - Propagators leverage the Context to inject and extract data for each cross-cutting concern, such as traces and Baggage.+The SDK registers these propagators automatically: - Propagation is usually implemented via a cooperation of library-specific request interceptors and Propagators,- where the interceptors detect incoming and outgoing requests and use the Propagator's extract and inject operations- respectively.+* __W3C TraceContext__ (@traceparent@ header) -- default+* __W3C Baggage__ (@baggage@ header) -- default+* __B3__ (Zipkin single and multi-header)+* __Jaeger__ (@uber-trace-id@ header)+* __Datadog__ (@x-datadog-trace-id@ headers)+* __AWS X-Ray__ (@X-Amzn-Trace-Id@ header) - The Propagators API is expected to be leveraged by users writing instrumentation libraries. However,- users using the OpenTelemetry SDK may need to select appropriate propagators to work with existing 3rd party systems- such as AWS.+Configure via @OTEL_PROPAGATORS@:++> export OTEL_PROPAGATORS=tracecontext,baggage,b3++= Usage in instrumentation++If you are writing instrumentation for a transport (HTTP, gRPC, messaging),+use the global propagator to inject\/extract context:++@+import OpenTelemetry.Propagator+import OpenTelemetry.Context.ThreadLocal++-- Injecting (outbound request):+propagator <- getGlobalTextMapPropagator+ctx <- getContext+headers <- inject propagator ctx request++-- Extracting (inbound request):+propagator <- getGlobalTextMapPropagator+ctx <- extract propagator request =<< getContext+tok <- attachContext ctx+-- ... later, restore previous context:+detachContext tok+@++= Custom propagators++Implement the 'Propagator' record with 'propagatorFields', 'extractor',+and 'injector' fields. Propagators are composable via their 'Monoid'+instance (extracts and injects run in sequence).++= Spec reference++<https://opentelemetry.io/docs/specs/otel/context/api-propagators/> -}-module OpenTelemetry.Propagator where+module OpenTelemetry.Propagator (+ -- * Propagator+ Propagator (..),+ propagatorNames,+ extract,+ inject, -import Control.Monad+ -- * TextMap carrier+ TextMap,+ emptyTextMap,+ textMapInsert,+ textMapLookup,+ textMapDelete,+ textMapKeys,+ textMapToList,+ textMapFromList,++ -- * TextMapPropagator+ TextMapPropagator,++ -- * Global TextMapPropagator+ getGlobalTextMapPropagator,+ setGlobalTextMapPropagator,+) where++import Control.Exception (SomeException, catch) import Control.Monad.IO.Class+import qualified Data.HashMap.Strict as H+import Data.IORef+import qualified Data.List as List import Data.Text (Text)+import qualified Data.Text as T+import OpenTelemetry.Context.Types (Context)+import OpenTelemetry.Internal.Logging (otelLogWarning)+import System.IO.Unsafe (unsafePerformIO) {- | A carrier is the medium used by Propagators to read values from and write values to. Each specific Propagator type defines its expected carrier type, such as a string map or a byte array.++@since 0.0.1.0 -} data Propagator context inboundCarrier outboundCarrier = Propagator- { propagatorNames :: [Text]+ { propagatorFields :: [Text]+ {- ^ The predefined propagation fields. For a TextMapPropagator these are+ the header names the propagator reads and writes (e.g. @["traceparent", "tracestate"]@).+ If your carrier is reused, you should delete these fields before calling 'inject'.+ -} , extractor :: inboundCarrier -> context -> IO context , injector :: context -> outboundCarrier -> IO outboundCarrier } instance Semigroup (Propagator c i o) where- (Propagator lNames lExtract lInject) <> (Propagator rNames rExtract rInject) =+ (Propagator lFields lExtract lInject) <> (Propagator rFields rExtract rInject) = Propagator- { propagatorNames = lNames <> rNames- , extractor = \i -> lExtract i >=> rExtract i- , injector = \c -> lInject c >=> rInject c+ { propagatorFields = lFields <> rFields+ , extractor = \i ctx -> do+ ctx' <-+ lExtract i ctx `catch` \(e :: SomeException) -> do+ otelLogWarning $ "Propagator extract failed: " <> show e+ pure ctx+ rExtract i ctx' `catch` \(e :: SomeException) -> do+ otelLogWarning $ "Propagator extract failed: " <> show e+ pure ctx'+ , injector = \c carrier -> do+ carrier' <-+ lInject c carrier `catch` \(e :: SomeException) -> do+ otelLogWarning $ "Propagator inject failed: " <> show e+ pure carrier+ rInject c carrier' `catch` \(e :: SomeException) -> do+ otelLogWarning $ "Propagator inject failed: " <> show e+ pure carrier' } @@ -58,10 +142,125 @@ mempty = Propagator mempty (\_ c -> pure c) (\_ p -> pure p) +{- | A case-insensitive text map used as the carrier for context propagation.+Keys are compared case-insensitively but their original casing is preserved,+matching the behavior required by HTTP header semantics.++Instrumentation code converts between transport-specific representations+(e.g. HTTP headers) and 'TextMap' at the boundary.++@since 0.4.0.0+-}+data TextMap = TextMap+ { tmLookup :: !(H.HashMap Text Text)+ -- ^ Lowercase key -> value (for O(1) case-insensitive lookup)+ , tmOriginal :: !(H.HashMap Text Text)+ -- ^ Lowercase key -> original-cased key (to preserve casing on output)+ }+ deriving (Show, Eq)+++-- | @since 0.4.0.0+emptyTextMap :: TextMap+emptyTextMap = TextMap H.empty H.empty+{-# INLINE emptyTextMap #-}+++-- | @since 0.4.0.0+textMapInsert :: Text -> Text -> TextMap -> TextMap+textMapInsert k v (TextMap lk orig) =+ let lk' = T.toLower k+ in TextMap (H.insert lk' v lk) (H.insert lk' k orig)+{-# INLINE textMapInsert #-}+++-- | @since 0.4.0.0+textMapLookup :: Text -> TextMap -> Maybe Text+textMapLookup k (TextMap lk _) = H.lookup (T.toLower k) lk+{-# INLINE textMapLookup #-}+++-- | @since 0.4.0.0+textMapDelete :: Text -> TextMap -> TextMap+textMapDelete k (TextMap lk orig) =+ let lk' = T.toLower k+ in TextMap (H.delete lk' lk) (H.delete lk' orig)+{-# INLINE textMapDelete #-}+++-- | @since 0.4.0.0+textMapKeys :: TextMap -> [Text]+textMapKeys (TextMap _ orig) = H.elems orig+{-# INLINE textMapKeys #-}+++-- | @since 0.4.0.0+textMapToList :: TextMap -> [(Text, Text)]+textMapToList (TextMap lk orig) =+ H.foldlWithKey'+ ( \acc lk' v -> case H.lookup lk' orig of+ Just origKey -> (origKey, v) : acc+ Nothing -> (lk', v) : acc+ )+ []+ lk+{-# INLINE textMapToList #-}+++-- | @since 0.4.0.0+textMapFromList :: [(Text, Text)] -> TextMap+textMapFromList = List.foldl' (\tm (k, v) -> textMapInsert k v tm) emptyTextMap+++{- | A 'TextMapPropagator' is a 'Propagator' specialized for text-based+carriers. This is the only propagator type defined by the OpenTelemetry+specification.++Instrumentation libraries convert between transport-specific formats+(e.g. HTTP headers, gRPC metadata, environment variables) and 'TextMap'+at the boundary, then pass the 'TextMap' to the propagator.++@since 0.4.0.0+-}+type TextMapPropagator = Propagator Context TextMap TextMap+++-- Per spec: "The OpenTelemetry API MUST use no-op propagators unless+-- explicitly configured otherwise." mempty is the no-op propagator.+globalTextMapPropagator :: IORef TextMapPropagator+globalTextMapPropagator = unsafePerformIO $ newIORef mempty+{-# NOINLINE globalTextMapPropagator #-}+++{- | Get the globally configured 'TextMapPropagator'.++Returns a no-op propagator until the SDK sets one via+'setGlobalTextMapPropagator' (typically driven by @OTEL_PROPAGATORS@).++@since 0.4.0.0+-}+getGlobalTextMapPropagator :: IO TextMapPropagator+getGlobalTextMapPropagator = readIORef globalTextMapPropagator+++{- | Set the global 'TextMapPropagator'.++Called by the SDK during initialization. Instrumentation libraries+should use 'getGlobalTextMapPropagator' rather than accessing the+'TracerProvider' propagator directly.++@since 0.4.0.0+-}+setGlobalTextMapPropagator :: TextMapPropagator -> IO ()+setGlobalTextMapPropagator = atomicWriteIORef globalTextMapPropagator++ {- | Extracts the value from an incoming request. For example, from the headers of an HTTP request. If a value can not be parsed from the carrier, for a cross-cutting concern, the implementation MUST NOT throw an exception and MUST NOT store a new value in the Context, in order to preserve any previously existing valid value.++@since 0.0.1.0 -} extract :: (MonadIO m)@@ -71,10 +270,26 @@ -> context -> m context -- ^ a new Context derived from the Context passed as argument, containing the extracted value, which can be a SpanContext, Baggage or another cross-cutting concern context.-extract (Propagator _ extractor _) i = liftIO . extractor i+extract (Propagator _ extractor_ _) i ctx =+ liftIO $+ extractor_ i ctx `catch` \(e :: SomeException) -> do+ otelLogWarning $ "Propagator extract failed: " <> show e+ pure ctx --- | Injects the value into a carrier. For example, into the headers of an HTTP request.+{- | Deprecated alias for 'propagatorFields'.++@since 0.0.1.0+-}+propagatorNames :: Propagator context i o -> [Text]+propagatorNames = propagatorFields+{-# DEPRECATED propagatorNames "Use propagatorFields instead. propagatorNames will be removed in a future release." #-}+++{- | Injects the value into a carrier. For example, into the headers of an HTTP request.++@since 0.0.1.0+-} inject :: (MonadIO m) => Propagator context i o@@ -82,4 +297,8 @@ -> o -- ^ The carrier that holds the propagation fields. For example, an outgoing message or HTTP request. -> m o-inject (Propagator _ _ injector) c = liftIO . injector c+inject (Propagator _ _ injector_) c carrier =+ liftIO $+ injector_ c carrier `catch` \(e :: SomeException) -> do+ otelLogWarning $ "Propagator inject failed: " <> show e+ pure carrier
+ src/OpenTelemetry/Registry.hs view
@@ -0,0 +1,350 @@+{-# LANGUAGE DataKinds #-}++{- |+ Module : OpenTelemetry.Registry+ Copyright : (c) Ian Duncan, 2021+ License : BSD-3+ Description : Global registry for exporters and propagators+ Maintainer : Ian Duncan+ Stability : experimental+ Portability : non-portable (GHC extensions)++ A global, process-wide registry that allows exporter and propagator+ libraries to make themselves discoverable by the SDK at+ initialization time.++ This follows the same pattern as Go's+ [@autoexport@](https://pkg.go.dev/go.opentelemetry.io/contrib/exporters/autoexport)+ and+ [@autoprop@](https://pkg.go.dev/go.opentelemetry.io/contrib/propagators/autoprop)+ packages: the registry is the single source of truth for resolving+ @OTEL_TRACES_EXPORTER@, @OTEL_PROPAGATORS@, and similar environment+ variables.++ == How it works++ * The SDK registers its known defaults (otlp, tracecontext, baggage,+ b3, datadog) using the @IfAbsent@ variants during initialization.+ * Third-party packages that call the plain @register@ variants+ /before/ SDK init will therefore take precedence over built-in+ defaults.+ * After SDK init, the registry is no longer consulted; changes have+ no retroactive effect on an already-initialized 'TracerProvider'.++ == Usage example++ @+ import OpenTelemetry.Registry ('registerSpanExporterFactory', 'registerTextMapPropagator')+ import OpenTelemetry.Trace ('initializeGlobalTracerProvider')++ main :: IO ()+ main = do+ -- Register a custom exporter before SDK init.+ -- When OTEL_TRACES_EXPORTER=\"zipkin\", the SDK will use this factory.+ 'registerSpanExporterFactory' \"zipkin\" myZipkinExporterFactory++ -- Register a custom propagator.+ -- When OTEL_PROPAGATORS=\"xray\", the SDK will use this propagator.+ 'registerTextMapPropagator' \"xray\" myXRayPropagator++ -- The SDK now resolves exporter\/propagator names from the registry.+ 'initializeGlobalTracerProvider'+ ...+ @++ @since 0.4.0.0+-}+module OpenTelemetry.Registry (+ -- * Span Exporter Registry+ registerSpanExporterFactory,+ registerSpanExporterFactoryIfAbsent,+ lookupSpanExporterFactory,+ registeredSpanExporterFactories,++ -- * Metric Exporter Registry+ registerMetricExporterFactory,+ registerMetricExporterFactoryIfAbsent,+ lookupMetricExporterFactory,+ registeredMetricExporterFactories,++ -- * Log Record Exporter Registry+ registerLogRecordExporterFactory,+ registerLogRecordExporterFactoryIfAbsent,+ lookupLogRecordExporterFactory,+ registeredLogRecordExporterFactories,++ -- * Text Map Propagator Registry+ registerTextMapPropagator,+ registerTextMapPropagatorIfAbsent,+ lookupRegisteredTextMapPropagator,+ registeredTextMapPropagators,++ -- * Resource Detector Registry+ ResourceDetector,+ registerResourceDetector,+ registerResourceDetectorIfAbsent,+ lookupResourceDetector,+ registeredResourceDetectors,+) where++import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as H+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)+import Data.Text (Text)+import OpenTelemetry.Internal.Log.Types (LogRecordExporter)+import OpenTelemetry.Internal.Metric.Export (MetricExporter)+import OpenTelemetry.Internal.Trace.Types (SpanExporter)+import OpenTelemetry.Propagator (TextMapPropagator)+import OpenTelemetry.Resource (Resource)+import System.IO.Unsafe (unsafePerformIO)+++-- Internal: insert-or-replace into an IORef HashMap.+insertRegistry :: IORef (HashMap Text v) -> Text -> v -> IO ()+insertRegistry ref name val =+ atomicModifyIORef' ref $ \m -> (H.insert name val m, ())+{-# INLINE insertRegistry #-}+++-- Internal: insert only if the key is absent. Returns True when a+-- new entry was actually inserted.+insertRegistryIfAbsent :: IORef (HashMap Text v) -> Text -> v -> IO Bool+insertRegistryIfAbsent ref name val =+ atomicModifyIORef' ref $ \m ->+ if H.member name m+ then (m, False)+ else (H.insert name val m, True)+{-# INLINE insertRegistryIfAbsent #-}+++lookupRegistry :: IORef (HashMap Text v) -> Text -> IO (Maybe v)+lookupRegistry ref name = H.lookup name <$> readIORef ref+{-# INLINE lookupRegistry #-}+++readRegistry :: IORef (HashMap Text v) -> IO (HashMap Text v)+readRegistry = readIORef+{-# INLINE readRegistry #-}+++-- Span Exporters --------------------------------------------------------------++spanExporterRegistry :: IORef (HashMap Text (IO SpanExporter))+spanExporterRegistry = unsafePerformIO $ newIORef H.empty+{-# NOINLINE spanExporterRegistry #-}+++{- | Register a span exporter factory, replacing any existing entry+with the same name.++Use this from third-party exporter packages to override or extend the+set of exporters available to the SDK.++@since 0.4.0.0+-}+registerSpanExporterFactory :: Text -> IO SpanExporter -> IO ()+registerSpanExporterFactory = insertRegistry spanExporterRegistry+++{- | Register a span exporter factory only if no factory is already+registered under the given name. Returns 'True' if the factory was+registered, 'False' if an entry already existed.++The SDK uses this for built-in defaults so that user registrations+(made before SDK initialization) take precedence.++@since 0.4.0.0+-}+registerSpanExporterFactoryIfAbsent :: Text -> IO SpanExporter -> IO Bool+registerSpanExporterFactoryIfAbsent = insertRegistryIfAbsent spanExporterRegistry+++{- | Look up a span exporter factory by name.++@since 0.4.0.0+-}+lookupSpanExporterFactory :: Text -> IO (Maybe (IO SpanExporter))+lookupSpanExporterFactory = lookupRegistry spanExporterRegistry+++{- | Return all registered span exporter factories.++@since 0.4.0.0+-}+registeredSpanExporterFactories :: IO (HashMap Text (IO SpanExporter))+registeredSpanExporterFactories = readRegistry spanExporterRegistry+++-- Metric Exporters ------------------------------------------------------------++metricExporterRegistry :: IORef (HashMap Text (IO MetricExporter))+metricExporterRegistry = unsafePerformIO $ newIORef H.empty+{-# NOINLINE metricExporterRegistry #-}+++{- | Register a metric exporter factory, replacing any existing entry.++@since 0.4.0.0+-}+registerMetricExporterFactory :: Text -> IO MetricExporter -> IO ()+registerMetricExporterFactory = insertRegistry metricExporterRegistry+++{- | Register a metric exporter factory only if absent.++@since 0.4.0.0+-}+registerMetricExporterFactoryIfAbsent :: Text -> IO MetricExporter -> IO Bool+registerMetricExporterFactoryIfAbsent = insertRegistryIfAbsent metricExporterRegistry+++{- | Look up a metric exporter factory by name.++@since 0.4.0.0+-}+lookupMetricExporterFactory :: Text -> IO (Maybe (IO MetricExporter))+lookupMetricExporterFactory = lookupRegistry metricExporterRegistry+++{- | Return all registered metric exporter factories.++@since 0.4.0.0+-}+registeredMetricExporterFactories :: IO (HashMap Text (IO MetricExporter))+registeredMetricExporterFactories = readRegistry metricExporterRegistry+++-- Log Record Exporters --------------------------------------------------------++logRecordExporterRegistry :: IORef (HashMap Text (IO LogRecordExporter))+logRecordExporterRegistry = unsafePerformIO $ newIORef H.empty+{-# NOINLINE logRecordExporterRegistry #-}+++{- | Register a log record exporter factory, replacing any existing entry.++@since 0.4.0.0+-}+registerLogRecordExporterFactory :: Text -> IO LogRecordExporter -> IO ()+registerLogRecordExporterFactory = insertRegistry logRecordExporterRegistry+++{- | Register a log record exporter factory only if absent.++@since 0.4.0.0+-}+registerLogRecordExporterFactoryIfAbsent :: Text -> IO LogRecordExporter -> IO Bool+registerLogRecordExporterFactoryIfAbsent = insertRegistryIfAbsent logRecordExporterRegistry+++{- | Look up a log record exporter factory by name.++@since 0.4.0.0+-}+lookupLogRecordExporterFactory :: Text -> IO (Maybe (IO LogRecordExporter))+lookupLogRecordExporterFactory = lookupRegistry logRecordExporterRegistry+++{- | Return all registered log record exporter factories.++@since 0.4.0.0+-}+registeredLogRecordExporterFactories :: IO (HashMap Text (IO LogRecordExporter))+registeredLogRecordExporterFactories = readRegistry logRecordExporterRegistry+++-- Text Map Propagators --------------------------------------------------------++propagatorRegistry :: IORef (HashMap Text TextMapPropagator)+propagatorRegistry = unsafePerformIO $ newIORef H.empty+{-# NOINLINE propagatorRegistry #-}+++{- | Register a text map propagator, replacing any existing entry with+the same name.++@since 0.4.0.0+-}+registerTextMapPropagator :: Text -> TextMapPropagator -> IO ()+registerTextMapPropagator = insertRegistry propagatorRegistry+++{- | Register a text map propagator only if absent. Returns 'True'+when a new entry was inserted.++@since 0.4.0.0+-}+registerTextMapPropagatorIfAbsent :: Text -> TextMapPropagator -> IO Bool+registerTextMapPropagatorIfAbsent = insertRegistryIfAbsent propagatorRegistry+++{- | Look up a text map propagator by name.++@since 0.4.0.0+-}+lookupRegisteredTextMapPropagator :: Text -> IO (Maybe TextMapPropagator)+lookupRegisteredTextMapPropagator = lookupRegistry propagatorRegistry+++{- | Return all registered text map propagators.++@since 0.4.0.0+-}+registeredTextMapPropagators :: IO (HashMap Text TextMapPropagator)+registeredTextMapPropagators = readRegistry propagatorRegistry+++-- Resource Detectors ----------------------------------------------------------++{- | A resource detector is an IO action that produces a 'Resource'.+Detectors that do not apply to the current environment should return+@'mkResource' []@ (an empty resource).++@since 0.4.0.0+-}+type ResourceDetector = IO Resource+++resourceDetectorRegistry :: IORef (HashMap Text ResourceDetector)+resourceDetectorRegistry = unsafePerformIO $ newIORef H.empty+{-# NOINLINE resourceDetectorRegistry #-}+++{- | Register a resource detector, replacing any existing entry with+the same name.++Use this from application code or third-party packages to make a+custom detector available to the SDK.++@since 0.4.0.0+-}+registerResourceDetector :: Text -> ResourceDetector -> IO ()+registerResourceDetector = insertRegistry resourceDetectorRegistry+++{- | Register a resource detector only if absent. Returns 'True'+when a new entry was inserted.++The SDK uses this for built-in detectors so that user registrations+(made before SDK initialization) take precedence.++@since 0.4.0.0+-}+registerResourceDetectorIfAbsent :: Text -> ResourceDetector -> IO Bool+registerResourceDetectorIfAbsent = insertRegistryIfAbsent resourceDetectorRegistry+++{- | Look up a resource detector by name.++@since 0.4.0.0+-}+lookupResourceDetector :: Text -> IO (Maybe ResourceDetector)+lookupResourceDetector = lookupRegistry resourceDetectorRegistry+++{- | Return all registered resource detectors.++@since 0.4.0.0+-}+registeredResourceDetectors :: IO (HashMap Text ResourceDetector)+registeredResourceDetectors = readRegistry resourceDetectorRegistry
src/OpenTelemetry/Resource.hs view
@@ -1,86 +1,169 @@-{-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-} ------------------------------------------------------------------------------+{- |+Module : OpenTelemetry.Resource+Copyright : (c) Ian Duncan, 2021-2026+License : BSD-3+Description : Metadata describing the entity producing telemetry+Stability : experimental ------------------------------------------------------------------------------+= Overview -{- |- Module : OpenTelemetry.Resource- Copyright : (c) Ian Duncan, 2021- License : BSD-3- Description : Facilities for attaching metadata attributes to all spans in a trace- Maintainer : Ian Duncan- Stability : experimental- Portability : non-portable (GHC extensions)+A 'Resource' is an immutable set of attributes describing the entity that+produces telemetry: the service name, host, container, cloud environment, etc.+Every span, metric, and log record is associated with a resource. - A Resource is an immutable representation of the entity producing- telemetry. For example, a process producing telemetry that is running in- a container on Kubernetes has a Pod name, it is in a namespace and- possibly is part of a Deployment which also has a name. All three of- these attributes can be included in the Resource.+= Quick example++@+import OpenTelemetry.Resource++-- Build a resource from key-value pairs:+myResource :: Resource+myResource = mkResource+ [ "service.name" .= ("my-service" :: Text)+ , "service.version" .= ("1.2.0" :: Text)+ ]++-- Build from a typed data structure:+import OpenTelemetry.Resource.Service+myService :: Resource+myService = toResource Service+ { serviceName = "my-service"+ , serviceNamespace = Just "production"+ , serviceInstanceId = Nothing+ , serviceVersion = Just "1.2.0"+ , serviceCriticality = Nothing+ }+@++= Automatic detection++The SDK automatically detects resources from the environment (hostname, OS,+process info, container ID, cloud metadata). You can add your own on top:++@+(processors, opts) <- getTracerProviderInitializationOptions' myResource+@++= Merging++Resources can be combined with '<>' or 'mergeResources'. When keys conflict,+the first argument (the /updating/ resource) wins. Schema URLs are merged per the OTel spec.++= Spec reference++<https://opentelemetry.io/docs/specs/otel/resource/sdk/> -} module OpenTelemetry.Resource ( -- * Creating resources directly mkResource,+ mkResourceWithSchema,+ semConvSchemaUrl, Resource, (.=), (.=?),- ResourceMerge, mergeResources, -- * Creating resources from data structures ToResource (..),- MaterializeResource,- materializeResources, -- * Using resources with a 'OpenTelemetry.Trace.TracerProvider' MaterializedResources,+ materializeResources, emptyMaterializedResources, getMaterializedResourcesSchema, getMaterializedResourcesAttributes,++ -- * Convenience constructors+ materializeResourcesWithSchema,+ setMaterializedResourcesSchema,++ -- * Accessing resource fields+ getResourceAttributes,+ getResourceSchemaUrl, ) where import Data.Maybe (catMaybes)-import Data.Proxy (Proxy (..)) import Data.Text (Text)-import GHC.TypeLits+import qualified Data.Text as T import OpenTelemetry.Attributes+import OpenTelemetry.Internal.Logging (otelLogWarning)+import System.IO.Unsafe (unsafePerformIO) -{- | A set of attributes created from one or more resources.+{- | The OpenTelemetry semantic conventions schema URL for version 1.40.0.+Resources that use semantic convention attributes SHOULD carry this URL+so backends can perform automatic attribute migration across versions. - A Resource is an immutable representation of the entity producing telemetry as Attributes.- For example, a process producing telemetry that is running in a container on Kubernetes has a Pod name,- it is in a namespace and possibly is part of a Deployment which also has a name.+@since 0.4.0.0+-}+semConvSchemaUrl :: Text+semConvSchemaUrl = "https://opentelemetry.io/schemas/1.40.0" - All three of these attributes can be included in the Resource. - Note that there are certain <https://github.com/open-telemetry/opentelemetry-specification/blob/34144d02baaa39f7aa97ee914539089e1481166c/specification/resource/semantic_conventions/README.md "standard attributes"> that have prescribed meanings.+{- | A set of attributes with an optional schema URL. - A number of these standard resources may be found in the @OpenTelemetry.Resource.*@ modules.+A Resource is an immutable representation of the entity producing telemetry as+Attributes. For example, a process producing telemetry that is running in a+container on Kubernetes has a Pod name, it is in a namespace and possibly is+part of a Deployment which also has a name. - The primary purpose of resources as a first-class concept in the SDK is decoupling of discovery of resource information from exporters.- This allows for independent development and easy customization for users that need to integrate with closed source environments.+All three of these attributes can be included in the Resource.++Note that there are certain+<https://github.com/open-telemetry/opentelemetry-specification/blob/34144d02baaa39f7aa97ee914539089e1481166c/specification/resource/semantic_conventions/README.md "standard attributes">+that have prescribed meanings.++A number of these standard resources may be found in the @OpenTelemetry.Resource.*@ modules.++The primary purpose of resources as a first-class concept in the SDK is+decoupling of discovery of resource information from exporters. This allows for+independent development and easy customization for users that need to integrate+with closed source environments.++@since 0.0.1.0 -}-newtype Resource (schema :: Maybe Symbol) = Resource Attributes+data Resource = Resource+ { resourceSchemaUrl :: !(Maybe Text)+ , resourceAttributes :: !Attributes+ } +instance Show Resource where+ showsPrec d (Resource s a) =+ showParen (d > 10) $+ showString "Resource "+ . showsPrec 11 s+ . showChar ' '+ . showsPrec 11 a+++instance Eq Resource where+ Resource s1 a1 == Resource s2 a2 = s1 == s2 && a1 == a2++ {- | Utility function to create a resource from a list of fields and attributes. See the '.=' and '.=?' functions. @since 0.0.1.0 -}-mkResource :: [Maybe (Text, Attribute)] -> Resource r-mkResource = Resource . unsafeAttributesFromListIgnoringLimits . catMaybes+mkResource :: [Maybe (Text, Attribute)] -> Resource+mkResource = Resource Nothing . unsafeAttributesFromListIgnoringLimits . catMaybes +{- | Create a resource with an explicit schema URL.++@since 0.4.0.0+-}+mkResourceWithSchema :: Maybe Text -> [Maybe (Text, Attribute)] -> Resource+mkResourceWithSchema schema = Resource schema . unsafeAttributesFromListIgnoringLimits . catMaybes++ {- | Utility function to convert a required resource attribute into the format needed for 'mkResource'.++ @since 0.0.1.0 -} (.=) :: (ToAttribute a) => Text -> a -> Maybe (Text, Attribute) k .= v = Just (k, toAttribute v)@@ -88,92 +171,92 @@ {- | Utility function to convert an optional resource attribute into the format needed for 'mkResource'.++ @since 0.0.1.0 -} (.=?) :: (ToAttribute a) => Text -> Maybe a -> Maybe (Text, Attribute) k .=? mv = (\k' v -> (k', toAttribute v)) k <$> mv -- | Merge two resources, taking the left-biased union of attributes.-instance Semigroup (Resource s) where- (<>) (Resource l) (Resource r) = Resource (unsafeMergeAttributesIgnoringLimits l r)---instance Monoid (Resource s) where- mempty = Resource emptyAttributes+instance Semigroup Resource where+ (<>) = mergeResources -{- | Static checks to prevent invalid resources from being merged.-- Note: This is intended to be utilized for merging of resources whose attributes- come from different sources,- such as environment variables, or metadata extracted from the host or container.-- The resulting resource will have all attributes that are on any of the two input resources.- If a key exists on both the old and updating resource, the value of the updating- resource will be picked (even if the updated value is "empty").-- The resulting resource will have the Schema URL calculated as follows:-- - If the old resource's Schema URL is empty then the resulting resource's Schema- URL will be set to the Schema URL of the updating resource,- - Else if the updating resource's Schema URL is empty then the resulting- resource's Schema URL will be set to the Schema URL of the old resource,- - Else if the Schema URLs of the old and updating resources are the same then- that will be the Schema URL of the resulting resource,- - Else this is a merging error (this is the case when the Schema URL of the old- and updating resources are not empty and are different). The resulting resource is- therefore statically prohibited by this type-level function.--}-type family ResourceMerge (schemaLeft :: Maybe Symbol) (schemaRight :: Maybe Symbol) :: Maybe Symbol where- ResourceMerge 'Nothing a = a- ResourceMerge a 'Nothing = a- ResourceMerge ('Just s) ('Just s) = 'Just s+instance Monoid Resource where+ mempty = Resource Nothing emptyAttributes {- | Combine two 'Resource' values into a new 'Resource' that contains the attributes of the two inputs. - See the 'ResourceMerge' documentation about the additional semantics of merging two resources.+ If a key exists on both resources, the value of the first (updating)+ resource takes precedence. + Schema URL merge follows the OpenTelemetry specification:++ * If one resource's Schema URL is empty, the other's is used.+ * If both are the same, that URL is used.+ * If both are non-empty and different, the first resource's URL is kept+ (the spec says this case is \"implementation-specific\"); a warning is also+ emitted to the OTel diagnostic logger.+ @since 0.0.1.0 -} mergeResources- :: Resource new+ :: Resource -- ^ the updating resource whose attributes take precedence- -> Resource old+ -> Resource -- ^ the old resource- -> Resource (ResourceMerge new old)-mergeResources (Resource l) (Resource r) = Resource (unsafeMergeAttributesIgnoringLimits l r)+ -> Resource+mergeResources (Resource newSchema newAttrs) (Resource oldSchema oldAttrs) =+ Resource (mergeSchemaUrls newSchema oldSchema) (unsafeMergeAttributesIgnoringLimits newAttrs oldAttrs) --- | A convenience class for converting arbitrary data into resources.-class ToResource a where- -- | Resource schema (if any) associated with the defined resource- type ResourceSchema a :: Maybe Symbol+mergeSchemaUrls :: Maybe Text -> Maybe Text -> Maybe Text+mergeSchemaUrls Nothing b = b+mergeSchemaUrls a Nothing = a+mergeSchemaUrls a@(Just s1) (Just s2)+ | s1 == s2 = a+ | otherwise =+ unsafePerformIO $ do+ otelLogWarning ("Resource schema URL conflict: '" <> T.unpack s1 <> "' vs '" <> T.unpack s2 <> "'")+ pure a - type ResourceSchema a = 'Nothing-+{- | A convenience class for converting arbitrary data into resources. +@since 0.0.1.0+-}+class ToResource a where -- | Convert the input value to a 'Resource'- toResource :: a -> Resource (ResourceSchema a)+ toResource :: a -> Resource -class MaterializeResource schema where- -- | Convert resource fields into a version that discharges the schema from the- -- type level to the runtime level.- materializeResources :: Resource schema -> MaterializedResources+{- | Access the attributes of a resource. +@since 0.0.1.0+-}+getResourceAttributes :: Resource -> Attributes+getResourceAttributes = resourceAttributes -instance MaterializeResource 'Nothing where- materializeResources (Resource attrs) = MaterializedResources Nothing attrs +{- | Access the schema URL of a resource. -instance (KnownSymbol s) => MaterializeResource ('Just s) where- materializeResources (Resource attrs) = MaterializedResources (Just $ symbolVal (Proxy @s)) attrs+@since 0.0.1.0+-}+getResourceSchemaUrl :: Resource -> Maybe Text+getResourceSchemaUrl = resourceSchemaUrl --- | A read-only resource attribute collection with an associated schema.+{- | A read-only resource attribute collection with an associated schema.++@since 0.0.1.0+-}++-- \| Convert resource fields into a version that discharges the schema from the+-- type level to the runtime level.+-- data MaterializedResources = MaterializedResources { materializedResourcesSchema :: Maybe String , materializedResourcesAttributes :: Attributes@@ -204,3 +287,36 @@ -} getMaterializedResourcesAttributes :: MaterializedResources -> Attributes getMaterializedResourcesAttributes = materializedResourcesAttributes+++{- | Convert a 'Resource' to 'MaterializedResources'.++@since 0.0.1.0+-}+materializeResources :: Resource -> MaterializedResources+materializeResources (Resource mSchema attrs) =+ MaterializedResources (T.unpack <$> mSchema) attrs+++{- | Materialize a resource with an explicit runtime schema URL,+overriding any schema URL on the resource itself.++@+let res = materializeResourcesWithSchema+ (Just "https:\/\/opentelemetry.io\/schemas\/1.25.0")+ (mkResource ["service.name" .= ("my-app" :: Text)])+@++@since 0.4.0.0+-}+materializeResourcesWithSchema :: Maybe String -> Resource -> MaterializedResources+materializeResourcesWithSchema schema (Resource _ attrs) = MaterializedResources schema attrs+++{- | Override the schema URL on an already-materialized resource.+Replaces any previously set schema URL.++@since 0.4.0.0+-}+setMaterializedResourcesSchema :: Maybe String -> MaterializedResources -> MaterializedResources+setMaterializedResourcesSchema schema mr = mr {materializedResourcesSchema = schema}
src/OpenTelemetry/Resource/Cloud.hs view
@@ -1,10 +1,3 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeFamilies #-}--------------------------------------------------------------------------------------------------------------------------------------------------------------- {- | Module : OpenTelemetry.Resource.Cloud Copyright : (c) Ian Duncan, 2021@@ -21,31 +14,37 @@ ) where import Data.Text (Text)-import OpenTelemetry.Resource (ToResource (..), mkResource, (.=?))+import OpenTelemetry.Attributes.Key (unkey)+import OpenTelemetry.Resource (ToResource (..), mkResourceWithSchema, semConvSchemaUrl, (.=?))+import qualified OpenTelemetry.SemanticConventions as SC --- | A cloud infrastructure (e.g. GCP, Azure, AWS).+{- | A cloud infrastructure (e.g. GCP, Azure, AWS).++@since 0.0.1.0+-} data Cloud = Cloud { cloudProvider :: Maybe Text- -- ^ Name of the cloud provider.- --- -- Examples: @alibaba_cloud@- --- -- cloud.provider MUST be one of the following or, if none of the listed values apply, a custom value:- --- -- +------------------+------------------------+- -- | Value | Description |- -- +==================+========================+- -- | @alibaba_cloud@ | Alibaba Cloud |- -- +------------------+------------------------+- -- | @aws@ | Amazon Web Services |- -- +------------------+------------------------+- -- | @azure@ | Microsoft Azure |- -- +------------------+------------------------+- -- | @gcp@ | Google Cloud Platform |- -- +------------------+------------------------+- -- | @tencent_cloud@ | Tencent Cloud |- -- +------------------+------------------------++ {- ^ Name of the cloud provider.++ Examples: @alibaba_cloud@++ cloud.provider MUST be one of the following or, if none of the listed values apply, a custom value:++ +------------------+------------------------++ | Value | Description |+ +==================+========================++ | @alibaba_cloud@ | Alibaba Cloud |+ +------------------+------------------------++ | @aws@ | Amazon Web Services |+ +------------------+------------------------++ | @azure@ | Microsoft Azure |+ +------------------+------------------------++ | @gcp@ | Google Cloud Platform |+ +------------------+------------------------++ | @tencent_cloud@ | Tencent Cloud |+ +------------------+------------------------++ -} , cloudAccountId :: Maybe Text -- ^ The cloud account ID the resource is assigned to. , cloudRegion :: Maybe Text@@ -53,67 +52,71 @@ , cloudAvailabilityZone :: Maybe Text -- ^ Cloud regions often have multiple, isolated locations known as zones to increase availability. Availability zone represents the zone where the resource is running. , cloudPlatform :: Maybe Text- -- ^ The cloud platform in use.- --- -- Example: @alibaba_cloud_ecs@- --- -- MUST be one of the following or, if none of the listed values apply, a custom value:- --- -- +------------------------------+-------------------------------------------------+- -- | Value | Description |- -- +==============================+=================================================+- -- | @alibaba_cloud_ecs@ | Alibaba Cloud Elastic Compute Service |- -- +------------------------------+-------------------------------------------------+- -- | @alibaba_cloud_fc@ | Alibaba Cloud Function Compute |- -- +------------------------------+-------------------------------------------------+- -- | @aws_ec2@ | AWS Elastic Compute Cloud |- -- +------------------------------+-------------------------------------------------+- -- | @aws_ecs@ | AWS Elastic Container Service |- -- +------------------------------+-------------------------------------------------+- -- | @aws_eks@ | AWS Elastic Kubernetes Service |- -- +------------------------------+-------------------------------------------------+- -- | @aws_lambda@ | AWS Lambda |- -- +------------------------------+-------------------------------------------------+- -- | @aws_elastic_beanstalk@ | AWS Elastic Beanstalk |- -- +------------------------------+-------------------------------------------------+- -- | @aws_app_runner@ | AWS App Runner |- -- +------------------------------+-------------------------------------------------+- -- | @azure_vm@ | Azure Virtual Machines |- -- +------------------------------+-------------------------------------------------+- -- | @azure_container_instances@ | Azure Container Instances |- -- +------------------------------+-------------------------------------------------+- -- | @azure_aks@ | Azure Kubernetes Service |- -- +------------------------------+-------------------------------------------------+- -- | @azure_functions@ | Azure Functions |- -- +------------------------------+-------------------------------------------------+- -- | @azure_app_service@ | Azure App Service |- -- +------------------------------+-------------------------------------------------+- -- | @gcp_compute_engine@ | Google Cloud Compute Engine (GCE) |- -- +------------------------------+-------------------------------------------------+- -- | @gcp_cloud_run@ | Google Cloud Run |- -- +------------------------------+-------------------------------------------------+- -- | @gcp_kubernetes_engine@ | Google Cloud Kubernetes Engine (GKE) |- -- +------------------------------+-------------------------------------------------+- -- | @gcp_cloud_functions@ | Google Cloud Functions (GCF) |- -- +------------------------------+-------------------------------------------------+- -- | @gcp_app_engine@ | Google Cloud App Engine (GAE) |- -- +------------------------------+-------------------------------------------------+- -- | @tencent_cloud_cvm@ | Tencent Cloud Cloud Virtual Machine (CVM) |- -- +------------------------------+-------------------------------------------------+- -- | @tencent_cloud_eks@ | Tencent Cloud Elastic Kubernetes Service (EKS) |- -- +------------------------------+-------------------------------------------------+- -- | @tencent_cloud_scf@ | Tencent Cloud Serverless Cloud Function (SCF) |- -- +------------------------------+-------------------------------------------------++ {- ^ The cloud platform in use.++ Example: @alibaba_cloud_ecs@++ MUST be one of the following or, if none of the listed values apply, a custom value:++ +------------------------------+-------------------------------------------------++ | Value | Description |+ +==============================+=================================================++ | @alibaba_cloud_ecs@ | Alibaba Cloud Elastic Compute Service |+ +------------------------------+-------------------------------------------------++ | @alibaba_cloud_fc@ | Alibaba Cloud Function Compute |+ +------------------------------+-------------------------------------------------++ | @aws_ec2@ | AWS Elastic Compute Cloud |+ +------------------------------+-------------------------------------------------++ | @aws_ecs@ | AWS Elastic Container Service |+ +------------------------------+-------------------------------------------------++ | @aws_eks@ | AWS Elastic Kubernetes Service |+ +------------------------------+-------------------------------------------------++ | @aws_lambda@ | AWS Lambda |+ +------------------------------+-------------------------------------------------++ | @aws_elastic_beanstalk@ | AWS Elastic Beanstalk |+ +------------------------------+-------------------------------------------------++ | @aws_app_runner@ | AWS App Runner |+ +------------------------------+-------------------------------------------------++ | @azure_vm@ | Azure Virtual Machines |+ +------------------------------+-------------------------------------------------++ | @azure_container_instances@ | Azure Container Instances |+ +------------------------------+-------------------------------------------------++ | @azure_aks@ | Azure Kubernetes Service |+ +------------------------------+-------------------------------------------------++ | @azure_functions@ | Azure Functions |+ +------------------------------+-------------------------------------------------++ | @azure_app_service@ | Azure App Service |+ +------------------------------+-------------------------------------------------++ | @gcp_compute_engine@ | Google Cloud Compute Engine (GCE) |+ +------------------------------+-------------------------------------------------++ | @gcp_cloud_run@ | Google Cloud Run |+ +------------------------------+-------------------------------------------------++ | @gcp_kubernetes_engine@ | Google Cloud Kubernetes Engine (GKE) |+ +------------------------------+-------------------------------------------------++ | @gcp_cloud_functions@ | Google Cloud Functions (GCF) |+ +------------------------------+-------------------------------------------------++ | @gcp_app_engine@ | Google Cloud App Engine (GAE) |+ +------------------------------+-------------------------------------------------++ | @tencent_cloud_cvm@ | Tencent Cloud Cloud Virtual Machine (CVM) |+ +------------------------------+-------------------------------------------------++ | @tencent_cloud_eks@ | Tencent Cloud Elastic Kubernetes Service (EKS) |+ +------------------------------+-------------------------------------------------++ | @tencent_cloud_scf@ | Tencent Cloud Serverless Cloud Function (SCF) |+ +------------------------------+-------------------------------------------------++ -}+ , cloudResourceId :: Maybe Text+ -- ^ Cloud provider-specific native identifier of the monitored cloud resource. } instance ToResource Cloud where- type ResourceSchema Cloud = 'Nothing toResource Cloud {..} =- mkResource- [ "cloud.provider" .=? cloudProvider- , "cloud.account.id" .=? cloudAccountId- , "cloud.region" .=? cloudRegion- , "cloud.availability_zone" .=? cloudAvailabilityZone- , "cloud.platform" .=? cloudPlatform+ mkResourceWithSchema+ (Just semConvSchemaUrl)+ [ unkey SC.cloud_provider .=? cloudProvider+ , unkey SC.cloud_account_id .=? cloudAccountId+ , unkey SC.cloud_region .=? cloudRegion+ , unkey SC.cloud_availabilityZone .=? cloudAvailabilityZone+ , unkey SC.cloud_platform .=? cloudPlatform+ , unkey SC.cloud_resourceId .=? cloudResourceId ]
src/OpenTelemetry/Resource/Container.hs view
@@ -1,10 +1,3 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeFamilies #-}--------------------------------------------------------------------------------------------------------------------------------------------------------------- {- | Module : OpenTelemetry.Resource.Container Copyright : (c) Ian Duncan, 2021@@ -17,15 +10,21 @@ module OpenTelemetry.Resource.Container where import Data.Text (Text)+import OpenTelemetry.Attributes.Key (unkey) import OpenTelemetry.Resource+import qualified OpenTelemetry.SemanticConventions as SC --- | A container instance.+{- | A container instance.++@since 0.0.1.0+-} data Container = Container { containerName :: Maybe Text- -- ^ Container name used by container runtime.- --- -- Examples: 'opentelemetry-autoconf'+ {- ^ Container name used by container runtime.++ Examples: 'opentelemetry-autoconf'+ -} , containerId :: Maybe Text -- ^ Container ID. Usually a UUID, as for example used to identify Docker containers. The UUID might be abbreviated. , containerRuntime :: Maybe Text@@ -34,16 +33,26 @@ -- ^ Name of the image the container was built on. , containerImageTag :: Maybe Text -- ^ Container image tag.+ , containerImageId :: Maybe Text+ -- ^ Runtime-specific image identifier (e.g., digest).+ , ociManifestDigest :: Maybe Text+ -- ^ The digest of the OCI image manifest.+ , containerImageRepoDigests :: Maybe [Text]+ -- ^ Repo digests of the container image. } instance ToResource Container where- type ResourceSchema Container = 'Nothing toResource Container {..} =- mkResource- [ "container.name" .=? containerName- , "container.id" .=? containerId- , "container.runtime" .=? containerRuntime- , "container.image.name" .=? containerImageName- , "container.image.tag" .=? containerImageTag+ mkResourceWithSchema+ (Just semConvSchemaUrl)+ [ unkey SC.container_name .=? containerName+ , unkey SC.container_id .=? containerId+ , unkey SC.container_runtime_name .=? containerRuntime+ , unkey SC.container_runtime .=? containerRuntime+ , unkey SC.container_image_name .=? containerImageName+ , unkey SC.container_image_id .=? containerImageId+ , unkey SC.container_image_tags .=? ((: []) <$> containerImageTag)+ , unkey SC.oci_manifest_digest .=? ociManifestDigest+ , unkey SC.container_image_repoDigests .=? containerImageRepoDigests ]
src/OpenTelemetry/Resource/DeploymentEnvironment.hs view
@@ -1,10 +1,3 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeFamilies #-}--------------------------------------------------------------------------------------------------------------------------------------------------------------- {- | Module : OpenTelemetry.Resource.DeploymentEnvironment Copyright : (c) Ian Duncan, 2021@@ -17,7 +10,9 @@ module OpenTelemetry.Resource.DeploymentEnvironment where import Data.Text (Text)+import OpenTelemetry.Attributes.Key (unkey) import OpenTelemetry.Resource+import qualified OpenTelemetry.SemanticConventions as SC {- | The software deployment.@@ -25,18 +20,24 @@ This resource doesn't have a an automatic detector because deployment environments tend to have very different detection mechanisms for differing projects.++ @since 0.0.1.0 -} newtype DeploymentEnvironment = DeploymentEnvironment { deploymentEnvironment :: Maybe Text- -- ^ Name of the deployment environment (aka deployment tier).- --- -- Examples: @staging@, @production@+ {- ^ Name of the deployment environment (aka deployment tier).++ Examples: @staging@, @production@+ -} } instance ToResource DeploymentEnvironment where- type ResourceSchema DeploymentEnvironment = 'Nothing+ -- 'deployment.environment' is deprecated in favor of 'deployment.environment.name';+ -- we emit both for backward compatibility with older consumers. toResource DeploymentEnvironment {..} =- mkResource- [ "deployment.environment" .=? deploymentEnvironment+ mkResourceWithSchema+ (Just semConvSchemaUrl)+ [ unkey SC.deployment_environment_name .=? deploymentEnvironment+ , unkey SC.deployment_environment .=? deploymentEnvironment ]
src/OpenTelemetry/Resource/Device.hs view
@@ -1,7 +1,3 @@-------------------------------------------------------------------------------------------------------------------------------------------------------------- {- | Module : OpenTelemetry.Resource.Device Copyright : (c) Ian Duncan, 2021
src/OpenTelemetry/Resource/FaaS.hs view
@@ -1,13 +1,6 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeFamilies #-}--------------------------------------------------------------------------------------------------------------------------------------------------------------- {- | Module : OpenTelemetry.Resource.FaaS- Copyright : (c) Ian Duncan, 2021+ Copyright : (c) Ian Duncan, 2026 License : BSD-3 Description : Resource information about a "function as a service" aka "serverless function" instance Maintainer : Ian Duncan@@ -17,60 +10,71 @@ module OpenTelemetry.Resource.FaaS where import Data.Text (Text)+import OpenTelemetry.Attributes.Key (unkey) import OpenTelemetry.Resource+import qualified OpenTelemetry.SemanticConventions as SC --- | A "function as a service" aka "serverless function" instance.+{- | A "function as a service" aka "serverless function" instance.++@since 0.0.1.0+-} data FaaS = FaaS { faasName :: Text- -- ^ The name of the single function that this runtime instance executes.- --- -- This is the name of the function as configured/deployed on the FaaS platform and is usually different from the name of the callback function (which may be stored in the code.namespace/code.function span attributes).- --- -- Examples: 'my-function'- , faasId :: Maybe Text- -- ^ The unique ID of the single function that this runtime instance executes.- --- -- Depending on the cloud provider, use:- --- -- - AWS Lambda: The function ARN. Take care not to use the "invoked ARN" directly but replace any alias suffix with the resolved function version, as the same runtime instance may be invokable with multiple different aliases.- -- - GCP: The URI of the resource- -- - Azure: The Fully Qualified Resource ID.- --- -- Examples: 'arn:aws:lambda:us-west-2:123456789012:function:my-function'+ {- ^ The name of the single function that this runtime instance executes.++ This is the name of the function as configured/deployed on the FaaS platform and is usually different from the name of the callback function (which may be stored in the code.namespace/code.function span attributes).++ Examples: 'my-function'+ -}+ , faasCloudResourceId :: Maybe Text+ {- ^ The cloud resource ID (@cloud.resource_id@) of the function.++ Depending on the cloud provider, use:++ - AWS Lambda: The function ARN.+ - GCP: The URI of the resource+ - Azure: The Fully Qualified Resource ID.++ Examples: 'arn:aws:lambda:us-west-2:123456789012:function:my-function'+ -} , faasVersion :: Maybe Text- -- ^ The immutable version of the function being executed.- --- -- Depending on the cloud provider and platform, use:- --- -- - AWS Lambda: The function version (an integer represented as a decimal string).- -- - Google Cloud Run: The revision (i.e., the function name plus the revision suffix).- -- - Google Cloud Functions: The value of the K_REVISION environment variable.- -- - Azure Functions: Not applicable. Do not set this attribute.- --- -- Examples: '26', 'pinkfroid-00002'+ {- ^ The immutable version of the function being executed.++ Depending on the cloud provider and platform, use:++ - AWS Lambda: The function version (an integer represented as a decimal string).+ - Google Cloud Run: The revision (i.e., the function name plus the revision suffix).+ - Google Cloud Functions: The value of the K_REVISION environment variable.+ - Azure Functions: Not applicable. Do not set this attribute.++ Examples: '26', 'pinkfroid-00002'+ -} , faasInstance :: Maybe Text- -- ^ The execution environment ID as a string, that will be potentially reused for other invocations to the same function/function version.- --- -- AWS Lambda: Use the (full) log stream name.- --- -- Examples: '2021/06/28/[$LATEST]2f399eb14537447da05ab2a2e39309de'+ {- ^ The execution environment ID as a string, that will be potentially reused for other invocations to the same function/function version.++ AWS Lambda: Use the (full) log stream name.++ Examples: '2021/06/28/[$LATEST]2f399eb14537447da05ab2a2e39309de'+ -} , faasMaxMemory :: Maybe Int- -- ^ The amount of memory available to the serverless function in MiB.- --- -- It's recommended to set this attribute since e.g. too little memory can easily an AWS Lambda function from working correctly. On AWS Lambda, the environment variable AWS_LAMBDA_FUNCTION_MEMORY_SIZE provides this information.- --- -- Examples: '128'+ {- ^ The amount of memory available to the serverless function converted to bytes.++ It's recommended to set this attribute since e.g. too little memory can easily stop an AWS Lambda function from working correctly. On AWS Lambda, the environment variable AWS_LAMBDA_FUNCTION_MEMORY_SIZE provides this information (which must be multiplied by 1,048,576).++ Examples: '134217728'+ -} }+ deriving (Show) instance ToResource FaaS where- type ResourceSchema FaaS = 'Nothing toResource FaaS {..} =- mkResource- [ "faas.name" .= faasName- , "faas.id" .=? faasId- , "faas.version" .=? faasVersion- , "faas.instance" .=? faasInstance- , "faas.max_memory" .=? faasMaxMemory+ mkResourceWithSchema+ (Just semConvSchemaUrl)+ [ unkey SC.faas_name .= faasName+ , unkey SC.cloud_resourceId .=? faasCloudResourceId+ , unkey SC.faas_version .=? faasVersion+ , unkey SC.faas_instance .=? faasInstance+ , unkey SC.faas_maxMemory .=? faasMaxMemory ]
src/OpenTelemetry/Resource/Host.hs view
@@ -1,10 +1,3 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeFamilies #-}--------------------------------------------------------------------------------------------------------------------------------------------------------------- {- | Module : OpenTelemetry.Resource.Host Copyright : (c) Ian Duncan, 2021@@ -19,10 +12,15 @@ ) where import Data.Text (Text)-import OpenTelemetry.Resource (ToResource (..), mkResource, (.=?))+import OpenTelemetry.Attributes.Key (unkey)+import OpenTelemetry.Resource (ToResource (..), mkResourceWithSchema, semConvSchemaUrl, (.=?))+import qualified OpenTelemetry.SemanticConventions as SC --- | A host is defined as a general computing instance.+{- | A host is defined as a general computing instance.++@since 0.0.1.0+-} data Host = Host { hostId :: Maybe Text -- ^ Unique host ID. For Cloud, this must be the instance_id assigned by the cloud provider.@@ -38,18 +36,24 @@ -- ^ VM image ID. For Cloud, this value is from the provider. , hostImageVersion :: Maybe Text -- ^ The version string of the VM image as defined in Version Attributes.+ , hostIp :: Maybe [Text]+ -- ^ Host IP addresses.+ , hostMac :: Maybe [Text]+ -- ^ MAC addresses of the host. } instance ToResource Host where- type ResourceSchema Host = 'Nothing toResource Host {..} =- mkResource- [ "host.id" .=? hostId- , "host.name" .=? hostName- , "host.type" .=? hostType- , "host.arch" .=? hostArch- , "host.image.name" .=? hostImageName- , "host.image.id" .=? hostImageId- , "host.image.version" .=? hostImageVersion+ mkResourceWithSchema+ (Just semConvSchemaUrl)+ [ unkey SC.host_id .=? hostId+ , unkey SC.host_name .=? hostName+ , unkey SC.host_type .=? hostType+ , unkey SC.host_arch .=? hostArch+ , unkey SC.host_image_name .=? hostImageName+ , unkey SC.host_image_id .=? hostImageId+ , unkey SC.host_image_version .=? hostImageVersion+ , unkey SC.host_ip .=? hostIp+ , unkey SC.host_mac .=? hostMac ]
src/OpenTelemetry/Resource/Kubernetes.hs view
@@ -1,10 +1,3 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeFamilies #-}--------------------------------------------------------------------------------------------------------------------------------------------------------------- {- | Module : OpenTelemetry.Resource.Kubernetes Copyright : (c) Ian Duncan, 2021@@ -17,73 +10,98 @@ module OpenTelemetry.Resource.Kubernetes where import Data.Text (Text)+import OpenTelemetry.Attributes.Key (unkey) import OpenTelemetry.Resource+import qualified OpenTelemetry.SemanticConventions as SC --- | A Kubernetes Cluster.-newtype Cluster = Cluster+{- | A Kubernetes Cluster.++@since 0.0.1.0+-}+data Cluster = Cluster { clusterName :: Maybe Text -- ^ The name of the cluster.+ , clusterUid :: Maybe Text+ -- ^ The UID of the cluster. }+ deriving (Show) instance ToResource Cluster where- type ResourceSchema Cluster = 'Nothing toResource Cluster {..} =- mkResource- ["k8s.cluster.name" .=? clusterName]+ mkResourceWithSchema+ (Just semConvSchemaUrl)+ [ unkey SC.k8s_cluster_name .=? clusterName+ , unkey SC.k8s_cluster_uid .=? clusterUid+ ] --- | A Kubernetes Node.+{- | A Kubernetes Node.++@since 0.0.1.0+-} data Node = Node { nodeName :: Maybe Text , nodeUid :: Maybe Text }+ deriving (Show) instance ToResource Node where- type ResourceSchema Node = 'Nothing toResource Node {..} =- mkResource- [ "k8s.node.name" .=? nodeName- , "k8s.node.uid" .=? nodeUid+ mkResourceWithSchema+ (Just semConvSchemaUrl)+ [ unkey SC.k8s_node_name .=? nodeName+ , unkey SC.k8s_node_uid .=? nodeUid ] --- | Namespaces provide a scope for names. Names of objects need to be unique within a namespace, but not across namespaces.+{- | Namespaces provide a scope for names. Names of objects need to be unique within a namespace, but not across namespaces.++@since 0.0.1.0+-} newtype Namespace = Namespace { namespaceName :: Maybe Text -- ^ The name of the namespace that the pod is running in. }+ deriving (Show) instance ToResource Namespace where- type ResourceSchema Namespace = 'Nothing toResource Namespace {..} =- mkResource- [ "k8s.namespace.name" .=? namespaceName+ mkResourceWithSchema+ (Just semConvSchemaUrl)+ [ unkey SC.k8s_namespace_name .=? namespaceName ] --- | The smallest and simplest Kubernetes object. A Pod represents a set of running containers on your cluster.+{- | The smallest and simplest Kubernetes object. A Pod represents a set of running containers on your cluster.++@since 0.0.1.0+-} data Pod = Pod { podName :: Maybe Text -- ^ The name of the Pod. , podUid :: Maybe Text -- ^ The UID of the Pod. }+ deriving (Show) instance ToResource Pod where- type ResourceSchema Pod = 'Nothing toResource Pod {..} =- mkResource- [ "k8s.pod.name" .=? podName- , "k8s.pod.uid" .=? podUid+ mkResourceWithSchema+ (Just semConvSchemaUrl)+ [ unkey SC.k8s_pod_name .=? podName+ , unkey SC.k8s_pod_uid .=? podUid ] --- | A container in a PodTemplate.+{- | A container in a PodTemplate.++@since 0.0.1.0+-} data Container = Container { containerName :: Maybe Text -- ^ The name of the Container from Pod specification, must be unique within a Pod. Container runtime usually uses different globally unique name (container.name).@@ -93,15 +111,18 @@ instance ToResource Container where- type ResourceSchema Container = 'Nothing toResource Container {..} =- mkResource- [ "k8s.container.name" .=? containerName- , "k8s.container.restart_count" .=? containerRestartCount+ mkResourceWithSchema+ (Just semConvSchemaUrl)+ [ unkey SC.k8s_container_name .=? containerName+ , unkey SC.k8s_container_restartCount .=? containerRestartCount ] --- | A ReplicaSet’s purpose is to maintain a stable set of replica Pods running at any given time.+{- | A ReplicaSet’s purpose is to maintain a stable set of replica Pods running at any given time.++@since 0.0.1.0+-} data ReplicaSet = ReplicaSet { replicaSetUid :: Maybe Text , replicaSetName :: Maybe Text@@ -109,15 +130,18 @@ instance ToResource ReplicaSet where- type ResourceSchema ReplicaSet = 'Nothing toResource ReplicaSet {..} =- mkResource- [ "k8s.replicaset.name" .=? replicaSetName- , "k8s.replicaset.uid" .=? replicaSetUid+ mkResourceWithSchema+ (Just semConvSchemaUrl)+ [ unkey SC.k8s_replicaset_name .=? replicaSetName+ , unkey SC.k8s_replicaset_uid .=? replicaSetUid ] --- | An API object that manages a replicated application, typically by running Pods with no local state. Each replica is represented by a Pod, and the Pods are distributed among the nodes of a cluster.+{- | An API object that manages a replicated application, typically by running Pods with no local state. Each replica is represented by a Pod, and the Pods are distributed among the nodes of a cluster.++@since 0.0.1.0+-} data Deployment = Deployment { deploymentUid :: Maybe Text -- ^ The UID of the Deployment.@@ -127,15 +151,18 @@ instance ToResource Deployment where- type ResourceSchema Deployment = 'Nothing toResource Deployment {..} =- mkResource- [ "k8s.deployment.name" .=? deploymentName- , "k8s.deployment.uid" .=? deploymentUid+ mkResourceWithSchema+ (Just semConvSchemaUrl)+ [ unkey SC.k8s_deployment_name .=? deploymentName+ , unkey SC.k8s_deployment_uid .=? deploymentUid ] --- | Manages the deployment and scaling of a set of Pods, and provides guarantees about the ordering and uniqueness of these Pods.+{- | Manages the deployment and scaling of a set of Pods, and provides guarantees about the ordering and uniqueness of these Pods.++@since 0.0.1.0+-} data StatefulSet = StatefulSet { statefulSetUid :: Maybe Text -- ^ The UID of the StatefulSet.@@ -145,15 +172,18 @@ instance ToResource StatefulSet where- type ResourceSchema StatefulSet = 'Nothing toResource StatefulSet {..} =- mkResource- [ "k8s.statefulset.name" .=? statefulSetName- , "k8s.statefulset.uid" .=? statefulSetUid+ mkResourceWithSchema+ (Just semConvSchemaUrl)+ [ unkey SC.k8s_statefulset_name .=? statefulSetName+ , unkey SC.k8s_statefulset_uid .=? statefulSetUid ] --- | A DaemonSet ensures that all (or some) Nodes run a copy of a Pod.+{- | A DaemonSet ensures that all (or some) Nodes run a copy of a Pod.++@since 0.0.1.0+-} data DaemonSet = DaemonSet { daemonSetUid :: Maybe Text -- ^ The UID of the DaemonSet.@@ -163,15 +193,18 @@ instance ToResource DaemonSet where- type ResourceSchema DaemonSet = 'Nothing toResource DaemonSet {..} =- mkResource- [ "k8s.daemonset.name" .=? daemonSetName- , "k8s.daemonset.uid" .=? daemonSetUid+ mkResourceWithSchema+ (Just semConvSchemaUrl)+ [ unkey SC.k8s_daemonset_name .=? daemonSetName+ , unkey SC.k8s_daemonset_uid .=? daemonSetUid ] --- | A Job creates one or more Pods and ensures that a specified number of them successfully terminate.+{- | A Job creates one or more Pods and ensures that a specified number of them successfully terminate.++@since 0.0.1.0+-} data Job = Job { jobUid :: Maybe Text -- ^ The UID of the Job.@@ -181,15 +214,18 @@ instance ToResource Job where- type ResourceSchema Job = 'Nothing toResource Job {..} =- mkResource- [ "k8s.job.name" .=? jobName- , "k8s.job.uid" .=? jobUid+ mkResourceWithSchema+ (Just semConvSchemaUrl)+ [ unkey SC.k8s_job_name .=? jobName+ , unkey SC.k8s_job_uid .=? jobUid ] --- | A CronJob creates Jobs on a repeating schedule.+{- | A CronJob creates Jobs on a repeating schedule.++@since 0.0.1.0+-} data CronJob = CronJob { cronJobUid :: Maybe Text -- ^ The UID of the CronJob.@@ -199,9 +235,9 @@ instance ToResource CronJob where- type ResourceSchema CronJob = 'Nothing toResource CronJob {..} =- mkResource- [ "k8s.cronjob.name" .=? cronJobName- , "k8s.cronjob.uid" .=? cronJobUid+ mkResourceWithSchema+ (Just semConvSchemaUrl)+ [ unkey SC.k8s_cronjob_name .=? cronJobName+ , unkey SC.k8s_cronjob_uid .=? cronJobUid ]
src/OpenTelemetry/Resource/OperatingSystem.hs view
@@ -1,10 +1,3 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeFamilies #-}--------------------------------------------------------------------------------------------------------------------------------------------------------------- {- | Module : OpenTelemetry.Resource.OperatingSystem Copyright : (c) Ian Duncan, 2021@@ -19,59 +12,65 @@ module OpenTelemetry.Resource.OperatingSystem where import Data.Text (Text)+import OpenTelemetry.Attributes.Key (unkey) import OpenTelemetry.Resource+import qualified OpenTelemetry.SemanticConventions as SC --- | The operating system (OS) on which the process represented by this resource is running.+{- | The operating system (OS) on which the process represented by this resource is running.++@since 0.0.1.0+-} data OperatingSystem = OperatingSystem { osType :: Text- -- ^ The operating system type.- --- -- MUST be one of the following or, if none of the listed values apply, a custom value:- --- -- +-----------------+---------------------------------------+- -- | Value | Description |- -- +=================+=======================================+- -- | @windows@ | Microsoft Windows |- -- +-----------------+---------------------------------------+- -- | @linux@ | Linux |- -- +-----------------+---------------------------------------+- -- | @darwin@ | Apple Darwin |- -- +-----------------+---------------------------------------+- -- | @freebsd@ | FreeBSD |- -- +-----------------+---------------------------------------+- -- | @netbsd@ | NetBSD |- -- +-----------------+---------------------------------------+- -- | @openbsd@ | OpenBSD |- -- +-----------------+---------------------------------------+- -- | @dragonflybsd@ | DragonFly BSD |- -- +-----------------+---------------------------------------+- -- | @hpux@ | HP-UX (Hewlett Packard Unix) |- -- +-----------------+---------------------------------------+- -- | @aix@ | AIX (Advanced Interactive eXecutive) |- -- +-----------------+---------------------------------------+- -- | @solaris@ | Oracle Solaris |- -- +-----------------+---------------------------------------+- -- | @z_os@ | IBM z/OS |- -- +-----------------+---------------------------------------++ {- ^ The operating system type.++ MUST be one of the following or, if none of the listed values apply, a custom value:++ +-----------------+---------------------------------------++ | Value | Description |+ +=================+=======================================++ | @windows@ | Microsoft Windows |+ +-----------------+---------------------------------------++ | @linux@ | Linux |+ +-----------------+---------------------------------------++ | @darwin@ | Apple Darwin |+ +-----------------+---------------------------------------++ | @freebsd@ | FreeBSD |+ +-----------------+---------------------------------------++ | @netbsd@ | NetBSD |+ +-----------------+---------------------------------------++ | @openbsd@ | OpenBSD |+ +-----------------+---------------------------------------++ | @dragonflybsd@ | DragonFly BSD |+ +-----------------+---------------------------------------++ | @hpux@ | HP-UX (Hewlett Packard Unix) |+ +-----------------+---------------------------------------++ | @aix@ | AIX (Advanced Interactive eXecutive) |+ +-----------------+---------------------------------------++ | @solaris@ | Oracle Solaris |+ +-----------------+---------------------------------------++ | @zos@ | IBM z/OS |+ +-----------------+---------------------------------------++ -} , osDescription :: Maybe Text -- ^ Human readable (not intended to be parsed) OS version information, like e.g. reported by @ver@ or @lsb_release -a@ commands. , osName :: Maybe Text -- ^ Human readable operating system name. , osVersion :: Maybe Text -- ^ The version string of the operating system as defined in+ , osBuildId :: Maybe Text+ -- ^ Unique identifier for a particular build or compilation of the operating system. } instance ToResource OperatingSystem where- type ResourceSchema OperatingSystem = 'Nothing--- -- TODO ^ schema toResource OperatingSystem {..} =- mkResource- [ "os.type" .= osType- , "os.description" .=? osDescription- , "os.name" .=? osName- , "os.version" .=? osVersion+ mkResourceWithSchema+ (Just semConvSchemaUrl)+ [ unkey SC.os_type .= osType+ , unkey SC.os_description .=? osDescription+ , unkey SC.os_name .=? osName+ , unkey SC.os_version .=? osVersion+ , unkey SC.os_buildId .=? osBuildId ]
src/OpenTelemetry/Resource/Process.hs view
@@ -1,11 +1,3 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeFamilies #-}--------------------------------------------------------------------------------------------------------------------------------------------------------------- {- | Module : OpenTelemetry.Resource.Process Copyright : (c) Ian Duncan, 2021@@ -18,78 +10,120 @@ module OpenTelemetry.Resource.Process where import Data.Text (Text)+import OpenTelemetry.Attributes.Key (unkey) import OpenTelemetry.Resource+import qualified OpenTelemetry.SemanticConventions as SC --- | An operating system process.+{- | An operating system process.++@since 0.0.1.0+-} data Process = Process { processPid :: Maybe Int- -- ^ Process identifier (PID).- --- -- Example: @1234@+ {- ^ Process identifier (PID).++ Example: @1234@+ -} , processExecutableName :: Maybe Text- -- ^ The name of the process executable. On Linux based systems, can be set to the @Name@ in @proc/[pid]/status@. On Windows, can be set to the base name of @GetProcessImageFileNameW@.- --- -- Example: @otelcol@+ {- ^ The name of the process executable. On Linux based systems, can be set to the @Name@ in @proc/[pid]/status@. On Windows, can be set to the base name of @GetProcessImageFileNameW@.++ Example: @otelcol@+ -} , processExecutablePath :: Maybe Text- -- ^ The full path to the process executable. On Linux based systems, can be set to the target of @proc/[pid]/exe@. On Windows, can be set to the result of @GetProcessImageFileNameW@.- --- -- Example: @/usr/bin/cmd/otelcol@+ {- ^ The full path to the process executable. On Linux based systems, can be set to the target of @proc/[pid]/exe@. On Windows, can be set to the result of @GetProcessImageFileNameW@.++ Example: @/usr/bin/cmd/otelcol@+ -} , processCommand :: Maybe Text- -- ^ The command used to launch the process (i.e. the command name). On Linux based systems, can be set to the zeroth string in @proc/[pid]/cmdline@. On Windows, can be set to the first parameter extracted from @GetCommandLineW@.- --- -- Example: @cmd/otelcol@+ {- ^ The command used to launch the process (i.e. the command name). On Linux based systems, can be set to the zeroth string in @proc/[pid]/cmdline@. On Windows, can be set to the first parameter extracted from @GetCommandLineW@.++ Example: @cmd/otelcol@+ -} , processCommandLine :: Maybe Text- -- ^ The full command used to launch the process as a single string representing the full command. On Windows, can be set to the result of @GetCommandLineW@. Do not set this if you have to assemble it just for monitoring; use @process.command_args@ instead.- --- -- Example: @C:\cmd\otecol --config="my directory\config.yaml"@+ {- ^ The full command used to launch the process as a single string representing the full command. On Windows, can be set to the result of @GetCommandLineW@. Do not set this if you have to assemble it just for monitoring; use @process.command_args@ instead.++ Example: @C:\cmd\otecol --config="my directory\config.yaml"@+ -} , processCommandArgs :: Maybe [Text]- -- ^ All the command arguments (including the command/executable itself) as received by the process. On Linux-based systems (and some other Unixoid systems supporting procfs), can be set according to the list of null-delimited strings extracted from @proc/[pid]/cmdline@. For libc-based executables, this would be the full argv vector passed to main.- --- -- Example: @[cmd/otecol, --config=config.yaml]@+ {- ^ All the command arguments (including the command/executable itself) as received by the process. On Linux-based systems (and some other Unixoid systems supporting procfs), can be set according to the list of null-delimited strings extracted from @proc/[pid]/cmdline@. For libc-based executables, this would be the full argv vector passed to main.++ Example: @[cmd/otecol, --config=config.yaml]@+ -} , processOwner :: Maybe Text- -- ^ The username of the user that owns the process.- --- -- Example: @root@+ {- ^ The username of the user that owns the process.++ Example: @root@+ -}+ , processCreationTime :: Maybe Text+ {- ^ The date and time the process was created, in ISO 8601 format.++ Example: @"2023-11-21T09:25:34.853Z"@+ -}+ , processArgsCount :: Maybe Int+ -- ^ Length of the process.command_args array. Opt-In.+ , processParentPid :: Maybe Int+ -- ^ Parent Process identifier (PPID). Opt-In.+ , processWorkingDirectory :: Maybe Text+ -- ^ The working directory of the process. Opt-In.+ , processInteractive :: Maybe Bool+ -- ^ Whether the process is connected to an interactive shell. Opt-In.+ , processTitle :: Maybe Text+ -- ^ Process title (proctitle). Opt-In.+ , processLinuxCgroup :: Maybe Text+ -- ^ The control group associated with the process. Opt-In. } instance ToResource Process where- type ResourceSchema Process = 'Nothing toResource Process {..} =- mkResource- [ "process.pid" .=? processPid- , "process.executable.name" .=? processExecutableName- , "process.executable.path" .=? processExecutablePath- , "process.command" .=? processCommand- , "process.command_line" .=? processCommandLine- , "process.command_args" .=? processCommandArgs- , "process.owner" .=? processOwner+ mkResourceWithSchema+ (Just semConvSchemaUrl)+ [ unkey SC.process_pid .=? processPid+ , unkey SC.process_executable_name .=? processExecutableName+ , unkey SC.process_executable_path .=? processExecutablePath+ , unkey SC.process_command .=? processCommand+ , unkey SC.process_commandLine .=? processCommandLine+ , unkey SC.process_commandArgs .=? processCommandArgs+ , unkey SC.process_owner .=? processOwner+ , unkey SC.process_creation_time .=? processCreationTime+ , unkey SC.process_argsCount .=? processArgsCount+ , unkey SC.process_parentPid .=? processParentPid+ , unkey SC.process_workingDirectory .=? processWorkingDirectory+ , unkey SC.process_interactive .=? processInteractive+ , unkey SC.process_title .=? processTitle+ , unkey SC.process_linux_cgroup .=? processLinuxCgroup ] --- | The single (language) runtime instance which is monitored.+{- | The single (language) runtime instance which is monitored.++@since 0.0.1.0+-} data ProcessRuntime = ProcessRuntime { processRuntimeName :: Maybe Text- -- ^ The name of the runtime of this process. For compiled native binaries, this SHOULD be the name of the compiler.- --- -- Example: @OpenJDK Runtime Environment@+ {- ^ The name of the runtime of this process. For compiled native binaries, this SHOULD be the name of the compiler.++ Example: @OpenJDK Runtime Environment@+ -} , processRuntimeVersion :: Maybe Text- -- ^ The version of the runtime of this process, as returned by the runtime without modification.- --- -- Example: @14.0.2@+ {- ^ The version of the runtime of this process, as returned by the runtime without modification.++ Example: @14.0.2@+ -} , processRuntimeDescription :: Maybe Text- -- ^ An additional description about the runtime of the process, for example a specific vendor customization of the runtime environment.- --- -- Example: @Eclipse OpenJ9 Eclipse OpenJ9 VM openj9-0.21.0@+ {- ^ An additional description about the runtime of the process, for example a specific vendor customization of the runtime environment.++ Example: @Eclipse OpenJ9 Eclipse OpenJ9 VM openj9-0.21.0@+ -} } instance ToResource ProcessRuntime where- type ResourceSchema ProcessRuntime = 'Nothing toResource ProcessRuntime {..} =- mkResource- [ "process.runtime.name" .=? processRuntimeName- , "process.runtime.version" .=? processRuntimeVersion- , "process.runtime.description" .=? processRuntimeDescription+ mkResourceWithSchema+ (Just semConvSchemaUrl)+ [ unkey SC.process_runtime_name .=? processRuntimeName+ , unkey SC.process_runtime_version .=? processRuntimeVersion+ , unkey SC.process_runtime_description .=? processRuntimeDescription ]
src/OpenTelemetry/Resource/Service.hs view
@@ -1,10 +1,3 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeFamilies #-}--------------------------------------------------------------------------------------------------------------------------------------------------------------- {- | Module : OpenTelemetry.Resource.Service Copyright : (c) Ian Duncan, 2021@@ -17,45 +10,57 @@ module OpenTelemetry.Resource.Service where import Data.Text (Text)+import OpenTelemetry.Attributes.Key (unkey) import OpenTelemetry.Resource+import qualified OpenTelemetry.SemanticConventions as SC --- | A service instance+{- | A service instance++@since 0.0.1.0+-} data Service = Service { serviceName :: Text- -- ^ Logical name of the service.- --- -- MUST be the same for all instances of horizontally scaled services.- -- If the value was not specified, SDKs MUST fallback to unknown_service: concatenated with process.executable.name,- -- e.g. unknown_service:bash. If process.executable.name is not available, the value MUST be set to unknown_service.- --- -- If using the built-in resource detectors, this can be specified via the- -- @OTEL_SERVICE_NAME@ environment variable- --- -- Example: @shoppingcart@+ {- ^ Logical name of the service.++ MUST be the same for all instances of horizontally scaled services.+ If the value was not specified, SDKs MUST fallback to unknown_service: concatenated with process.executable.name,+ e.g. unknown_service:bash. If process.executable.name is not available, the value MUST be set to unknown_service.++ If using the built-in resource detectors, this can be specified via the+ @OTEL_SERVICE_NAME@ environment variable++ Example: @shoppingcart@+ -} , serviceNamespace :: Maybe Text- -- ^ A namespace for service.name.- --- -- A string value having a meaning that helps to distinguish a group of services, for example the team name that owns a group of services. service.name is expected to be unique within the same namespace. If service.namespace is not specified in the Resource then service.name is expected to be unique for all services that have no explicit namespace defined (so the empty/unspecified namespace is simply one more valid namespace). Zero-length namespace string is assumed equal to unspecified namespace.- --- -- Example: @Shop@+ {- ^ A namespace for service.name.++ A string value having a meaning that helps to distinguish a group of services, for example the team name that owns a group of services. service.name is expected to be unique within the same namespace. If service.namespace is not specified in the Resource then service.name is expected to be unique for all services that have no explicit namespace defined (so the empty/unspecified namespace is simply one more valid namespace). Zero-length namespace string is assumed equal to unspecified namespace.++ Example: @Shop@+ -} , serviceInstanceId :: Maybe Text- -- ^ The string ID of the service instance.- --- -- Example: @627cc493-f310-47de-96bd-71410b7dec09@+ {- ^ The string ID of the service instance.++ Example: @627cc493-f310-47de-96bd-71410b7dec09@+ -} , serviceVersion :: Maybe Text- -- ^ The version string of the service API or implementation.- --- -- Example: @2.0.0@+ {- ^ The version string of the service API or implementation.++ Example: @2.0.0@+ -}+ , serviceCriticality :: Maybe Text+ -- ^ Criticality of the service relative to other services. } instance ToResource Service where- type ResourceSchema Service = 'Nothing toResource Service {..} =- mkResource- [ "service.name" .= serviceName- , "service.namespace" .=? serviceNamespace- , "service.instance.id" .=? serviceInstanceId- , "service.version" .=? serviceVersion+ mkResourceWithSchema+ (Just semConvSchemaUrl)+ [ unkey SC.service_name .= serviceName+ , unkey SC.service_namespace .=? serviceNamespace+ , unkey SC.service_instance_id .=? serviceInstanceId+ , unkey SC.service_version .=? serviceVersion+ , unkey SC.service_criticality .=? serviceCriticality ]
src/OpenTelemetry/Resource/Telemetry.hs view
@@ -1,11 +1,5 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeFamilies #-} -------------------------------------------------------------------------------------------------------------------------------------------------------------- {- | Module : OpenTelemetry.Resource.Telemetry Copyright : (c) Ian Duncan, 2021@@ -19,7 +13,9 @@ module OpenTelemetry.Resource.Telemetry where import Data.Text (Text)+import OpenTelemetry.Attributes.Key (unkey) import OpenTelemetry.Resource+import qualified OpenTelemetry.SemanticConventions as SC -- - id: cpp@@ -44,7 +40,10 @@ -- value: "webjs" -- other allowed --- | The telemetry SDK used to capture data recorded by the instrumentation libraries.+{- | The telemetry SDK used to capture data recorded by the instrumentation libraries.++@since 0.0.1.0+-} data Telemetry = Telemetry { telemetrySdkName :: Text -- ^ The name of the telemetry SDK as defined above.@@ -52,17 +51,20 @@ -- ^ The name of the telemetry SDK as defined above. , telemetrySdkVersion :: Maybe Text -- ^ The version string of the telemetry SDK.- , telemetryAutoVersion :: Maybe Text- --- ^ The version string of the auto instrumentation agent, if used.+ , telemetryDistroName :: Maybe Text+ -- ^ The name of the telemetry auto instrumentation provider, if used.+ , telemetryDistroVersion :: Maybe Text+ -- ^ The version string of the telemetry auto instrumentation provider, if used. } instance ToResource Telemetry where- type ResourceSchema Telemetry = 'Nothing toResource Telemetry {..} =- mkResource- [ "telemetry.sdk.name" .= telemetrySdkName- , "telemetry.sdk.language" .=? telemetrySdkLanguage- , "telemetry.sdk.version" .=? telemetrySdkVersion- , "telemetry.auto.version" .=? telemetryAutoVersion+ mkResourceWithSchema+ (Just semConvSchemaUrl)+ [ unkey SC.telemetry_sdk_name .= telemetrySdkName+ , unkey SC.telemetry_sdk_language .=? telemetrySdkLanguage+ , unkey SC.telemetry_sdk_version .=? telemetrySdkVersion+ , unkey SC.telemetry_distro_name .=? telemetryDistroName+ , unkey SC.telemetry_distro_version .=? telemetryDistroVersion ]
src/OpenTelemetry/Resource/Webengine.hs view
@@ -1,17 +1,42 @@-------------------------------------------------------------------------------------------------------------------------------------------------------------- {- |- Module : OpenTelemetry.Resource.Telemetry- Copyright : (c) Ian Duncan, 2021+ Module : OpenTelemetry.Resource.Webengine+ Copyright : (c) Ian Duncan, 2021-2026 License : BSD-3- Description : Not implemented+ Description : Resource describing the web engine running the application Maintainer : Ian Duncan Stability : experimental Portability : non-portable (GHC extensions) - Not implemented. Please file a GitHub issue if you want this.+ Resource describing the packaged software running the application code.+ Web engines are typically executed using @process.runtime@. -} module OpenTelemetry.Resource.Webengine where +import Data.Text (Text)+import OpenTelemetry.Attributes.Key (unkey)+import OpenTelemetry.Resource+import qualified OpenTelemetry.SemanticConventions as SC+++{- | A web engine instance.++@since 1.0.0.0+-}+data Webengine = Webengine+ { webengineName :: Text+ -- ^ The name of the web engine. Required.+ , webengineVersion :: Maybe Text+ -- ^ The version of the web engine.+ , webengineDescription :: Maybe Text+ -- ^ Additional description of the web engine.+ }+++instance ToResource Webengine where+ toResource Webengine {..} =+ mkResourceWithSchema+ (Just semConvSchemaUrl)+ [ unkey SC.webengine_name .= webengineName+ , unkey SC.webengine_version .=? webengineVersion+ , unkey SC.webengine_description .=? webengineDescription+ ]
src/OpenTelemetry/SemanticsConfig.hs view
@@ -1,68 +1,141 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-} +{- |+Module : OpenTelemetry.SemanticsConfig+Description : Configuration for semantic convention stability opt-in. Controls which attribute naming conventions are used.+Stability : experimental++Values are typically derived from @OTEL_SEMCONV_STABILITY_OPT_IN@ via+'getSemanticsOptions' and queried per signal area with 'lookupStability'.+-} module OpenTelemetry.SemanticsConfig (- SemanticsOptions (httpOption),- HttpOption (..),+ SemanticsOptions,+ StabilityOpt (..),+ HttpOption,+ lookupStability,++ -- * Well-known stability keys+ httpOption,+ databaseOption,+ codeOption,++ -- * Reading from the environment getSemanticsOptions, getSemanticsOptions', ) where -import Control.Exception.Safe (throwIO, tryAny)+import Control.Exception (SomeException, throwIO, try)+import qualified Data.HashSet as Set import Data.IORef (newIORef, readIORef, writeIORef) import qualified Data.Text as T import System.Environment (lookupEnv) import System.IO.Unsafe (unsafePerformIO) -{- | This is a record that contains options for whether the new stable semantics conventions should be emitted.-Semantics conventions that have been declared stable:-- [http](https://opentelemetry.io/blog/2023/http-conventions-declared-stable/#migration-plan)+{- | Parsed representation of @OTEL_SEMCONV_STABILITY_OPT_IN@.++This is opaque: use 'lookupStability' with any signal key (e.g. @"http"@,+@"database"@, @"messaging"@) to query whether stable, old, or both conventions+should be emitted. Well-known accessors 'httpOption' and 'databaseOption' are+provided for convenience; third-party instrumentation libraries can query+arbitrary keys without modifying this module.++@since 0.4.0.0 -}-data SemanticsOptions = SemanticsOptions {httpOption :: HttpOption}+newtype SemanticsOptions = SemanticsOptions (Set.HashSet T.Text) --- | This option determines whether stable, old, or both kinds of http attributes are emitted.-data HttpOption+{- | Stability setting for a particular semantic convention area.++* 'Stable': emit only the new stable conventions.+* 'StableAndOld': emit both old and stable conventions (migration/dup mode).+* 'Old': emit only the legacy conventions (default when unset).++@since 0.4.0.0+-}+data StabilityOpt = Stable | StableAndOld | Old deriving (Show, Eq) --- | These are the default values emitted if OTEL_SEM_CONV_STABILITY_OPT_IN is unset or does not contain values for a specific category of option.-defaultOptions :: SemanticsOptions-defaultOptions = SemanticsOptions {httpOption = Old}+{- | Backward-compatible alias. +@since 0.4.0.0+-}+type HttpOption = StabilityOpt --- | Detects the presence of "http/dup" or "http" in OTEL_SEMCONV_STABILITY_OPT_IN or uses the default option if they are not there.-parseHttpOption :: (Foldable t) => t T.Text -> HttpOption-parseHttpOption envs- | "http/dup" `elem` envs = StableAndOld- | "http" `elem` envs = Stable- | otherwise = httpOption defaultOptions +{- | Look up the stability setting for an arbitrary signal key. --- | Detects the presence of semantics options in OTEL_SEMCONV_STABILITY_OPT_IN or uses the defaultOptions if they are not present.+Given a key like @"http"@, @"database"@, @"messaging"@, etc., returns:++* 'StableAndOld' if @\<key\>\/dup@ is present in the env var+* 'Stable' if @\<key\>@ is present+* 'Old' otherwise++@+opts <- getSemanticsOptions+case lookupStability "messaging" opts of+ Stable -> emitStableAttrs+ StableAndOld -> emitStableAttrs >> emitOldAttrs+ Old -> emitOldAttrs+@+@since 0.4.0.0+-}+lookupStability :: T.Text -> SemanticsOptions -> StabilityOpt+lookupStability key (SemanticsOptions vals)+ | (key <> "/dup") `Set.member` vals = StableAndOld+ | key `Set.member` vals = Stable+ | otherwise = Old+++{- | Stability setting for HTTP semantic conventions (@"http"@ / @"http\/dup"@).++@since 0.4.0.0+-}+httpOption :: SemanticsOptions -> StabilityOpt+httpOption = lookupStability "http"+++{- | Stability setting for database semantic conventions (@"database"@ / @"database\/dup"@).++@since 0.4.0.0+-}+databaseOption :: SemanticsOptions -> StabilityOpt+databaseOption = lookupStability "database"+++{- | Stability setting for code source-location conventions (@"code"@ / @"code\/dup"@).++Controls whether @code.function.name@, @code.file.path@, @code.line.number@ (stable)+or @code.function@, @code.namespace@, @code.filepath@, @code.lineno@ (legacy) are emitted.++@since 0.5.0.0+-}+codeOption :: SemanticsOptions -> StabilityOpt+codeOption = lookupStability "code"++ parseSemanticsOptions :: Maybe String -> SemanticsOptions-parseSemanticsOptions Nothing = defaultOptions-parseSemanticsOptions (Just env) = SemanticsOptions {..}- where- envs = fmap T.strip $ T.splitOn "," $ T.pack env- httpOption = parseHttpOption envs+parseSemanticsOptions Nothing = SemanticsOptions Set.empty+parseSemanticsOptions (Just env) =+ SemanticsOptions $ Set.fromList $ fmap T.strip $ T.splitOn "," $ T.pack env -{- | Version of getSemanticsOptions that is not memoized. It is recommended to use getSemanticsOptions for efficiency purposes-unless it is necessary to retrieve the value of OTEL_SEMCONV_STABILITY_OPT_IN every time getSemanticsOptions' is called.+{- | Version of 'getSemanticsOptions' that is not memoized. It is recommended to+use 'getSemanticsOptions' for efficiency purposes unless it is necessary to+retrieve the value of @OTEL_SEMCONV_STABILITY_OPT_IN@ every time+'getSemanticsOptions'' is called.++@since 0.4.0.0 -} getSemanticsOptions' :: IO SemanticsOptions getSemanticsOptions' = parseSemanticsOptions <$> lookupEnv "OTEL_SEMCONV_STABILITY_OPT_IN" -{- | Create a new memoized IO action using an 'IORef' under the surface. Note that-the action may be run in multiple threads simultaneously, so this may not be-thread safe (depending on the underlying action). For the sake of reading an environment-variable and parsing some stuff, we don't have to be concerned about thread-safety.--} memoize :: IO a -> IO (IO a) memoize action = do ref <- newIORef Nothing@@ -71,19 +144,22 @@ res <- case mres of Just res -> pure res Nothing -> do- res <- tryAny action+ res <- try @SomeException action writeIORef ref $ Just res pure res either throwIO pure res -{- | Retrieves OTEL_SEMCONV_STABILITY_OPT_IN and parses it into SemanticsOptions.+{- | Retrieves @OTEL_SEMCONV_STABILITY_OPT_IN@ and parses it into 'SemanticsOptions'. -This uses the [global IORef trick](https://www.parsonsmatt.org/2021/04/21/global_ioref_in_template_haskell.html)-to memoize the settings for efficiency. Note that getSemanticsOptions stores and returns the-value of the first time it was called and will not change when OTEL_SEMCONV_STABILITY_OPT_IN-is updated. Use getSemanticsOptions' to read OTEL_SEMCONV_STABILITY_OPT_IN every time the-function is called.+This uses the+[global IORef trick](https://www.parsonsmatt.org/2021/04/21/global_ioref_in_template_haskell.html)+to memoize the settings for efficiency. Note that 'getSemanticsOptions' stores+and returns the value of the first time it was called and will not change when+@OTEL_SEMCONV_STABILITY_OPT_IN@ is updated. Use 'getSemanticsOptions'' to read+the env var every time the function is called.++@since 0.4.0.0 -} getSemanticsOptions :: IO SemanticsOptions getSemanticsOptions = unsafePerformIO $ memoize getSemanticsOptions'
src/OpenTelemetry/Trace/Core.hs view
@@ -1,975 +1,1565 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NumericUnderscores #-}-{-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}----------------------------------------------------------------------------------------------------------------------------------------------------------------{- |- Module : OpenTelemetry.Trace.Core- Copyright : (c) Ian Duncan, 2021- License : BSD-3- Description : Low-level tracing API- Maintainer : Ian Duncan- Stability : experimental- Portability : non-portable (GHC extensions)-- Traces track the progression of a single request, called a trace, as it is handled by services that make up an application. The request may be initiated by a user or an application. Distributed tracing is a form of tracing that traverses process, network and security boundaries. Each unit of work in a trace is called a span; a trace is a tree of spans. Spans are objects that represent the work being done by individual services or components involved in a request as it flows through a system. A span contains a span context, which is a set of globally unique identifiers that represent the unique request that each span is a part of. A span provides Request, Error and Duration (RED) metrics that can be used to debug availability as well as performance issues.-- A trace contains a single root span which encapsulates the end-to-end latency for the entire request. You can think of this as a single logical operation, such as clicking a button in a web application to add a product to a shopping cart. The root span would measure the time it took from an end-user clicking that button to the operation being completed or failing (so, the item is added to the cart or some error occurs) and the result being displayed to the user. A trace is comprised of the single root span and any number of child spans, which represent operations taking place as part of the request. Each span contains metadata about the operation, such as its name, start and end timestamps, attributes, events, and status.-- To create and manage 'Span's in OpenTelemetry, the <https://hackage.haskell.org/package/hs-opentelemetry-api OpenTelemetry API> provides the tracer interface. This object is responsible for tracking the active span in your process, and allows you to access the current span in order to perform operations on it such as adding attributes, events, and finishing it when the work it tracks is complete. One or more tracer objects can be created in a process through the tracer provider, a factory interface that allows for multiple 'Tracer's to be instantiated in a single process with different options.-- Generally, the lifecycle of a span resembles the following:-- A request is received by a service. The span context is extracted from the request headers, if it exists.- A new span is created as a child of the extracted span context; if none exists, a new root span is created.- The service handles the request. Additional attributes and events are added to the span that are useful for understanding the context of the request, such as the hostname of the machine handling the request, or customer identifiers.- New spans may be created to represent work being done by sub-components of the service.- When the service makes a remote call to another service, the current span context is serialized and forwarded to the next service by injecting the span context into the headers or message envelope.- The work being done by the service completes, successfully or not. The span status is appropriately set, and the span is marked finished.- For more information, see the traces specification, which covers concepts including: trace, span, parent/child relationship, span context, attributes, events and links.--- This module implements eveything required to conform to the trace & span public interface described- by the OpenTelemetry specification.-- See OpenTelemetry.Trace.Monad for an implementation that's- generally easier to use in idiomatic Haskell.--}-module OpenTelemetry.Trace.Core (- -- * @TracerProvider@ operations- TracerProvider,- createTracerProvider,- shutdownTracerProvider,- forceFlushTracerProvider,- FlushResult (..),- getTracerProviderResources,- getTracerProviderPropagators,- getGlobalTracerProvider,- setGlobalTracerProvider,- emptyTracerProviderOptions,- TracerProviderOptions (..),-- -- * @Tracer@ operations- Tracer,- tracerName,- tracerIsEnabled,- HasTracer (..),- makeTracer,- getTracer,- getImmutableSpanTracer,- getTracerTracerProvider,- InstrumentationLibrary (..),- detectInstrumentationLibrary,- TracerOptions (..),- tracerOptions,-- -- * Span operations- Span,- toImmutableSpan,- FrozenOrDropped (..),- ImmutableSpan (..),- SpanContext (..),- -- | W3c Trace flags- --- -- https://www.w3.org/TR/trace-context/#trace-flags- TraceFlags,- traceFlagsValue,- traceFlagsFromWord8,- defaultTraceFlags,- isSampled,- setSampled,- unsetSampled,-- -- ** Creating @Span@s- inSpan,- inSpan',- inSpan'',- createSpan,- createSpanWithoutCallStack,- wrapSpanContext,- SpanKind (..),- defaultSpanArguments,- SpanArguments (..),-- -- ** Recording @Event@s- Event (..),- NewEvent (..),- addEvent,-- -- ** Enriching @Span@s with additional information- updateName,- OpenTelemetry.Trace.Core.addAttribute,- OpenTelemetry.Trace.Core.addAttributes,- spanGetAttributes,- Attribute (..),- ToAttribute (..),- PrimitiveAttribute (..),- ToPrimitiveAttribute (..),- Link (..),- NewLink (..),- addLink,-- -- ** Recording error information- recordException,- setStatus,- SpanStatus (..),-- -- ** Completing @Span@s- endSpan,-- -- ** Accessing other @Span@ information- getSpanContext,- isRecording,- isValid,- spanIsRemote,-- -- * Utilities- Timestamp,- getTimestamp,- timestampNanoseconds,- unsafeReadSpan,- whenSpanIsRecording,- ownCodeAttributes,- callerAttributes,- addAttributesToSpanArguments,-- -- * Limits- SpanLimits (..),- defaultSpanLimits,- bracketError,-) where--import Control.Applicative-import Control.Concurrent (myThreadId)-import Control.Concurrent.Async-import Control.Exception (Exception (..), SomeException (..), try)-import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.IO.Unlift-import Data.Coerce-import qualified Data.HashMap.Strict as H-import Data.IORef-import Data.Maybe (fromMaybe, isJust, isNothing)-import Data.Text (Text)-import qualified Data.Text as T-import Data.Typeable-import qualified Data.Vector as V-import Data.Word (Word64)-import GHC.Stack-import Network.HTTP.Types-import OpenTelemetry.Attributes-import qualified OpenTelemetry.Attributes as A-import OpenTelemetry.Common-import OpenTelemetry.Context-import OpenTelemetry.Context.ThreadLocal-import OpenTelemetry.Internal.Common.Types-import OpenTelemetry.Internal.Logs.Core (emitOTelLogRecord, logDroppedAttributes)-import qualified OpenTelemetry.Internal.Logs.Types as SeverityNumber (SeverityNumber (..))-import OpenTelemetry.Internal.Trace.Types-import qualified OpenTelemetry.Internal.Trace.Types as Types-import OpenTelemetry.Propagator (Propagator)-import OpenTelemetry.Resource-import OpenTelemetry.Trace.Id-import OpenTelemetry.Trace.Id.Generator-import OpenTelemetry.Trace.Id.Generator.Dummy-import OpenTelemetry.Trace.Sampler-import qualified OpenTelemetry.Trace.TraceState as TraceState-import OpenTelemetry.Util-import System.Clock-import System.IO.Unsafe-import System.Timeout (timeout)---{- | Create a 'Span'.-- If the provided 'Context' has a span in it (inserted via 'OpenTelemetry.Context.insertSpan'),- that 'Span' will be used as the parent of the 'Span' created via this API.-- Note: if the @hs-opentelemetry-sdk@ or another SDK is not installed, all actions that use the created- 'Span's produced will be no-ops.-- @since 0.0.1.0--}-createSpan- :: (MonadIO m, HasCallStack)- => Tracer- -- ^ 'Tracer' to create the span from. Associated 'Processor's and 'Exporter's will be- -- used for the lifecycle of the created 'Span'- -> Context- -- ^ Context, potentially containing a parent span. If no existing parent (or context) exists,- -- you can use 'OpenTelemetry.Context.empty'.- -> Text- -- ^ Span name- -> SpanArguments- -- ^ Additional span information- -> m Span- -- ^ The created span.- -- Try and infer source code information unless the user has set any of the attributes already, which- -- we take as an indication that our automatic strategy won't work well.-createSpan t ctxt n args = createSpanWithoutCallStack t ctxt n (addAttributesToSpanArgumentsIfNonePresent callerAttributes args)----- | The same thing as 'createSpan', except that it does not have a 'HasCallStack' constraint.-createSpanWithoutCallStack- :: (MonadIO m)- => Tracer- -- ^ 'Tracer' to create the span from. Associated 'Processor's and 'Exporter's will be- -- used for the lifecycle of the created 'Span'- -> Context- -- ^ Context, potentially containing a parent span. If no existing parent (or context) exists,- -- you can use 'OpenTelemetry.Context.empty'.- -> Text- -- ^ Span name- -> SpanArguments- -- ^ Additional span information- -> m Span- -- ^ The created span.-createSpanWithoutCallStack t ctxt n args@SpanArguments {..} = liftIO $ do- sId <- newSpanId $ tracerProviderIdGenerator $ tracerProvider t- let parent = lookupSpan ctxt- tId <- case parent of- Nothing -> newTraceId $ tracerProviderIdGenerator $ tracerProvider t- Just (Span s) ->- traceId . Types.spanContext <$> readIORef s- Just (FrozenSpan s) -> pure $ traceId s- Just (Dropped s) -> pure $ traceId s-- if null $ tracerProviderProcessors $ tracerProvider t- then pure $ Dropped $ SpanContext defaultTraceFlags False tId sId TraceState.empty- else do- (samplingOutcome, attrs, samplingTraceState) <- case parent of- -- TODO, this seems logically like what we'd do here- Just (Dropped _) -> pure (Drop, [], TraceState.empty)- _ ->- shouldSample- (tracerProviderSampler $ tracerProvider t)- ctxt- tId- n- args-- -- TODO properly populate- let ctxtForSpan =- SpanContext- { traceFlags = case samplingOutcome of- Drop -> defaultTraceFlags- RecordOnly -> defaultTraceFlags- RecordAndSample -> setSampled defaultTraceFlags- , isRemote = False- , traceState = samplingTraceState- , spanId = sId- , traceId = tId- }-- mkRecordingSpan = do- st <- maybe getTimestamp pure startTime- tid <- myThreadId- let additionalInfo = [("thread.id", toAttribute $ getThreadId tid)]- is =- ImmutableSpan- { spanName = n- , spanContext = ctxtForSpan- , spanParent = parent- , spanKind = kind- , spanAttributes =- A.addAttributes- (limitBy t spanAttributeCountLimit)- emptyAttributes- (H.unions [additionalInfo, attrs, attributes])- , spanLinks =- let emptyLinks = emptyAppendOnlyBoundedCollection $ fromMaybe 128 (linkCountLimit $ tracerProviderSpanLimits $ tracerProvider t)- in foldl (\c l -> appendToBoundedCollection c l) emptyLinks (fmap (freezeLink t) links)- , spanEvents = emptyAppendOnlyBoundedCollection $ fromMaybe 128 (eventCountLimit $ tracerProviderSpanLimits $ tracerProvider t)- , spanStatus = Unset- , spanStart = st- , spanEnd = Nothing- , spanTracer = t- }-- when (A.getDropped (spanAttributes is) > 0) $ void logDroppedAttributes-- s <- newIORef is- eResult <- try $ mapM_ (\processor -> spanProcessorOnStart processor s ctxt) $ tracerProviderProcessors $ tracerProvider t- case eResult of- Left err -> void $ emitOTelLogRecord H.empty SeverityNumber.Error $ T.pack $ show (err :: SomeException)- Right _ -> pure ()- pure $ Span s-- case samplingOutcome of- Drop -> pure $ Dropped ctxtForSpan- RecordOnly -> mkRecordingSpan- RecordAndSample -> mkRecordingSpan---{- |-Creates source code attributes describing the caller of the current function. You should use this if you are getting-source code attributes from inside a function that is creating a span.--Note: this will return nothing if the call stack is frozen.--}-ownCodeAttributes :: (HasCallStack) => AttributeMap-ownCodeAttributes = case getCallStack callStack of- -- The call stack is (probably) not frozen and the top entry is our call. Assume we have a full call stack- -- and look one further step up for our own code.- (("ownCodeAttributes", ownCodeCalledAt) : (ownFunction, _ownFunctionCalledAt) : _) ->- -- The source location attributes for the call to 'ownCode' will do well enough to identify the function- fnAttributes ownFunction <> srcLocAttributes ownCodeCalledAt- (("ownCodeAttributes", ownCodeCalledAt) : _) ->- -- We couldn't determine the calling function, but we should still be able to see the call location- fnAttributes "<unknown>" <> srcLocAttributes ownCodeCalledAt- -- The call stack doesn't look like we expect, potentially frozen or empty. In this case we can't- -- really do much, so give up. (see discussion below in 'callerAttributes')- _ -> mempty---{- |-Creates source code attributes describing where the current function is called. You should use this if-you are getting source code attributes from inside a "span creation" function.--Note: this will return nothing if the call stack is frozen.--}-callerAttributes :: (HasCallStack) => AttributeMap-callerAttributes = case getCallStack callStack of- -- The call stack is (probably) not frozen and the top entry is our call. Assume we have a full call stack- -- and look two further steps up for the caller.- (("callerAttributes", _callerAttributesCalledAt) : (_ownFunction, ownFunctionCalledAt) : (callerFunction, _) : _) ->- fnAttributes callerFunction <> srcLocAttributes ownFunctionCalledAt- (("callerAttributes", _callerAttributesCalledAt) : (_ownFunction, ownFunctionCalledAt) : _) ->- -- We couldn't determine the calling function, but we should still be able to see the call location- fnAttributes "<unknown>" <> srcLocAttributes ownFunctionCalledAt- -- The call stack doesn't look like we expect. It could be empty (in which case we can't do anything), or frozen- --- -- If it's frozen, there are at least two ways we could interpret it:- -- 1. The "current function" is the top of the call stack. This is likely if the call stack got frozen in a- -- helper function.- -- 2. The "caller" is the top of the call stack. This is likely if the call stack got frozen further up.- --- -- This means we really don't know what is going on, so we can't pick something that will work in all- -- circumstances. So we do nothing, and rely on the user to set these themselves.- _ -> mempty---fnAttributes :: String -> AttributeMap-fnAttributes fn =- H.fromList- [ ("code.function", toAttribute $ T.pack fn)- ]---srcLocAttributes :: SrcLoc -> AttributeMap-srcLocAttributes loc =- H.fromList- [ ("code.namespace", toAttribute $ T.pack $ srcLocModule loc)- , ("code.filepath", toAttribute $ T.pack $ srcLocFile loc)- , ("code.lineno", toAttribute $ srcLocStartLine loc)- , ("code.package", toAttribute $ T.pack $ srcLocPackage loc)- ]---{- | Attributes are added to the end of the span argument list, so will be discarded- if the number of attributes in the span exceeds the limit.--}-addAttributesToSpanArguments :: AttributeMap -> SpanArguments -> SpanArguments-addAttributesToSpanArguments attrs args = args {attributes = H.union (attributes args) attrs}----- | Add the given attributes to the span arguments, but only if *none* of them are present already.-addAttributesToSpanArgumentsIfNonePresent :: AttributeMap -> SpanArguments -> SpanArguments-addAttributesToSpanArgumentsIfNonePresent attrs args | shouldAddAttrs = addAttributesToSpanArguments attrs args- where- shouldAddAttrs = H.null $ H.intersection attrs (attributes args)-addAttributesToSpanArgumentsIfNonePresent _ args = args---{- | The simplest function for annotating code with trace information.-- @since 0.0.1.0--}-inSpan- :: (MonadUnliftIO m, HasCallStack)- => Tracer- -> Text- -- ^ The name of the span. This may be updated later via 'updateName'- -> SpanArguments- -- ^ Additional options for creating the span, such as 'SpanKind',- -- span links, starting attributes, etc.- -> m a- -- ^ The action to perform. 'inSpan' will record the time spent on the- -- action without forcing strict evaluation of the result. Any uncaught- -- exceptions will be recorded and rethrown.- -> m a--- Try and infer source code information unless the user has set any of the attributes already, which--- we take as an indication that our automatic strategy won't work well.-inSpan t n args m = inSpan'' t n (addAttributesToSpanArgumentsIfNonePresent callerAttributes args) (const m)---inSpan'- :: (MonadUnliftIO m, HasCallStack)- => Tracer- -> Text- -- ^ The name of the span. This may be updated later via 'updateName'- -> SpanArguments- -> (Span -> m a)- -> m a--- Try and infer source code information unless the user has set any of the attributes already, which--- we take as an indication that our automatic strategy won't work well.-inSpan' t n args = inSpan'' t n (addAttributesToSpanArgumentsIfNonePresent callerAttributes args)---inSpan''- :: (MonadUnliftIO m, HasCallStack)- => Tracer- -> Text- -- ^ The name of the span. This may be updated later via 'updateName'- -> SpanArguments- -> (Span -> m a)- -> m a-inSpan'' t n args f = do- bracketError- ( liftIO $ do- ctx <- getContext- s <- createSpanWithoutCallStack t ctx n args- adjustContext (insertSpan s)- pure (lookupSpan ctx, s)- )- ( \e (parent, s) -> liftIO $ do- forM_ e $ \(SomeException inner) -> do- setStatus s $ Error $ T.pack $ displayException inner- recordException s [("exception.escaped", toAttribute True)] Nothing inner- endSpan s Nothing- adjustContext $ \ctx ->- maybe (removeSpan ctx) (`insertSpan` ctx) parent- )- (\(_, s) -> f s)---{- | Returns whether the the @Span@ is currently recording. If a span- is dropped, this will always return False. If a span is from an- external process, this will return True, and if the span was- created by this process, the span will return True until endSpan- is called.--}-isRecording :: (MonadIO m) => Span -> m Bool-isRecording (Span s) = liftIO (isNothing . spanEnd <$> readIORef s)-isRecording (FrozenSpan _) = pure True-isRecording (Dropped _) = pure False---{- | Add an attribute to a span. Only has a useful effect on recording spans.--As an application developer when you need to record an attribute first consult existing semantic conventions for Resources, Spans, and Metrics. If an appropriate name does not exists you will need to come up with a new name. To do that consider a few options:--The name is specific to your company and may be possibly used outside the company as well. To avoid clashes with names introduced by other companies (in a distributed system that uses applications from multiple vendors) it is recommended to prefix the new name by your company’s reverse domain name, e.g. 'com.acme.shopname'.--The name is specific to your application that will be used internally only. If you already have an internal company process that helps you to ensure no name clashes happen then feel free to follow it. Otherwise it is recommended to prefix the attribute name by your application name, provided that the application name is reasonably unique within your organization (e.g. 'myuniquemapapp.longitude' is likely fine). Make sure the application name does not clash with an existing semantic convention namespace.--The name may be generally applicable to applications in the industry. In that case consider submitting a proposal to this specification to add a new name to the semantic conventions, and if necessary also to add a new namespace.--It is recommended to limit names to printable Basic Latin characters (more precisely to 'U+0021' .. 'U+007E' subset of Unicode code points), although the Haskell OpenTelemetry specification DOES provide full Unicode support.--Attribute names that start with 'otel.' are reserved to be defined by OpenTelemetry specification. These are typically used to express OpenTelemetry concepts in formats that don’t have a corresponding concept.--For example, the 'otel.library.name' attribute is used to record the instrumentation library name, which is an OpenTelemetry concept that is natively represented in OTLP, but does not have an equivalent in other telemetry formats and protocols.--Any additions to the 'otel.*' namespace MUST be approved as part of OpenTelemetry specification.--@since 0.0.1.0--}-addAttribute- :: (MonadIO m, A.ToAttribute a)- => Span- -- ^ Span to add the attribute to- -> Text- -- ^ Attribute name- -> a- -- ^ Attribute value- -> m ()-addAttribute (Span s) k v = liftIO $ modifyIORef' s $ \(!i) ->- i- { spanAttributes =- OpenTelemetry.Attributes.addAttribute- (limitBy (spanTracer i) spanAttributeCountLimit)- (spanAttributes i)- k- v- }-addAttribute (FrozenSpan _) _ _ = pure ()-addAttribute (Dropped _) _ _ = pure ()---{- | A convenience function related to 'addAttribute' that adds multiple attributes to a span at the same time.-- This function may be slightly more performant than repeatedly calling 'addAttribute'.-- @since 0.0.1.0--}-addAttributes :: (MonadIO m) => Span -> H.HashMap Text A.Attribute -> m ()-addAttributes (Span s) attrs = liftIO $ modifyIORef' s $ \(!i) ->- i- { spanAttributes =- OpenTelemetry.Attributes.addAttributes- (limitBy (spanTracer i) spanAttributeCountLimit)- (spanAttributes i)- attrs- }-addAttributes (FrozenSpan _) _ = pure ()-addAttributes (Dropped _) _ = pure ()---{- | Add an event to a recording span. Events will not be recorded for remote spans and dropped spans.-- @since 0.0.1.0--}-addEvent :: (MonadIO m) => Span -> NewEvent -> m ()-addEvent (Span s) NewEvent {..} = liftIO $ do- t <- maybe getTimestamp pure newEventTimestamp- modifyIORef' s $ \(!i) ->- i- { spanEvents =- appendToBoundedCollection (spanEvents i) $- Event- { eventName = newEventName- , eventAttributes =- A.addAttributes- (limitBy (spanTracer i) eventAttributeCountLimit)- emptyAttributes- newEventAttributes- , eventTimestamp = t- }- }-addEvent (FrozenSpan _) _ = pure ()-addEvent (Dropped _) _ = pure ()----- | Add a link to a recording span.-addLink :: (MonadIO m) => Span -> NewLink -> m ()-addLink (Span s) l = liftIO $ do- modifyIORef' s $ \(!i) -> i {spanLinks = appendToBoundedCollection (spanLinks i) (freezeLink (spanTracer i) l)}-addLink (FrozenSpan _) _ = pure ()-addLink (Dropped _) _ = pure ()---freezeLink :: Tracer -> NewLink -> Link-freezeLink t NewLink {..} =- Link- { frozenLinkContext = linkContext- , frozenLinkAttributes = A.addAttributes (limitBy t linkAttributeCountLimit) A.emptyAttributes linkAttributes- }---{- | Sets the Status of the Span. If used, this will override the default @Span@ status, which is @Unset@.-- These values form a total order: Ok > Error > Unset. This means that setting Status with StatusCode=Ok will override any prior or future attempts to set span Status with StatusCode=Error or StatusCode=Unset.-- @since 0.0.1.0--}-setStatus :: (MonadIO m) => Span -> SpanStatus -> m ()-setStatus (Span s) st = liftIO $ modifyIORef' s $ \(!i) ->- i- { spanStatus = max st (spanStatus i)- }-setStatus (FrozenSpan _) _ = pure ()-setStatus (Dropped _) _ = pure ()---alterFlags :: (MonadIO m) => Span -> (TraceFlags -> TraceFlags) -> m ()-alterFlags (Span s) f = liftIO $ modifyIORef' s $ \(!i) ->- i- { spanContext =- (spanContext i)- { traceFlags = f $ traceFlags $ spanContext i- }- }-alterFlags (FrozenSpan _) _ = pure ()-alterFlags (Dropped _) _ = pure ()---{- |-Updates the Span name. Upon this update, any sampling behavior based on Span name will depend on the implementation.--Note that @Sampler@s can only consider information already present during span creation. Any changes done later, including updated span name, cannot change their decisions.--Alternatives for the name update may be late Span creation, when Span is started with the explicit timestamp from the past at the moment where the final Span name is known, or reporting a Span with the desired name as a child Span.--@since 0.0.1.0--}-updateName- :: (MonadIO m)- => Span- -> Text- -- ^ The new span name, which supersedes whatever was passed in when the Span was started- -> m ()-updateName (Span s) n = liftIO $ modifyIORef' s $ \(!i) -> i {spanName = n}-updateName (FrozenSpan _) _ = pure ()-updateName (Dropped _) _ = pure ()---{- |-Signals that the operation described by this span has now (or at the time optionally specified) ended.--This does have any effects on child spans. Those may still be running and can be ended later.--This also does not inactivate the Span in any Context it is active in. It is still possible to use an ended span as-parent via a Context it is contained in. Also, putting the Span into a Context will still work after the Span was ended.--@since 0.0.1.0--}-endSpan- :: (MonadIO m)- => Span- -> Maybe Timestamp- -- ^ Optional @Timestamp@ signalling the end time of the span. If not provided, the current time will be used.- -> m ()-endSpan (Span s) mts = liftIO $ do- ts <- maybe getTimestamp pure mts- (alreadyFinished, frozenS) <- atomicModifyIORef' s $ \(!i) ->- let ref = i {spanEnd = spanEnd i <|> Just ts}- in (ref, (isJust $ spanEnd i, ref))- unless alreadyFinished $ do- eResult <- try $ mapM_ (`spanProcessorOnEnd` s) $ tracerProviderProcessors $ tracerProvider $ spanTracer frozenS- case eResult of- Left err -> print (err :: SomeException)- Right _ -> pure ()-endSpan (FrozenSpan _) _ = pure ()-endSpan (Dropped _) _ = pure ()---{- | A specialized variant of @addEvent@ that records attributes conforming to- the OpenTelemetry specification's- <https://github.com/open-telemetry/opentelemetry-specification/blob/49c2f56f3c0468ceb2b69518bcadadd96e0a5a8b/specification/trace/semantic_conventions/exceptions.md semantic conventions>-- @since 0.0.1.0--}-recordException :: (MonadIO m, Exception e) => Span -> AttributeMap -> Maybe Timestamp -> e -> m ()-recordException s attrs ts e = liftIO $ do- cs <- whoCreated e- let message = T.pack $ show e- addEvent s $- NewEvent- { newEventName = "exception"- , newEventAttributes =- H.union- attrs- [ ("exception.type", A.toAttribute $ T.pack $ show $ typeOf e)- , ("exception.message", A.toAttribute message)- , ("exception.stacktrace", A.toAttribute $ T.unlines $ map T.pack cs)- ]- , newEventTimestamp = ts- }----- | Returns @True@ if the @SpanContext@ has a non-zero @TraceID@ and a non-zero @SpanID@-isValid :: SpanContext -> Bool-isValid sc =- not- (isEmptyTraceId (traceId sc) && isEmptySpanId (spanId sc))---{- |-Returns @True@ if the @SpanContext@ was propagated from a remote parent,--When extracting a SpanContext through the Propagators API, isRemote MUST return @True@,-whereas for the SpanContext of any child spans it MUST return @False@.--}-spanIsRemote :: (MonadIO m) => Span -> m Bool-spanIsRemote (Span s) = liftIO $ do- i <- readIORef s- pure $ Types.isRemote $ Types.spanContext i-spanIsRemote (FrozenSpan c) = pure $ Types.isRemote c-spanIsRemote (Dropped _) = pure False---{- | Really only intended for tests, this function does not conform- to semantic versioning .--}-unsafeReadSpan :: (MonadIO m) => Span -> m ImmutableSpan-unsafeReadSpan s =- toImmutableSpan s >>= \case- Right span -> pure span- Left frozenOrDropped -> case frozenOrDropped of- SpanFrozen -> error "This span is from another process"- SpanDropped -> error "This span was dropped"---wrapSpanContext :: SpanContext -> Span-wrapSpanContext = FrozenSpan---{- | This can be useful for pulling data for attributes and- using it to copy / otherwise use the data to further enrich- instrumentation.--}-spanGetAttributes :: (MonadIO m) => Span -> m A.Attributes-spanGetAttributes = \case- Span ref -> do- s <- liftIO $ readIORef ref- pure $ spanAttributes s- FrozenSpan _ -> pure A.emptyAttributes- Dropped _ -> pure A.emptyAttributes---{- | Sometimes, you may have a more accurate notion of when a traced- operation has ended. In this case you may call 'getTimestamp', and then- supply 'endSpan' with the more accurate timestamp you have acquired.-- When using the monadic interface, (such as 'OpenTelemetry.Trace.Monad.inSpan', you may call- 'endSpan' early to record the information, and the first call to 'endSpan' will be honored.-- @since 0.0.1.0--}-getTimestamp :: (MonadIO m) => m Timestamp-getTimestamp = liftIO $ coerce @(IO TimeSpec) @(IO Timestamp) $ getTime Realtime---limitBy- :: Tracer- -> (SpanLimits -> Maybe Int)- -- ^ Attribute count- -> AttributeLimits-limitBy t countF =- AttributeLimits- { attributeCountLimit = countLimit- , attributeLengthLimit = lengthLimit- }- where- countLimit =- countF (tracerProviderSpanLimits $ tracerProvider t)- <|> attributeCountLimit- (tracerProviderAttributeLimits $ tracerProvider t)- lengthLimit =- spanAttributeValueLengthLimit (tracerProviderSpanLimits $ tracerProvider t)- <|> attributeLengthLimit- (tracerProviderAttributeLimits $ tracerProvider t)---globalTracer :: IORef TracerProvider-globalTracer = unsafePerformIO $ do- p <-- createTracerProvider- []- emptyTracerProviderOptions- newIORef p-{-# NOINLINE globalTracer #-}---data TracerProviderOptions = TracerProviderOptions- { tracerProviderOptionsIdGenerator :: IdGenerator- , tracerProviderOptionsSampler :: Sampler- , tracerProviderOptionsResources :: MaterializedResources- , tracerProviderOptionsAttributeLimits :: AttributeLimits- , tracerProviderOptionsSpanLimits :: SpanLimits- , tracerProviderOptionsPropagators :: Propagator Context RequestHeaders RequestHeaders- }---{- | Options for creating a 'TracerProvider' with invalid ids, no resources, default limits, and no propagators.-- In effect, tracing is a no-op when using this configuration.-- @since 0.0.1.0--}-emptyTracerProviderOptions :: TracerProviderOptions-emptyTracerProviderOptions =- TracerProviderOptions- dummyIdGenerator- (parentBased $ parentBasedOptions alwaysOn)- emptyMaterializedResources- defaultAttributeLimits- defaultSpanLimits- mempty---{- | Initialize a new tracer provider-- You should generally use 'getGlobalTracerProvider' for most applications.--}-createTracerProvider :: (MonadIO m) => [SpanProcessor] -> TracerProviderOptions -> m TracerProvider-createTracerProvider ps opts = liftIO $ do- let g = tracerProviderOptionsIdGenerator opts- pure $- TracerProvider- (V.fromList ps)- g- (tracerProviderOptionsSampler opts)- (tracerProviderOptionsResources opts)- (tracerProviderOptionsAttributeLimits opts)- (tracerProviderOptionsSpanLimits opts)- (tracerProviderOptionsPropagators opts)---{- | Access the globally configured 'TracerProvider'. Once the- the global tracer provider is initialized via the OpenTelemetry SDK,- 'Tracer's created from this 'TracerProvider' will export spans to their- configured exporters. Prior to that, any 'Tracer's acquired from the- uninitialized 'TracerProvider' will create no-op spans.-- @since 0.0.1.0--}-getGlobalTracerProvider :: (MonadIO m) => m TracerProvider-getGlobalTracerProvider = liftIO $ readIORef globalTracer---{- | Overwrite the globally configured 'TracerProvider'.-- 'Tracer's acquired from the previously installed 'TracerProvider'- will continue to use that 'TracerProvider's configured span processors,- exporters, and other settings.-- @since 0.0.1.0--}-setGlobalTracerProvider :: (MonadIO m) => TracerProvider -> m ()-setGlobalTracerProvider = liftIO . writeIORef globalTracer---getTracerProviderResources :: TracerProvider -> MaterializedResources-getTracerProviderResources = tracerProviderResources---getTracerProviderPropagators :: TracerProvider -> Propagator Context RequestHeaders RequestHeaders-getTracerProviderPropagators = tracerProviderPropagators----- | Tracer configuration options.-newtype TracerOptions = TracerOptions- { tracerSchema :: Maybe Text- -- ^ OpenTelemetry provides a schema for describing common attributes so that backends can easily parse and identify relevant information.- -- It is important to understand these conventions when writing instrumentation, in order to normalize your data and increase its utility.- --- -- In particular, this option is valuable to set when possible, because it allows vendors to normalize data accross releases in order to account- -- for attribute name changes.- }----- | Default Tracer options-tracerOptions :: TracerOptions-tracerOptions = TracerOptions Nothing---{- | A small utility lens for extracting a 'Tracer' from a larger data type-- This will generally be most useful as a means of implementing 'OpenTelemetry.Trace.Monad.getTracer'-- @since 0.0.1.0--}-class HasTracer s where- tracerL :: Lens' s Tracer---makeTracer :: TracerProvider -> InstrumentationLibrary -> TracerOptions -> Tracer-makeTracer tp n TracerOptions {} = Tracer n tp---getTracer :: (MonadIO m) => TracerProvider -> InstrumentationLibrary -> TracerOptions -> m Tracer-getTracer tp n TracerOptions {} = liftIO $ do- pure $ Tracer n tp-{-# DEPRECATED getTracer "use makeTracer" #-}---getImmutableSpanTracer :: ImmutableSpan -> Tracer-getImmutableSpanTracer = spanTracer---getTracerTracerProvider :: Tracer -> TracerProvider-getTracerTracerProvider = tracerProvider---{- | Check if the 'Tracer' is enabled.-- This function helps users avoid performing computationally expensive operations- when creating 'Span's if the tracer is not enabled.-- A 'Tracer' is considered enabled if it has at least one configured processor.- If the 'TracerProvider' has no processors, all spans will be dropped, so the- tracer is disabled.-- @since 0.3.1.0--}-tracerIsEnabled :: Tracer -> Bool-tracerIsEnabled t = not $ V.null $ tracerProviderProcessors $ tracerProvider t---{- | Smart constructor for 'SpanArguments' providing reasonable values for most 'Span's created- that are internal to an application.-- Defaults:-- - `kind`: `Internal`- - `attributes`: @[]@- - `links`: @[]@- - `startTime`: `Nothing` (`getTimestamp` will be called upon `Span` creation)--}-defaultSpanArguments :: SpanArguments-defaultSpanArguments =- SpanArguments- { kind = Internal- , attributes = []- , links = []- , startTime = Nothing- }---{- | This method provides a way for provider to do any cleanup required.-- This will also trigger shutdowns on all internal processors.-- @since 0.0.1.0--}-shutdownTracerProvider :: (MonadIO m) => TracerProvider -> m ()-shutdownTracerProvider TracerProvider {..} = liftIO $ do- asyncShutdownResults <- forM tracerProviderProcessors $ \processor -> do- spanProcessorShutdown processor- mapM_ wait asyncShutdownResults---{- | This method provides a way for provider to immediately export all spans that have not yet- been exported for all the internal processors.--}-forceFlushTracerProvider- :: (MonadIO m)- => TracerProvider- -> Maybe Int- -- ^ Optional timeout in microseconds, defaults to 5,000,000 (5s)- -> m FlushResult- -- ^ Result that denotes whether the flush action succeeded, failed, or timed out.-forceFlushTracerProvider TracerProvider {..} mtimeout = liftIO $ do- jobs <- forM tracerProviderProcessors $ \processor -> async $ do- spanProcessorForceFlush processor- mresult <-- timeout (fromMaybe 5_000_000 mtimeout) $- foldM- ( \status action -> do- res <- waitCatch action- pure $! case res of- Left _err -> FlushError- Right _ok -> status- )- FlushSuccess- jobs- case mresult of- Nothing -> pure FlushTimeout- Just res -> pure res---{- | Utility function to only perform costly attribute annotations- for spans that are actually--}-whenSpanIsRecording :: (MonadIO m) => Span -> m () -> m ()-whenSpanIsRecording (Span ref) m = do- span_ <- liftIO $ readIORef ref- case spanEnd span_ of- Nothing -> m- Just _ -> pure ()-whenSpanIsRecording (FrozenSpan _) _ = pure ()-whenSpanIsRecording (Dropped _) _ = pure ()---timestampNanoseconds :: Timestamp -> Word64-timestampNanoseconds (Timestamp TimeSpec {..}) = fromIntegral (sec * 1_000_000_000) + fromIntegral nsec+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++{- |+Module : OpenTelemetry.Trace.Core+Copyright : (c) Ian Duncan, 2021-2026+License : BSD-3+Description : Low-level tracing API+Maintainer : Ian Duncan+Stability : experimental+Portability : non-portable (GHC extensions)++= Overview++This module provides the core tracing API for creating and managing spans.+Most application code should use "OpenTelemetry.Trace" (from the SDK package)+for initialization and "OpenTelemetry.Trace.Monad" for a cleaner monadic+interface. This module is useful when you need direct control or are writing+instrumentation libraries.++= Quick example++> import OpenTelemetry.Trace.Core+>+> -- Wrap any IO action in a span:+> handleRequest :: Tracer -> Request -> IO Response+> handleRequest tracer req =+> inSpan tracer "handleRequest" defaultSpanArguments $ do+> result <- processRequest req+> pure result+>+> -- Access the span to add attributes:+> fetchUser :: Tracer -> UserId -> IO User+> fetchUser tracer uid =+> inSpan' tracer "fetchUser" defaultSpanArguments $ \span -> do+> addAttribute span "user.id" (toAttribute uid)+> user <- db_lookupUser uid+> addAttribute span "user.name" (toAttribute (userName user))+> pure user++= Key concepts++[@TracerProvider@] Factory that holds configuration (processors, exporters,+samplers) and creates 'Tracer's. Typically one per application, created at+startup.++[@Tracer@] Obtained from a 'TracerProvider', scoped to an instrumentation+library or application component. Carries the library name and version for+attribution.++[@Span@] Represents a unit of work. Has a name, start\/end timestamps,+attributes, events, links, and status. Created by 'OpenTelemetry.Trace.Core.inSpan'+or 'createSpan'.++= Creating spans++The @inSpan@ family of functions is the primary API:++* @inSpan@: wraps an @IO a@ action (or any 'MonadUnliftIO' action),+ automatically ending the span and recording exceptions. Captures source+ location from the call site.+* @inSpan@′: like @inSpan@, but passes the 'Span' to the callback so you can+ add attributes or events during execution. (In Haskell source the name ends+ with one ASCII prime character.)+* @inSpan@′′: raw variant with no automatic @code.*@ attributes from the call+ site. Preferred for instrumentation libraries where those attributes would+ describe library internals rather than user code. (In Haskell source the+ name ends with two ASCII prime characters.)++For manual span lifecycle management, use 'createSpan' and 'endSpan'.++= Adding metadata++> inSpan' tracer "processOrder" defaultSpanArguments $ \span -> do+> addAttribute span "order.id" (toAttribute orderId)+> addAttributes span+> [ ("order.total", toAttribute total)+> , ("order.currency", toAttribute "USD")+> ]+> addEvent span (newEvent "order.validated")+> setStatus span Ok++= Error handling++@inSpan@ and @inSpan@′ automatically catch exceptions, record them on the span (as an exception+event with stack trace), set the span status to Error, and re-throw. You+can also manually set error status:++> setStatus span (Error "payment declined")+> recordException span mempty Nothing myException++= Source location++@inSpan@, @inSpan@′, and 'createSpan' automatically add source location+attributes from GHC's 'HasCallStack'. The attribute names depend on the+@OTEL_SEMCONV_STABILITY_OPT_IN@ setting:++* Default (@Old@): @code.function@, @code.namespace@, @code.filepath@, @code.lineno@+* @code@: @code.function.name@, @code.file.path@, @code.line.number@ (stable semconv v1.33+)+* @code\/dup@: both old and stable names emitted++If you provide any @code.*@ attribute yourself in+'SpanArguments', the automatic attributes are suppressed.++= Spec reference++<https://opentelemetry.io/docs/specs/otel/trace/api/>+-}+module OpenTelemetry.Trace.Core (+ -- * @TracerProvider@ operations+ TracerProvider,+ createTracerProvider,+ shutdownTracerProvider,+ ShutdownResult (..),+ worstShutdown,+ forceFlushTracerProvider,+ FlushResult (..),+ getTracerProviderResources,+ getTracerProviderPropagators,+ getGlobalTracerProvider,+ setGlobalTracerProvider,+ emptyTracerProviderOptions,+ TracerProviderOptions (..),++ -- * @Tracer@ operations+ Tracer,+ tracerName,+ tracerIsEnabled,+ HasTracer (..),+ makeTracer,+ getTracer,+ getImmutableSpanTracer,+ getTracerTracerProvider,+ InstrumentationLibrary (..),+ instrumentationLibrary,+ withSchemaUrl,+ withLibraryAttributes,+ detectInstrumentationLibrary,+ TracerOptions (..),+ tracerOptions,++ -- * Span operations+ Span,+ toImmutableSpan,+ FrozenOrDropped (..),+ ImmutableSpan (..),+ SpanHot (..),+ SpanContext (..),+ {- | W3c Trace flags++ https://www.w3.org/TR/trace-context/#trace-flags+ -}+ TraceFlags,+ traceFlagsValue,+ traceFlagsFromWord8,+ defaultTraceFlags,+ isSampled,+ setSampled,+ unsetSampled,+ isRandom,+ setRandom,+ unsetRandom,++ -- ** Creating @Span@s+ inSpan,+ inSpan',+ inSpan'',+ createSpan,+ createSpanWithoutCallStack,+ wrapSpanContext,+ wrapDroppedContext,+ SpanKind (..),+ defaultSpanArguments,+ SpanArguments (..),++ -- ** Recording @Event@s+ Event (..),+ NewEvent (..),+ addEvent,++ -- ** Enriching @Span@s with additional information+ updateName,+ OpenTelemetry.Trace.Core.addAttribute,+ OpenTelemetry.Trace.Core.addAttributes,+ OpenTelemetry.Trace.Core.addAttributes',+ spanGetAttributes,+ Attribute (..),+ ToAttribute (..),+ PrimitiveAttribute (..),+ ToPrimitiveAttribute (..),++ -- *** Attribute builder+ A.AttrsBuilder,+ A.attr,+ A.optAttr,+ (A..@),+ (A..@?),+ A.buildAttrs,+ Link (..),+ NewLink (..),+ addLink,++ -- ** Recording error information+ recordException,+ recordError,+ setStatus,+ SpanStatus (..),++ -- ** Exception handling+ ExceptionClassification (..),+ ExceptionResponse (..),+ ExceptionHandler,+ defaultExceptionResponse,+ resolveException,++ -- ** Completing @Span@s+ endSpan,++ -- ** Accessing other @Span@ information+ getSpanContext,+ isRecording,+ isValid,+ spanIsRemote,++ -- * Active span+ getActiveSpan,+ withActiveSpan,+ getActiveSpanContext,++ -- * Event constructors+ newEvent,+ newEventWith,++ -- * Utilities+ Timestamp,+ getTimestamp,+ timestampNanoseconds,+ unsafeReadSpan,+ whenSpanIsRecording,+ codeAttributes,+ ownCodeAttributes,+ callerAttributes,+ addAttributesToSpanArguments,++ -- * Limits+ SpanLimits (..),+ defaultSpanLimits,+ bracketError,+) where++import Control.Applicative+import Control.Concurrent.Async+import Control.Concurrent.Thread.Storage (getCurrentThreadId)+import Control.Exception (Exception (..), SomeException (..), catch, displayException)+import qualified Control.Exception as EUnsafe+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift+import Data.Coerce+import qualified Data.HashMap.Strict as H+import Data.IORef (IORef, atomicModifyIORef', atomicWriteIORef, newIORef, readIORef, writeIORef)+++#if !MIN_VERSION_base(4,20,0)+import Data.List (foldl')+#endif+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Typeable+import qualified Data.Vector as V+import Data.Word (Word64)+import GHC.Stack+import OpenTelemetry.Attributes+import qualified OpenTelemetry.Attributes as A+import OpenTelemetry.Common+import OpenTelemetry.Context+import OpenTelemetry.Context.ThreadLocal+import OpenTelemetry.Internal.Common.Types+import OpenTelemetry.Internal.Log.Core (emitOTelLogRecord)+import qualified OpenTelemetry.Internal.Log.Types as SeverityNumber (SeverityNumber (..))+import OpenTelemetry.Internal.Logging (otelLogWarning)+import OpenTelemetry.Internal.Trace.Types+import qualified OpenTelemetry.Internal.Trace.Types as Types+import OpenTelemetry.Propagator (TextMapPropagator)+import OpenTelemetry.Resource+import qualified OpenTelemetry.SemanticConventions as SC+import OpenTelemetry.SemanticsConfig (StabilityOpt (..), codeOption, getSemanticsOptions)+import OpenTelemetry.Trace.Id+import OpenTelemetry.Trace.Id.Generator+import OpenTelemetry.Trace.Id.Generator.Dummy+import OpenTelemetry.Trace.Sampler+import qualified OpenTelemetry.Trace.TraceState as TraceState+import OpenTelemetry.Util+import System.IO.Unsafe+import System.Timeout (timeout)+++{- | Create a 'Span'.++ If the provided 'Context' has a span in it (inserted via 'OpenTelemetry.Context.insertSpan'),+ that 'Span' will be used as the parent of the 'Span' created via this API.++ Note: if the @hs-opentelemetry-sdk@ or another SDK is not installed, all actions that use the created+ 'Span's produced will be no-ops.++ @since 0.0.1.0+-}+createSpan+ :: (MonadIO m, HasCallStack)+ => Tracer+ {- ^ 'Tracer' to create the span from. Associated 'Processor's and 'Exporter's will be+ used for the lifecycle of the created 'Span'+ -}+ -> Context+ {- ^ Context, potentially containing a parent span. If no existing parent (or context) exists,+ you can use 'OpenTelemetry.Context.empty'.+ -}+ -> Text+ -- ^ Span name+ -> SpanArguments+ -- ^ Additional span information+ -> m Span+ {- ^ The created span.+ Try and infer source code information unless the user has set any of the attributes already, which+ we take as an indication that our automatic strategy won't work well.+ -}+createSpan t ctxt n args = createSpanWithoutCallStack t ctxt n (addAttributesToSpanArgumentsIfNonePresent callerAttributes args)+{-# INLINE createSpan #-}+++{- | The same thing as 'createSpan', except that it does not have a 'HasCallStack' constraint.++@since 0.0.1.0+-}+createSpanWithoutCallStack+ :: (MonadIO m)+ => Tracer+ {- ^ 'Tracer' to create the span from. Associated 'Processor's and 'Exporter's will be+ used for the lifecycle of the created 'Span'+ -}+ -> Context+ {- ^ Context, potentially containing a parent span. If no existing parent (or context) exists,+ you can use 'OpenTelemetry.Context.empty'.+ -}+ -> Text+ -- ^ Span name+ -> SpanArguments+ -- ^ Additional span information+ -> m Span+ -- ^ The created span.+createSpanWithoutCallStack t ctxt n args = liftIO $ do+ !tidInt <- getCurrentThreadId+ createSpanHelper t ctxt n args H.empty tidInt+{-# INLINE createSpanWithoutCallStack #-}+++{- | Like 'createSpanWithoutCallStack' but accepts lazy extra attributes+(e.g. source location info) that are only forced when the span is recorded.+The Int parameter is a pre-computed thread ID for the @thread.id@ span+attribute, avoiding a redundant myThreadId + FFI call when the caller+(e.g. inSpanInternal) already has the value.+-}+createSpanHelper :: Tracer -> Context -> Text -> SpanArguments -> AttributeMap -> Int -> IO Span+createSpanHelper t ctxt n args@SpanArguments {..} extraAttrs !tidInt = do+ when (T.null n) $+ otelLogWarning "Span created with empty name"+ let !tp = tracerProvider t+ isShutdown <- readIORef $ tracerProviderIsShutdown tp+ if isShutdown || not (tracerProviderHasProcessor tp)+ then do+ let parent = lookupSpan ctxt+ parentSc = case parent of+ Nothing -> Nothing+ Just (Span imm) -> Just (Types.spanContext imm)+ Just (FrozenSpan s') -> Just s'+ Just (Dropped s') -> Just s'+ (!tId, !parentTs) = case parentSc of+ Nothing -> (nilTraceId, TraceState.empty)+ Just sc -> (traceId sc, traceState sc)+ pure $! Dropped $! SpanContext defaultTraceFlags False tId nilSpanId parentTs+ else do+ let parent = lookupSpan ctxt+ parentSc = case parent of+ Nothing -> Nothing+ Just (Span imm) -> Just (Types.spanContext imm)+ Just (FrozenSpan s) -> Just s+ Just (Dropped s) -> Just s++ -- Dropped parent: propagate trace context, skip all ID generation+ case parent of+ Just (Dropped _) -> do+ let !ts = maybe TraceState.empty traceState parentSc+ !tId = maybe nilTraceId traceId parentSc+ pure $! Dropped $! SpanContext defaultTraceFlags False tId nilSpanId ts+ _ -> do+ let !idGen = tracerProviderIdGenerator tp++ -- Root spans: generate TraceId + SpanId in one FFI call (3 xoshiro+ -- steps) instead of 3 separate calls. The SpanId bytes are drawn+ -- before sampling but used after — the spec requires the ID to be+ -- fresh regardless of sampling outcome, which this satisfies.+ -- Child spans: inherit TraceId, generate only SpanId (1 call).+ (!tId, !preSpanId) <- case parentSc of+ Nothing -> newTraceAndSpanId idGen+ Just sc -> do+ !sid <- newSpanId idGen+ pure (traceId sc, sid)++ let !baseFlags = case parentSc of+ Nothing -> case idGen of+ DefaultIdGenerator -> setRandom defaultTraceFlags+ _ -> defaultTraceFlags+ Just sc+ | isRandom (Types.traceFlags sc) -> setRandom defaultTraceFlags+ | otherwise -> defaultTraceFlags++ -- Spec: shouldSample receives the InstrumentationScope of the Tracer.+ -- https://opentelemetry.io/docs/specs/otel/trace/sdk/#shouldsample+ SamplingDecision {..} <-+ shouldSample+ (tracerProviderSampler tp)+ ctxt+ tId+ n+ args+ (tracerName t)++ let !sId = preSpanId++ case samplingOutcome of+ Drop ->+ pure $! Dropped $! SpanContext baseFlags False tId sId samplingTraceState+ _ -> do+ let !ctxtForSpan =+ SpanContext+ { traceFlags = case samplingOutcome of+ Drop -> baseFlags+ RecordOnly -> baseFlags+ RecordAndSample -> setSampled baseFlags+ , isRemote = False+ , traceState = samplingTraceState+ , spanId = sId+ , traceId = tId+ }+ st <- maybe getTimestampIO pure startTime+ let !attrLimits = tracerSpanAttributeLimits t+ !tidVal = toAttribute tidInt+ !allAttrs =+ H.insert (unkey SC.thread_id) tidVal $!+ case (H.null samplingAttributes, H.null extraAttrs) of+ (True, True) -> attributes+ (True, False) -> H.union attributes extraAttrs+ (False, True) -> H.union samplingAttributes attributes+ (False, False) -> H.union samplingAttributes (H.union attributes extraAttrs)+ !initialAttrs = A.unsafeAttributesFromMap attrLimits allAttrs+ !initialLinks =+ foldl' (\c l -> appendToBoundedCollection c (freezeLink t l)) emptyLinks links+ emptyLinks = emptyAppendOnlyBoundedCollection (tracerLinkCountLimit t)+ emptyEvts = emptyAppendOnlyBoundedCollection (tracerEventCountLimit t)++ hotRef <-+ newIORef $!+ SpanHot+ { hotName = n+ , hotEnd = NoTimestamp+ , hotAttributes = initialAttrs+ , hotLinks = initialLinks+ , hotEvents = emptyEvts+ , hotStatus = Unset+ }+ let !imm =+ ImmutableSpan+ { spanContext = ctxtForSpan+ , spanKind = kind+ , spanStart = st+ , spanParent = parent+ , spanTracer = t+ , spanHot = hotRef+ }+ tracerProviderOnStart tp imm ctxt+ `catch` \(err :: SomeException) -> do+ otelLogWarning $ "Span processor onStart failed: " <> show err+ void $ emitOTelLogRecord H.empty SeverityNumber.Error $ T.pack $ show err+ pure $! Span imm+++{- |+Creates source code attributes describing the caller of the current function. You should use this if you are getting+source code attributes from inside a function that is creating a span.++Respects @OTEL_SEMCONV_STABILITY_OPT_IN=code@ to select stable vs legacy attribute names.++Note: this will return nothing if the call stack is frozen.+-}+ownCodeAttributes :: (HasCallStack) => AttributeMap+ownCodeAttributes =+ let opt = codeOption $ unsafePerformIO getSemanticsOptions+ in case getCallStack callStack of+ (("ownCodeAttributes", ownCodeCalledAt) : (ownFunction, _ownFunctionCalledAt) : _) ->+ codeAttributes opt ownFunction ownCodeCalledAt+ (("ownCodeAttributes", ownCodeCalledAt) : _) ->+ codeAttributes opt "<unknown>" ownCodeCalledAt+ _ -> mempty+++{- |+Creates source code attributes describing where the current function is called. You should use this if+you are getting source code attributes from inside a "span creation" function.++Respects @OTEL_SEMCONV_STABILITY_OPT_IN=code@ to select stable vs legacy attribute names.++Note: this will return nothing if the call stack is frozen.+-}+callerAttributes :: (HasCallStack) => AttributeMap+callerAttributes =+ let opt = codeOption $ unsafePerformIO getSemanticsOptions+ in case getCallStack callStack of+ (("callerAttributes", _callerAttributesCalledAt) : (_ownFunction, ownFunctionCalledAt) : (callerFunction, _) : _) ->+ codeAttributes opt callerFunction ownFunctionCalledAt+ (("callerAttributes", _callerAttributesCalledAt) : (_ownFunction, ownFunctionCalledAt) : _) ->+ codeAttributes opt "<unknown>" ownFunctionCalledAt+ _ -> mempty+++codeAttributes :: StabilityOpt -> String -> SrcLoc -> AttributeMap+codeAttributes opt fn loc = case opt of+ Stable -> stableAttrs+ StableAndOld -> H.union stableAttrs oldAttrs+ Old -> oldAttrs+ where+ modName = srcLocModule loc+ qualifiedName = T.pack $ modName <> "." <> fn+ stableAttrs =+ H.insert (unkey SC.code_function_name) (toAttribute qualifiedName) $!+ H.insert (unkey SC.code_file_path) (toAttribute $ T.pack $ srcLocFile loc) $!+ H.singleton (unkey SC.code_line_number) (toAttribute $ srcLocStartLine loc)+ oldAttrs =+ H.insert (unkey SC.code_function) (toAttribute $ T.pack fn) $!+ H.insert (unkey SC.code_namespace) (toAttribute $ T.pack modName) $!+ H.insert (unkey SC.code_filepath) (toAttribute $ T.pack $ srcLocFile loc) $!+ H.singleton (unkey SC.code_lineno) (toAttribute $ srcLocStartLine loc)+{-# INLINE codeAttributes #-}+++{- | Attributes are added to the end of the span argument list, so will be discarded+ if the number of attributes in the span exceeds the limit.+-}+addAttributesToSpanArguments :: AttributeMap -> SpanArguments -> SpanArguments+addAttributesToSpanArguments attrs args = args {attributes = H.union (attributes args) attrs}+++-- | Add the given attributes to the span arguments, but only if *none* of them are present already.+addAttributesToSpanArgumentsIfNonePresent :: AttributeMap -> SpanArguments -> SpanArguments+addAttributesToSpanArgumentsIfNonePresent attrs args+ | H.null attrs = args+ | H.null existingAttrs = addAttributesToSpanArguments attrs args+ | anyOverlap = args+ | otherwise = addAttributesToSpanArguments attrs args+ where+ existingAttrs = attributes args+ anyOverlap = any (`H.member` existingAttrs) (H.keys attrs)+++hasCodeAttributes :: AttributeMap -> Bool+hasCodeAttributes m =+ H.member (unkey SC.code_function) m+ || H.member (unkey SC.code_namespace) m+ || H.member (unkey SC.code_filepath) m+ || H.member (unkey SC.code_function_name) m+ || H.member (unkey SC.code_file_path) m+{-# INLINE hasCodeAttributes #-}+++{- | Extract caller source location from a 'CallStack' and build attributes.+Takes the 'CallStack' directly so the thunk captures only the implicit+parameter, deferring all 'T.pack' / 'H.insert' work until forced.++The call stack from @inSpan@ (HasCallStack) looks like:+ (\"inSpan\", call_site) : (caller_of_inSpan, ...) : ...+We want the call_site (where inSpan was called) and the caller function name.+-}+callerCodeAttrs :: StabilityOpt -> CallStack -> AttributeMap+callerCodeAttrs opt cs = case getCallStack cs of+ ((_inSpanFn, callSite) : (callerFn, _) : _) ->+ codeAttributes opt callerFn callSite+ ((_inSpanFn, callSite) : _) ->+ codeAttributes opt "<unknown>" callSite+ _ -> H.empty+{-# INLINE callerCodeAttrs #-}+++{- | The simplest function for annotating code with trace information.++ @since 0.0.1.0+-}+inSpan+ :: (MonadUnliftIO m, HasCallStack)+ => Tracer+ -> Text+ -- ^ The name of the span. This may be updated later via 'updateName'+ -> SpanArguments+ {- ^ Additional options for creating the span, such as 'SpanKind',+ span links, starting attributes, etc.+ -}+ -> m a+ {- ^ The action to perform. 'inSpan' will record the time spent on the+ action without forcing strict evaluation of the result. Any uncaught+ exceptions will be recorded and rethrown.+ -}+ -> m a+inSpan t n args m =+ let opt = codeOption $ unsafePerformIO getSemanticsOptions+ codeAttrs = if hasCodeAttributes (attributes args) then H.empty else callerCodeAttrs opt callStack+ in inSpanInternal t n args codeAttrs (const m)+{-# INLINE inSpan #-}+++{- | Like 'inSpan', but passes the created 'Span' to the action.++ @since 0.0.1.0+-}+inSpan'+ :: (MonadUnliftIO m, HasCallStack)+ => Tracer+ -> Text+ -- ^ The name of the span. This may be updated later via 'updateName'+ -> SpanArguments+ -> (Span -> m a)+ -> m a+inSpan' t n args =+ let opt = codeOption $ unsafePerformIO getSemanticsOptions+ codeAttrs = if hasCodeAttributes (attributes args) then H.empty else callerCodeAttrs opt callStack+ in inSpanInternal t n args codeAttrs+{-# INLINE inSpan' #-}+++{- | Like @inSpan@′ (the Haskell name has one ASCII prime), but does not add+ automatic caller source location attributes.++ @since 0.4.0.0+-}+inSpan''+ :: (MonadUnliftIO m, HasCallStack)+ => Tracer+ -> Text+ -- ^ The name of the span. This may be updated later via 'updateName'+ -> SpanArguments+ -> (Span -> m a)+ -> m a+inSpan'' t n args = inSpanInternal t n args H.empty+{-# INLINE inSpan'' #-}+++{- | Internal workhorse: takes lazy extra attributes (e.g. callerAttributes)+that are only evaluated when the span is actually recorded.+-}+inSpanInternal+ :: (MonadUnliftIO m)+ => Tracer+ -> Text+ -> SpanArguments+ -> AttributeMap+ -> (Span -> m a)+ -> m a+inSpanInternal t n args extraAttrs f+ | not (tracerProviderHasProcessor (tracerProvider t)) =+ -- Fast path: no processors means every span is Dropped. Skip mask,+ -- context modification, and exception recording entirely. We still+ -- propagate trace ID via a lightweight Dropped span for context+ -- continuity in case a child uses a different (active) tracer.+ liftIO (getContext >>= \ctx -> createSpanHelper t ctx n args extraAttrs (-1)) >>= f+ | otherwise = withRunInIO $ \run -> EUnsafe.mask $ \restore -> do+ -- Fused CMM fast path: reads CurrentTSO.id + probes flat table+ -- in a single CMM call. No ThreadId allocation, no FFI, no Maybe.+ -- On steady state this is one CMM call + one readArray#.+ (!tidInt, ctxRef) <- ensureContextRefFast+ entry <- readIORef ctxRef+ let ctx = ceContext entry+ s <- createSpanHelper t ctx n args extraAttrs tidInt+ writeIORef ctxRef $! entry {ceContext = insertSpan s ctx}+ -- User code (unmasked via restore)+ a <-+ restore (run $ f s) `EUnsafe.catch` \someEx@(SomeException inner) -> do+ let ExceptionResponse classification exAttrs = resolveException t someEx+ case classification of+ ErrorException -> do+ setStatus s $ Error $ T.pack $ displayException inner+ recordException s (H.union [(unkey SC.exception_escaped, toAttribute True)] exAttrs) Nothing inner+ RecordedException ->+ recordException s (H.union [(unkey SC.exception_escaped, toAttribute True)] exAttrs) Nothing inner+ IgnoredException ->+ pure ()+ endSpan s Nothing+ writeIORef ctxRef entry+ EUnsafe.throwIO someEx+ -- Success cleanup (runs masked; non-blocking, no uninterruptibleMask_ needed)+ endSpan s Nothing+ writeIORef ctxRef entry+ pure a+{-# INLINEABLE inSpanInternal #-}+{-# SPECIALIZE inSpanInternal :: Tracer -> Text -> SpanArguments -> AttributeMap -> (Span -> IO a) -> IO a #-}+++{- | Returns whether the @Span@ is currently recording.++A live 'Span' created by this process returns 'True' until 'endSpan' is+called. A 'FrozenSpan' (non-recording context-only wrapper, e.g. from+'wrapSpanContext') and a 'Dropped' span always return 'False'.++ @since 0.0.1.0+-}+isRecording :: (MonadIO m) => Span -> m Bool+isRecording (Span imm) = liftIO (not . isEnded . hotEnd <$> readIORef (spanHot imm))+isRecording (FrozenSpan _) = pure False+isRecording (Dropped _) = pure False+{-# INLINE isRecording #-}+++{- | Add an attribute to a span. Only affects recording spans.++See the [OTel attribute naming conventions](https://opentelemetry.io/docs/specs/otel/common/attribute-naming/)+for guidance on choosing attribute names.++@since 0.0.1.0+-}+addAttribute+ :: (MonadIO m, A.ToAttribute a)+ => Span+ -- ^ Span to add the attribute to+ -> Text+ -- ^ Attribute name+ -> a+ -- ^ Attribute value+ -> m ()+addAttribute (Span imm) k v = liftIO $ casModifyIORef_ (spanHot imm) $ \(!h) ->+ if isEnded (hotEnd h)+ then h+ else+ h+ { hotAttributes =+ OpenTelemetry.Attributes.addAttribute+ (tracerSpanAttributeLimits $ spanTracer imm)+ (hotAttributes h)+ k+ v+ }+addAttribute (FrozenSpan _) _ _ = pure ()+addAttribute (Dropped _) _ _ = pure ()+{-# INLINEABLE addAttribute #-}+++{-# SPECIALIZE OpenTelemetry.Trace.Core.addAttribute :: (A.ToAttribute a) => Span -> Text -> a -> IO () #-}+++{- | A convenience function related to 'addAttribute' that adds multiple attributes to a span at the same time.++ This function may be slightly more performant than repeatedly calling 'addAttribute'.++ @since 0.0.1.0+-}+addAttributes :: (MonadIO m) => Span -> H.HashMap Text A.Attribute -> m ()+addAttributes (Span imm) attrs = liftIO $ casModifyIORef_ (spanHot imm) $ \(!h) ->+ if isEnded (hotEnd h)+ then h+ else+ h+ { hotAttributes =+ OpenTelemetry.Attributes.addAttributes+ (tracerSpanAttributeLimits $ spanTracer imm)+ (hotAttributes h)+ attrs+ }+addAttributes (FrozenSpan _) _ = pure ()+addAttributes (Dropped _) _ = pure ()+{-# INLINEABLE addAttributes #-}+++{-# SPECIALIZE OpenTelemetry.Trace.Core.addAttributes :: Span -> H.HashMap Text A.Attribute -> IO () #-}+++{- | Like 'addAttributes', but takes an 'A.AttrsBuilder' instead of a 'HashMap'.+More efficient when setting many attributes at once.++With typed 'AttributeKey's from semantic conventions:++@+'addAttributes'' span $+ SC.http_request_method '.@' method+ <> SC.url_full '.@' url+ <> SC.server_port '.@?' mPort+@++With plain 'Text' keys:++@+'addAttributes'' span $+ 'attr' "custom.key" value+ <> 'optAttr' "custom.optional" mValue+@++@since 0.4.1.0+-}+addAttributes' :: (MonadIO m) => Span -> A.AttrsBuilder -> m ()+addAttributes' (Span imm) builder = liftIO $ casModifyIORef_ (spanHot imm) $ \(!h) ->+ if isEnded (hotEnd h)+ then h+ else+ h+ { hotAttributes =+ A.addAttributesFromBuilder+ (tracerSpanAttributeLimits $ spanTracer imm)+ (hotAttributes h)+ builder+ }+addAttributes' (FrozenSpan _) _ = pure ()+addAttributes' (Dropped _) _ = pure ()+{-# INLINEABLE addAttributes' #-}+{-# SPECIALIZE addAttributes' :: Span -> A.AttrsBuilder -> IO () #-}+++-- Skip the CAS entirely when there's nothing to add.+{-# RULES+"addAttributes'/mempty" forall s. addAttributes' s mempty = pure ()+"addAttributes/empty" forall s. OpenTelemetry.Trace.Core.addAttributes s H.empty = pure ()+ #-}+++{- | Add an event to a recording span. Events will not be recorded for remote spans and dropped spans.++ @since 0.0.1.0+-}+addEvent :: (MonadIO m) => Span -> NewEvent -> m ()+addEvent (Span imm) NewEvent {..} = liftIO $ do+ t <- maybe getTimestampIO pure newEventTimestamp+ casModifyIORef_ (spanHot imm) $ \(!h) ->+ if isEnded (hotEnd h)+ then h+ else+ h+ { hotEvents =+ appendToBoundedCollection (hotEvents h) $+ Event+ { eventName = newEventName+ , eventAttributes =+ A.addAttributes+ (tracerEventAttributeLimits $ spanTracer imm)+ emptyAttributes+ newEventAttributes+ , eventTimestamp = t+ }+ }+addEvent (FrozenSpan _) _ = pure ()+addEvent (Dropped _) _ = pure ()+{-# INLINEABLE addEvent #-}+{-# SPECIALIZE addEvent :: Span -> NewEvent -> IO () #-}+++{- | Construct a 'NewEvent' with just a name (no attributes, current timestamp).++@+addEvent span (newEvent "cache-miss")+@++@since 0.4.1.0+-}+newEvent :: Text -> NewEvent+newEvent name = NewEvent {newEventName = name, newEventAttributes = H.empty, newEventTimestamp = Nothing}+{-# INLINE newEvent #-}+++{- | Construct a 'NewEvent' with a name and attributes (current timestamp).++@+addEvent span (newEventWith "retry" [("attempt", toAttribute retryCount)])+@++@since 0.4.1.0+-}+newEventWith :: Text -> AttributeMap -> NewEvent+newEventWith name attrs = NewEvent {newEventName = name, newEventAttributes = attrs, newEventTimestamp = Nothing}+{-# INLINE newEventWith #-}+++{- | Add a link to a recording span.++@since 0.0.1.0+-}+addLink :: (MonadIO m) => Span -> NewLink -> m ()+addLink (Span imm) l = liftIO $+ casModifyIORef_ (spanHot imm) $ \(!h) ->+ if isEnded (hotEnd h)+ then h+ else h {hotLinks = appendToBoundedCollection (hotLinks h) (freezeLink (spanTracer imm) l)}+addLink (FrozenSpan _) _ = pure ()+addLink (Dropped _) _ = pure ()+{-# INLINEABLE addLink #-}+{-# SPECIALIZE addLink :: Span -> NewLink -> IO () #-}+++freezeLink :: Tracer -> NewLink -> Link+freezeLink t NewLink {..} =+ Link+ { frozenLinkContext = linkContext+ , frozenLinkAttributes = A.addAttributes (tracerLinkAttributeLimits t) A.emptyAttributes linkAttributes+ }+++{- | Sets the Status of the Span. If used, this will override the default @Span@ status, which is @Unset@.++ These values form a total order: Ok > Error > Unset. This means that setting Status with StatusCode=Ok will override any prior or future attempts to set span Status with StatusCode=Error or StatusCode=Unset.++ @since 0.0.1.0+-}+setStatus :: (MonadIO m) => Span -> SpanStatus -> m ()+setStatus (Span imm) st = liftIO $ casModifyIORef_ (spanHot imm) $ \(!h) ->+ if isEnded (hotEnd h)+ then h+ else h {hotStatus = mergeStatus st (hotStatus h)}+setStatus (FrozenSpan _) _ = pure ()+setStatus (Dropped _) _ = pure ()+{-# INLINEABLE setStatus #-}+{-# SPECIALIZE setStatus :: Span -> SpanStatus -> IO () #-}+++{- | Merge a new status into the existing status per the OTel spec.++The spec defines a total order: @Ok > Error > Unset@. Setting @Ok@+overrides any prior status. Setting @Error@ overrides @Unset@ but not+@Ok@. Setting @Unset@ is always a no-op.++@since 0.0.1.0+-}+mergeStatus :: SpanStatus -> SpanStatus -> SpanStatus+mergeStatus _ Ok = Ok+mergeStatus Ok _ = Ok+mergeStatus new Unset = new+mergeStatus _new current = current+++{- |+Updates the Span name. Upon this update, any sampling behavior based on Span name will depend on the implementation.++Note that @Sampler@s can only consider information already present during span creation. Any changes done later, including updated span name, cannot change their decisions.++Alternatives for the name update may be late Span creation, when Span is started with the explicit timestamp from the past at the moment where the final Span name is known, or reporting a Span with the desired name as a child Span.++@since 0.0.1.0+-}+updateName+ :: (MonadIO m)+ => Span+ -> Text+ -- ^ The new span name, which supersedes whatever was passed in when the Span was started+ -> m ()+updateName (Span imm) n = liftIO $ casModifyIORef_ (spanHot imm) $ \(!h) ->+ if isEnded (hotEnd h)+ then h+ else h {hotName = n}+updateName (FrozenSpan _) _ = pure ()+updateName (Dropped _) _ = pure ()+{-# INLINEABLE updateName #-}+{-# SPECIALIZE updateName :: Span -> Text -> IO () #-}+++{- |+Signals that the operation described by this span has now (or at the time optionally specified) ended.++This does have any effects on child spans. Those may still be running and can be ended later.++This also does not inactivate the Span in any Context it is active in. It is still possible to use an ended span as+parent via a Context it is contained in. Also, putting the Span into a Context will still work after the Span was ended.++@since 0.0.1.0+-}+endSpan+ :: (MonadIO m)+ => Span+ -> Maybe Timestamp+ -- ^ Optional @Timestamp@ signalling the end time of the span. If not provided, the current time will be used.+ -> m ()+endSpan (Span imm) mts = liftIO $ do+ ts <- maybe getTimestampIO pure mts+ let !optTs = timestampToOptional ts+ old <- casReadModifyIORef_ (spanHot imm) $ \(!h) ->+ case hotEnd h of+ SomeTimestamp _ -> h+ NoTimestamp -> h {hotEnd = optTs}+ case hotEnd old of+ SomeTimestamp _ -> pure ()+ NoTimestamp -> do+ let !spanName = hotName old+ !droppedAttributeCount =+ A.getDropped (hotAttributes old)+ + V.foldl' (\acc e -> acc + A.getDropped (eventAttributes e)) 0 (appendOnlyBoundedCollectionValues (hotEvents old))+ + V.foldl' (\acc l -> acc + A.getDropped (frozenLinkAttributes l)) 0 (appendOnlyBoundedCollectionValues (hotLinks old))+ !droppedEventsCount = appendOnlyBoundedCollectionDroppedElementCount (hotEvents old)+ !droppedLinksCount = appendOnlyBoundedCollectionDroppedElementCount (hotLinks old)+ when (droppedAttributeCount > 0 || droppedEventsCount > 0 || droppedLinksCount > 0) $+ otelLogWarning $+ "Span '"+ <> T.unpack spanName+ <> "' dropped data due to limits: "+ <> show droppedAttributeCount+ <> " attribute(s), "+ <> show droppedEventsCount+ <> " event(s), "+ <> show droppedLinksCount+ <> " link(s)"+ tracerProviderOnEnd (tracerProvider (spanTracer imm)) imm+ `catch` \(ex :: SomeException) -> otelLogWarning ("Span processor onEnd failed: " <> show ex)+endSpan (FrozenSpan _) _ = pure ()+endSpan (Dropped _) _ = pure ()+{-# INLINEABLE endSpan #-}+{-# SPECIALIZE endSpan :: Span -> Maybe Timestamp -> IO () #-}+++{- | A specialized variant of @addEvent@ that records attributes conforming to+ the OpenTelemetry specification's+ <https://github.com/open-telemetry/opentelemetry-specification/blob/49c2f56f3c0468ceb2b69518bcadadd96e0a5a8b/specification/trace/semantic_conventions/exceptions.md semantic conventions>++ @since 0.0.1.0+-}+recordException :: (MonadIO m, Exception e) => Span -> AttributeMap -> Maybe Timestamp -> e -> m ()+recordException s attrs ts e = liftIO $ do+ cs <- whoCreated e+ let message = T.pack $ displayException e+ addEvent s $+ NewEvent+ { newEventName = "exception"+ , newEventAttributes =+ H.union+ attrs+ [ (unkey SC.exception_type, A.toAttribute $ T.pack $ show $ typeOf e)+ , (unkey SC.exception_message, A.toAttribute message)+ , (unkey SC.exception_stacktrace, A.toAttribute $ T.unlines $ map T.pack cs)+ ]+ , newEventTimestamp = ts+ }+{-# INLINEABLE recordException #-}+{-# SPECIALIZE recordException :: (Exception e) => Span -> AttributeMap -> Maybe Timestamp -> e -> IO () #-}+++{- | Record an error and set the span status in one call.++Combines 'setStatus' with 'Error' and 'recordException'. This is a common+pattern when handling errors outside of 'inSpan' (which does this+automatically for uncaught exceptions).++@+case result of+ Left err -> recordError span err+ Right _ -> setStatus span Ok+@++@since 0.4.1.0+-}+recordError :: (MonadIO m, Exception e) => Span -> e -> m ()+recordError s e = do+ setStatus s $ Error $ T.pack $ displayException e+ recordException s H.empty Nothing e+{-# INLINE recordError #-}+++{- | Returns @True@ if the @SpanContext@ has a non-zero @TraceID@ and a non-zero @SpanID@.+Spec: "true if the SpanContext has a non-zero TraceID and a non-zero SpanID".++ @since 0.0.1.0+-}+isValid :: SpanContext -> Bool+isValid sc =+ not (isEmptyTraceId (traceId sc)) && not (isEmptySpanId (spanId sc))+++{- |+Returns @True@ if the @SpanContext@ was propagated from a remote parent,++When extracting a SpanContext through the Propagators API, isRemote MUST return @True@,+whereas for the SpanContext of any child spans it MUST return @False@.++ @since 0.0.1.0+-}+spanIsRemote :: (MonadIO m) => Span -> m Bool+spanIsRemote (Span imm) = pure $ Types.isRemote $ Types.spanContext imm+spanIsRemote (FrozenSpan c) = pure $ Types.isRemote c+spanIsRemote (Dropped _) = pure False+++{- | Really only intended for tests, this function does not conform+ to semantic versioning .++ @since 0.0.1.0+-}+unsafeReadSpan :: (MonadIO m) => Span -> m ImmutableSpan+unsafeReadSpan s =+ toImmutableSpan s >>= \case+ Right span -> pure span+ Left frozenOrDropped -> case frozenOrDropped of+ SpanFrozen -> error "This span is from another process"+ SpanDropped -> error "This span was dropped"+++{- | Wrap a 'SpanContext' as a non-recording 'Span' ('FrozenSpan').++@since 0.0.1.0+-}+wrapSpanContext :: SpanContext -> Span+wrapSpanContext = FrozenSpan+++{- | Construct a non-recording parent span representing a dropped (not sampled) trace,+e.g. for tests or when continuing a trace whose parent was not recorded.++@since 0.4.0.0+-}+wrapDroppedContext :: SpanContext -> Span+wrapDroppedContext = Dropped+++{- | This can be useful for pulling data for attributes and+ using it to copy / otherwise use the data to further enrich+ instrumentation.++ @since 0.0.1.0+-}+spanGetAttributes :: (MonadIO m) => Span -> m A.Attributes+spanGetAttributes = \case+ Span imm -> liftIO $ hotAttributes <$> readIORef (spanHot imm)+ FrozenSpan _ -> pure A.emptyAttributes+ Dropped _ -> pure A.emptyAttributes+++{- | Sometimes, you may have a more accurate notion of when a traced+ operation has ended. In this case you may call 'getTimestamp', and then+ supply 'endSpan' with the more accurate timestamp you have acquired.++ When using the monadic interface, (such as 'OpenTelemetry.Trace.Monad.inSpan', you may call+ 'endSpan' early to record the information, and the first call to 'endSpan' will be honored.++ @since 0.0.1.0+-}+getTimestamp :: (MonadIO m) => m Timestamp+getTimestamp = liftIO getTimestampIO+{-# INLINE getTimestamp #-}+++foreign import ccall unsafe "hs_otel_gettime_ns"+ getTimestampIO :: IO Timestamp+++globalTracer :: IORef TracerProvider+globalTracer = unsafePerformIO $ do+ p <-+ createTracerProvider+ []+ emptyTracerProviderOptions+ newIORef p+{-# NOINLINE globalTracer #-}+++{- | Options used when creating a 'TracerProvider'.++@since 0.0.1.0+-}+data TracerProviderOptions = TracerProviderOptions+ { tracerProviderOptionsIdGenerator :: IdGenerator+ , tracerProviderOptionsSampler :: Sampler+ , tracerProviderOptionsResources :: MaterializedResources+ , tracerProviderOptionsAttributeLimits :: AttributeLimits+ , tracerProviderOptionsSpanLimits :: SpanLimits+ , tracerProviderOptionsPropagators :: TextMapPropagator+ , tracerProviderOptionsExceptionHandlers :: [ExceptionHandler]+ {- ^ Exception handlers consulted (after any tracer-level handlers) when+ 'inSpan' catches an exception. Defaults to @[]@ (all exceptions are errors).++ @since 0.4.0.0+ -}+ }+++{- | Options for creating a 'TracerProvider' with invalid ids, no resources, default limits, and no propagators.++ In effect, tracing is a no-op when using this configuration.++ @since 0.0.1.0+-}+emptyTracerProviderOptions :: TracerProviderOptions+emptyTracerProviderOptions =+ TracerProviderOptions+ { tracerProviderOptionsIdGenerator = dummyIdGenerator+ , tracerProviderOptionsSampler = parentBased $ parentBasedOptions alwaysOn+ , tracerProviderOptionsResources = emptyMaterializedResources+ , tracerProviderOptionsAttributeLimits = defaultAttributeLimits+ , tracerProviderOptionsSpanLimits = defaultSpanLimits+ , tracerProviderOptionsPropagators = mempty+ , tracerProviderOptionsExceptionHandlers = []+ }+++{- | Initialize a new tracer provider++ You should generally use 'getGlobalTracerProvider' for most applications.++ @since 0.0.1.0+-}+createTracerProvider :: (MonadIO m) => [SpanProcessor] -> TracerProviderOptions -> m TracerProvider+createTracerProvider ps opts = liftIO $ do+ let g = tracerProviderOptionsIdGenerator opts+ !procsVec = V.fromList ps+ !hasProc = not (V.null procsVec)+ !onStart = case V.length procsVec of+ 0 -> \_ _ -> pure ()+ 1 -> spanProcessorOnStart (V.unsafeHead procsVec)+ _ -> \imm ctx -> V.mapM_ (\p -> spanProcessorOnStart p imm ctx) procsVec+ !onEnd = case V.length procsVec of+ 0 -> \_ -> pure ()+ 1 -> spanProcessorOnEnd (V.unsafeHead procsVec)+ _ -> \imm -> V.mapM_ (\p -> spanProcessorOnEnd p imm) procsVec+ shutRef <- newIORef False+ cacheRef <- newIORef H.empty+ pure $+ TracerProvider+ { tracerProviderOnStart = onStart+ , tracerProviderOnEnd = onEnd+ , tracerProviderProcessors = procsVec+ , tracerProviderHasProcessor = hasProc+ , tracerProviderIdGenerator = g+ , tracerProviderSampler = tracerProviderOptionsSampler opts+ , tracerProviderResources = tracerProviderOptionsResources opts+ , tracerProviderAttributeLimits = tracerProviderOptionsAttributeLimits opts+ , tracerProviderSpanLimits = tracerProviderOptionsSpanLimits opts+ , tracerProviderPropagators = tracerProviderOptionsPropagators opts+ , tracerProviderExceptionHandlers = tracerProviderOptionsExceptionHandlers opts+ , tracerProviderIsShutdown = shutRef+ , tracerProviderTracerCache = cacheRef+ }+++{- | Access the globally configured 'TracerProvider'. Once the+ the global tracer provider is initialized via the OpenTelemetry SDK,+ 'Tracer's created from this 'TracerProvider' will export spans to their+ configured exporters. Prior to that, any 'Tracer's acquired from the+ uninitialized 'TracerProvider' will create no-op spans.++ @since 0.0.1.0+-}+getGlobalTracerProvider :: (MonadIO m) => m TracerProvider+getGlobalTracerProvider = liftIO $ readIORef globalTracer+++{- | Overwrite the globally configured 'TracerProvider'.++ 'Tracer's acquired from the previously installed 'TracerProvider'+ will continue to use that 'TracerProvider's configured span processors,+ exporters, and other settings.++ @since 0.0.1.0+-}+setGlobalTracerProvider :: (MonadIO m) => TracerProvider -> m ()+setGlobalTracerProvider = liftIO . atomicWriteIORef globalTracer+++-- | @since 0.0.1.0+getTracerProviderResources :: TracerProvider -> MaterializedResources+getTracerProviderResources = tracerProviderResources+++-- | @since 0.0.1.0+getTracerProviderPropagators :: TracerProvider -> TextMapPropagator+getTracerProviderPropagators = tracerProviderPropagators+++{- | Tracer configuration options.++@since 0.0.1.0+-}+data TracerOptions = TracerOptions+ { tracerSchema :: Maybe Text+ {- ^ OpenTelemetry provides a schema for describing common attributes so that backends can easily parse and identify relevant information.+ It is important to understand these conventions when writing instrumentation, in order to normalize your data and increase its utility.++ In particular, this option is valuable to set when possible, because it allows vendors to normalize data accross releases in order to account+ for attribute name changes.+ -}+ , tracerExceptionHandlerOptions :: [ExceptionHandler]+ {- ^ Exception handlers specific to this tracer, consulted before+ provider-level handlers. Defaults to @[]@.++ @since 0.4.0.0+ -}+ }+++{- | Default Tracer options++@since 0.0.1.0+-}+tracerOptions :: TracerOptions+tracerOptions = TracerOptions Nothing []+++{- | A small utility lens for extracting a 'Tracer' from a larger data type++ This will generally be most useful as a means of implementing 'OpenTelemetry.Trace.Monad.getTracer'++ @since 0.0.1.0+-}+class HasTracer s where+ tracerL :: Lens' s Tracer+++{- | Construct a 'Tracer' from a provider, library, and options.++Prefer a non-empty 'libraryName' per the OpenTelemetry specification; use 'getTracer'+if you want a warning when the name is empty.++@since 0.0.1.0+-}+makeTracer :: TracerProvider -> InstrumentationLibrary -> TracerOptions -> Tracer+makeTracer tp n opts =+ let n' = case tracerSchema opts of+ Nothing -> n+ Just s -> n {librarySchemaUrl = s}+ resolveLimits countF =+ AttributeLimits+ { attributeCountLimit =+ countF (tracerProviderSpanLimits tp)+ <|> attributeCountLimit (tracerProviderAttributeLimits tp)+ , attributeLengthLimit =+ spanAttributeValueLengthLimit (tracerProviderSpanLimits tp)+ <|> attributeLengthLimit (tracerProviderAttributeLimits tp)+ }+ !sl = tracerProviderSpanLimits tp+ in Tracer+ { tracerName = n'+ , tracerProvider = tp+ , tracerExceptionHandlers = tracerExceptionHandlerOptions opts+ , tracerSpanAttributeLimits = resolveLimits spanAttributeCountLimit+ , tracerEventAttributeLimits = resolveLimits eventAttributeCountLimit+ , tracerLinkAttributeLimits = resolveLimits linkAttributeCountLimit+ , tracerEventCountLimit = fromMaybe 128 (eventCountLimit sl)+ , tracerLinkCountLimit = fromMaybe 128 (linkCountLimit sl)+ }+++{- | Like 'makeTracer' but caches by 'InstrumentationLibrary', so repeated+calls with the same scope return the same 'Tracer' instance.+Spec: implementations SHOULD return a single Tracer per InstrumentationScope.++@since 0.0.1.0+-}+getTracer :: (MonadIO m) => TracerProvider -> InstrumentationLibrary -> TracerOptions -> m Tracer+getTracer tp n opts = liftIO $ do+ when (T.null (libraryName n)) $+ otelLogWarning "Tracer created with empty name; returning working Tracer with empty name per spec"+ let !t = makeTracer tp n opts+ !key = tracerName t+ atomicModifyIORef' (tracerProviderTracerCache tp) $ \cache ->+ case H.lookup key cache of+ Just cached -> (cache, cached)+ Nothing -> (H.insert key t cache, t)+++-- | @since 0.0.1.0+getImmutableSpanTracer :: ImmutableSpan -> Tracer+getImmutableSpanTracer = spanTracer+++-- | @since 0.0.1.0+getTracerTracerProvider :: Tracer -> TracerProvider+getTracerTracerProvider = tracerProvider+++{- | Check if the 'Tracer' is enabled.++ This function helps users avoid performing computationally expensive operations+ when creating 'Span's if the tracer is not enabled.++ A 'Tracer' is considered enabled if it has at least one configured processor.+ If the 'TracerProvider' has no processors, all spans will be dropped, so the+ tracer is disabled.++ Callers SHOULD invoke this before each span creation to get the most up-to-date+ response, as the result may change over time.++ @since 0.3.1.0+-}+tracerIsEnabled :: Tracer -> Bool+tracerIsEnabled t = tracerProviderHasProcessor $ tracerProvider t+++{- | Smart constructor for 'SpanArguments' providing reasonable values for most 'Span's created+ that are internal to an application.++ Defaults:++ - `kind`: `Internal`+ - `attributes`: @[]@+ - `links`: @[]@+ - `startTime`: `Nothing` (`getTimestamp` will be called upon `Span` creation)++ @since 0.0.1.0+-}+defaultSpanArguments :: SpanArguments+defaultSpanArguments =+ SpanArguments+ { kind = Internal+ , attributes = []+ , links = []+ , startTime = Nothing+ }+++{- | This method provides a way for provider to do any cleanup required.++ This will also trigger shutdowns on all internal processors.++ @since 0.0.1.0+-}+shutdownTracerProvider+ :: (MonadIO m)+ => TracerProvider+ -> Maybe Int+ -- ^ Optional timeout in microseconds, defaults to 5,000,000 (5s)+ -> m ShutdownResult+shutdownTracerProvider TracerProvider {..} mtimeout = liftIO $ do+ alreadyShut <- atomicModifyIORef' tracerProviderIsShutdown $ \s -> (True, s)+ if alreadyShut+ then pure ShutdownFailure+ else do+ jobs <- V.mapM (async . spanProcessorShutdown) tracerProviderProcessors+ mresult <-+ timeout (fromMaybe 5_000_000 mtimeout) $+ V.foldM'+ ( \status action -> do+ res <- waitCatch action+ pure $! case res of+ Left _err -> worstShutdown status ShutdownFailure+ Right sr -> worstShutdown status sr+ )+ ShutdownSuccess+ jobs+ case mresult of+ Nothing -> do+ V.mapM_ cancel jobs+ pure ShutdownTimeout+ Just res -> pure res+++{- | This method provides a way for provider to immediately export all spans that have not yet+ been exported for all the internal processors.++ @since 0.0.1.0+-}+forceFlushTracerProvider+ :: (MonadIO m)+ => TracerProvider+ -> Maybe Int+ -- ^ Optional timeout in microseconds, defaults to 5,000,000 (5s)+ -> m FlushResult+ -- ^ Result that denotes whether the flush action succeeded, failed, or timed out.+forceFlushTracerProvider TracerProvider {..} mtimeout = liftIO $ do+ isShut <- readIORef tracerProviderIsShutdown+ if isShut+ then pure FlushError+ else do+ jobs <- V.forM tracerProviderProcessors $ \processor ->+ async $+ spanProcessorForceFlush processor+ mresult <-+ timeout (fromMaybe 5_000_000 mtimeout) $+ V.foldM'+ ( \status action -> do+ res <- waitCatch action+ pure $! case res of+ Left _err -> FlushError+ Right fr -> worstFlush status fr+ )+ FlushSuccess+ jobs+ case mresult of+ Nothing -> do+ V.mapM_ cancel jobs+ pure FlushTimeout+ Just res -> pure res+++{- | Run an action only when the span is recording. Use this to guard+expensive attribute computation that would be wasted on non-recording spans.++ @since 0.0.1.0+-}+whenSpanIsRecording :: (MonadIO m) => Span -> m () -> m ()+whenSpanIsRecording (Span imm) m = do+ hot <- liftIO $ readIORef (spanHot imm)+ case hotEnd hot of+ NoTimestamp -> m+ _ -> pure ()+whenSpanIsRecording (FrozenSpan _) _ = pure ()+whenSpanIsRecording (Dropped _) _ = pure ()+++{- | Retrieve the active 'Span' from the current thread's context.++Returns 'Nothing' if there is no span in the current context (e.g. at+the top level, before any tracing has started).++This is the Haskell equivalent of Go's @trace.SpanFromContext(ctx)@ and+Rust's @get_active_span@.++@since 0.4.1.0+-}+getActiveSpan :: (MonadIO m) => m (Maybe Span)+getActiveSpan = lookupSpan <$> getContext+{-# INLINE getActiveSpan #-}+++{- | Run an action on the active span. If there is no active span in the+current context, the action is silently skipped.++@+withActiveSpan $ \\span -> do+ addAttribute span "user.id" (toAttribute userId)+ addEvent span (newEvent "cache-miss")+@++@since 0.4.1.0+-}+withActiveSpan :: (MonadIO m) => (Span -> m ()) -> m ()+withActiveSpan f = do+ mSpan <- getActiveSpan+ forM_ mSpan f+{-# INLINE withActiveSpan #-}+++{- | Retrieve the 'SpanContext' of the active span, useful for log+correlation (extracting trace\/span IDs) without needing the full 'Span'+handle.++@since 0.4.1.0+-}+getActiveSpanContext :: (MonadIO m) => m (Maybe SpanContext)+getActiveSpanContext = do+ mSpan <- getActiveSpan+ case mSpan of+ Nothing -> pure Nothing+ Just s -> Just <$> getSpanContext s+{-# INLINE getActiveSpanContext #-}+++{- | Nanoseconds since the Unix epoch.++@since 0.0.1.0+-}+timestampNanoseconds :: Timestamp -> Word64+timestampNanoseconds = coerce+{-# INLINE timestampNanoseconds #-}
+ src/OpenTelemetry/Trace/ExceptionHandler.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++{- |+Module : OpenTelemetry.Trace.ExceptionHandler+Copyright : (c) Ian Duncan, 2024+License : BSD-3+Description : Exception classification for tracing+Maintainer : Ian Duncan+Stability : experimental+Portability : non-portable (GHC extensions)++Register exception handlers on a 'TracerProvider' or 'Tracer' to control how+exceptions interact with span status and events.++By default, every exception caught by 'inSpan' sets the span status to+'Error' and records an exception event. This module provides combinators to+override that behavior for specific exception types. For example, treating+'System.Exit.ExitSuccess' or 'Control.Exception.AsyncCancelled' as+non-errors.++@since 0.4.0.0+-}+module OpenTelemetry.Trace.ExceptionHandler (+ -- * Types+ ExceptionClassification (..),+ ExceptionResponse (..),+ ExceptionHandler,+ defaultExceptionResponse,++ -- * Smart constructors+ ignoreExceptionType,+ ignoreExceptionMatching,+ recordExceptionType,+ recordExceptionMatching,+ classifyException,++ -- * Common handlers+ exitSuccessHandler,++ -- * Resolution+ resolveException,+) where++import Control.Exception (Exception (..), SomeException (..))+import qualified Data.HashMap.Strict as H+import OpenTelemetry.Internal.Trace.Types+import System.Exit (ExitCode (..))+++{- | Ignore all exceptions of the given type. They will not be recorded as+events and will not set the span status to Error.++@+import Control.Exception (AsyncCancelled)++myHandlers = [ignoreExceptionType \@AsyncCancelled]+@++@since 0.4.0.0+-}+ignoreExceptionType :: forall e. (Exception e) => ExceptionHandler+ignoreExceptionType (SomeException ex) = case fromException @e (SomeException ex) of+ Just _ -> Just $ ExceptionResponse IgnoredException H.empty+ Nothing -> Nothing+++{- | Ignore exceptions of the given type that match a predicate.++@+ignoreExceptionMatching \@ExitCode (== ExitSuccess)+@++@since 0.4.0.0+-}+ignoreExceptionMatching :: forall e. (Exception e) => (e -> Bool) -> ExceptionHandler+ignoreExceptionMatching p (SomeException ex) = case fromException @e (SomeException ex) of+ Just e+ | p e -> Just $ ExceptionResponse IgnoredException H.empty+ _ -> Nothing+++{- | Record exceptions of the given type as events but do not set the span+status to Error. The exception remains visible in traces but is not counted+as an error.++@since 0.4.0.0+-}+recordExceptionType :: forall e. (Exception e) => ExceptionHandler+recordExceptionType (SomeException ex) = case fromException @e (SomeException ex) of+ Just _ -> Just $ ExceptionResponse RecordedException H.empty+ Nothing -> Nothing+++{- | Record exceptions of the given type matching a predicate as events,+without setting Error status.++@since 0.4.0.0+-}+recordExceptionMatching :: forall e. (Exception e) => (e -> Bool) -> ExceptionHandler+recordExceptionMatching p (SomeException ex) = case fromException @e (SomeException ex) of+ Just e+ | p e -> Just $ ExceptionResponse RecordedException H.empty+ _ -> Nothing+++{- | Full control: inspect an exception and return a classification with+optional extra attributes. Use this to enrich spans with domain-specific+information extracted from the exception.++@+classifyException \@HttpException $ \\(HttpException status _body) ->+ ExceptionResponse ErrorException+ (HashMap.fromList [("http.response.status_code", toAttribute (statusCode status))])+@++@since 0.4.0.0+-}+classifyException :: forall e. (Exception e) => (e -> ExceptionResponse) -> ExceptionHandler+classifyException f (SomeException ex) = case fromException @e (SomeException ex) of+ Just e -> Just (f e)+ Nothing -> Nothing+++{- | Handler that classifies 'ExitSuccess' as ignored. 'ExitFailure' is left+unhandled (falls through to the next handler or the default).++This is a common handler to register globally:++@+opts = emptyTracerProviderOptions+ { tracerProviderOptionsExceptionHandlers = [exitSuccessHandler]+ }+@++@since 0.4.0.0+-}+exitSuccessHandler :: ExceptionHandler+exitSuccessHandler = ignoreExceptionMatching @ExitCode (== ExitSuccess)
src/OpenTelemetry/Trace/Id.hs view
@@ -42,6 +42,9 @@ -- ** Creating 'SpanId's newSpanId, + -- ** Combined generation (root spans)+ newTraceAndSpanId,+ -- ** Checking 'SpanId's for validity isEmptySpanId, @@ -55,6 +58,14 @@ spanIdBaseEncodedBuilder, spanIdBaseEncodedByteString, spanIdBaseEncodedText,++ -- * Nil (all-zero) IDs+ nilTraceId,+ nilSpanId,++ -- * Traceparent encoding/decoding+ decodeTraceparent,+ encodeTraceparent, ) where import OpenTelemetry.Internal.Trace.Id
src/OpenTelemetry/Trace/Id/Generator.hs view
@@ -1,35 +1,83 @@-------------------------------------------------------------------------------------------------------------------------------------------------------------- {- |- Module : OpenTelemetry.Id.Generator- Copyright : (c) Ian Duncan, 2021- License : BSD-3- Description : Raw byte generation facilities for ID generation- Maintainer : Ian Duncan- Stability : experimental- Portability : non-portable (GHC extensions)+Module : OpenTelemetry.Id.Generator+Copyright : (c) Ian Duncan, 2021+License : BSD-3+Description : ID generation strategies for trace and span identifiers+Maintainer : Ian Duncan+Stability : experimental+Portability : non-portable (GHC extensions) - Stateful random number generation interface for creating Trace and Span ID- bytes.+Pluggable ID generation for creating Trace and Span ID bytes. - In most cases, the built-in generator in the hs-opentelemetry-sdk will be sufficient, but the- interface is exposed for more exotic needs.+The default generator ('DefaultIdGenerator') uses a thread-local+xoshiro256++ PRNG seeded from the platform's native random source+(arc4random_buf on macOS, getrandom on Linux, BCryptGenRandom on+Windows). It is not cryptographically secure but is significantly+faster than a CSPRNG due to zero contention and no syscalls after+initial seeding. This matches the approach used by the Java OTel SDK+(@ThreadLocalRandom@). The OTel spec requires IDs to be "randomly+generated" but does not mandate cryptographic strength.++For fully custom generation (e.g. deterministic testing), use+'customIdGenerator' to provide your own functions. -} module OpenTelemetry.Trace.Id.Generator ( IdGenerator (..),+ customIdGenerator, ) where -import Data.ByteString (ByteString)+import Data.ByteString.Short (ShortByteString) -{- | An interface for generating the underlying bytes for- trace and span ids.+{- | Strategy for generating trace and span IDs.++Pattern-matching on known constructors in the hot path lets GHC+inline the generation functions directly, eliminating the indirect+call overhead of a record-of-functions approach.++ @since 0.0.1.0 -}-data IdGenerator = IdGenerator- { generateSpanIdBytes :: IO ByteString- -- ^ MUST generate exactly 8 bytes- , generateTraceIdBytes :: IO ByteString- -- ^ MUST generate exactly 16 bytes- }+data IdGenerator+ = {- | Thread-local xoshiro256++ PRNG seeded from the platform CSPRNG.++ Each OS thread gets its own PRNG state, seeded once from the+ platform CSPRNG. Subsequent ID generation is pure arithmetic+ with no syscalls, no shared state, and no atomic operations.++ xoshiro256++ passes BigCrush and PractRand with a period of+ 2^256−1. Fork-safe: child processes reseed automatically via+ @pthread_atfork@.++ @since 0.1.0.0+ -}+ DefaultIdGenerator+ | {- | Fully custom generation.++ The first action must produce exactly 8 random bytes (span ID),+ the second exactly 16 bytes (trace ID).++ @since 0.0.1.0+ -}+ CustomIdGenerator+ !(IO ShortByteString)+ !(IO ShortByteString)+++{- | Construct a custom 'IdGenerator' from two actions producing raw ID bytes.++@+deterministicGen :: IORef Word64 -> IdGenerator+deterministicGen ref = customIdGenerator+ (genBytes ref 8) -- span ID: 8 bytes+ (genBytes ref 16) -- trace ID: 16 bytes+@++ @since 0.0.1.0+-}+customIdGenerator+ :: IO ShortByteString+ -- ^ Generate 8 bytes for span ID+ -> IO ShortByteString+ -- ^ Generate 16 bytes for trace ID+ -> IdGenerator+customIdGenerator = CustomIdGenerator
src/OpenTelemetry/Trace/Id/Generator/Dummy.hs view
@@ -3,10 +3,11 @@ import OpenTelemetry.Trace.Id.Generator --- | A non-functioning id generator for use when an SDK is not installed+{- | A non-functioning id generator for use when an SDK is not installed.++Uses 'DefaultIdGenerator' so ID generation is available if spans+are ever actually created (the no-processor path short-circuits+before ID generation, so this is never called in practice).+-} dummyIdGenerator :: IdGenerator-dummyIdGenerator =- IdGenerator- { generateSpanIdBytes = pure "\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL"- , generateTraceIdBytes = pure "\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL"- }+dummyIdGenerator = DefaultIdGenerator
src/OpenTelemetry/Trace/Monad.hs view
@@ -2,23 +2,46 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} ------------------------------------------------------------------------------+{- |+Module : OpenTelemetry.Trace.Monad+Copyright : (c) Ian Duncan, 2021-2026+License : BSD-3+Description : Monadic tracing API+Stability : experimental ------------------------------------------------------------------------------+= Overview -{- |- Module : OpenTelemetry.Trace.Monad- Copyright : (c) Ian Duncan, 2021- License : BSD-3- Description : Higher-level tracing API- Maintainer : Ian Duncan- Stability : experimental- Portability : non-portable (GHC extensions)+Higher-level tracing interface that obtains the 'Tracer' from your monad+stack via 'MonadTracer', eliminating the need to pass it explicitly. - The recommended tracing interface for application developers+= Quick example - See OpenTelemetry.Trace for an interface that's- more lower-level, but more flexible.+@+data App = App { appTracer :: Tracer }++instance MonadTracer (ReaderT App IO) where+ getTracer = asks appTracer++handleRequest :: (MonadUnliftIO m, MonadTracer m) => Request -> m Response+handleRequest req = inSpan "handleRequest" defaultSpanArguments $ do+ user <- inSpan "lookupUser" defaultSpanArguments $ lookupUser req+ inSpan "buildResponse" defaultSpanArguments $ buildResponse user+@++= Variants++* 'inSpan' : simple wrapper, no span access in callback+* 'OpenTelemetry.Trace.Monad.inSpan'' : passes the 'Span' to the callback for adding attributes+* 'OpenTelemetry.Trace.Monad.inSpan''' : raw variant, no automatic source-location capture++All variants automatically end the span and record exceptions, just like+their counterparts in "OpenTelemetry.Trace.Core".++= When to use this vs Trace.Core++Use this module when your application has a monad stack with a 'Tracer'+in the environment. Use "OpenTelemetry.Trace.Core" when you have the+'Tracer' as an explicit argument or need lower-level control. -} module OpenTelemetry.Trace.Monad ( inSpan,@@ -37,9 +60,9 @@ ) where import Control.Monad.IO.Unlift-import Control.Monad.Identity (IdentityT)-import Control.Monad.Reader (ReaderT)-import Control.Monad.Trans (MonadTrans (lift))+import Control.Monad.Trans.Class (MonadTrans (lift))+import Control.Monad.Trans.Identity (IdentityT)+import Control.Monad.Trans.Reader (ReaderT) import Data.Text (Text) import GHC.Stack import OpenTelemetry.Trace.Core (@@ -52,11 +75,15 @@ ) --- | This is generally scoped by Monad stack to do different things+{- | This is generally scoped by Monad stack to do different things++@since 0.0.1.0+-} class (Monad m) => MonadTracer m where getTracer :: m Tracer +-- | @since 0.0.1.0 inSpan :: (MonadUnliftIO m, MonadTracer m, HasCallStack) => Text@@ -66,6 +93,7 @@ inSpan n args m = OpenTelemetry.Trace.Monad.inSpan'' n (addAttributesToSpanArguments callerAttributes args) (const m) +-- | @since 0.0.1.0 inSpan' :: (MonadUnliftIO m, MonadTracer m, HasCallStack) => Text@@ -75,6 +103,7 @@ inSpan' n args f = OpenTelemetry.Trace.Monad.inSpan'' n (addAttributesToSpanArguments callerAttributes args) f +-- | @since 0.4.0.0 inSpan'' :: (MonadUnliftIO m, MonadTracer m, HasCallStack) => Text
src/OpenTelemetry/Trace/Sampler.hs view
@@ -1,4 +1,6 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE RecordWildCards #-} {- | Module : OpenTelemetry.Trace.Sampler@@ -11,35 +13,48 @@ This module provides several built-in sampling strategies, as well as the ability to define custom samplers. - Sampling is the concept of selecting a few elements from a large collection and learning about the entire collection by extrapolating from the selected set. It’s widely used throughout the world whenever trying to tackle a problem of scale: for example, a survey assumes that by asking a small group of people a set of questions, you can learn something about the opinions of the entire populace.+ Sampling is the concept of selecting a few elements from a large collection and learning about the entire collection by extrapolating from the selected set. It's widely used throughout the world whenever trying to tackle a problem of scale: for example, a survey assumes that by asking a small group of people a set of questions, you can learn something about the opinions of the entire populace. - While it’s nice to believe that every event is precious, the reality of monitoring high volume production infrastructure is that there are some attributes to events that make them more interesting than the rest. Failures are often more interesting than successes! Rare events are more interesting than common events! Capturing some traffic from all customers can be better than capturing all traffic from some customers.+ While it's nice to believe that every event is precious, the reality of monitoring high volume production infrastructure is that there are some attributes to events that make them more interesting than the rest. Failures are often more interesting than successes! Rare events are more interesting than common events! Capturing some traffic from all customers can be better than capturing all traffic from some customers. - Sampling as a basic technique for instrumentation is no different—by recording information about a representative subset of requests flowing through a system, you can learn about the overall performance of the system. And as with surveys and air monitoring, the way you choose your representative set (the sample set) can greatly influence the accuracy of your results.+ Sampling as a basic technique for instrumentation is no different. By recording information about a representative subset of requests flowing through a system, you can learn about the overall performance of the system. And as with surveys and air monitoring, the way you choose your representative set (the sample set) can greatly influence the accuracy of your results. - Sampling is widespread in observability systems because it lowers the cost of producing, collecting, and analyzing data in systems anywhere cost is a concern. Developers and operators in an observability system apply or attach key=value properties to observability data–spans and metrics–and we use these properties to investigate hypotheses about our systems after the fact. It is interesting to look at how sampling impacts our ability to analyze observability data, using key=value restrictions for some keys and grouping the output based on other keys.+ Sampling is widespread in observability systems because it lowers the cost of producing, collecting, and analyzing data in systems anywhere cost is a concern. Developers and operators in an observability system apply or attach key=value properties to observability data, spans and metrics, and we use these properties to investigate hypotheses about our systems after the fact. It is interesting to look at how sampling impacts our ability to analyze observability data, using key=value restrictions for some keys and grouping the output based on other keys. Sampling schemes let observability systems collect examples of data that are not merely exemplary, but also representative. Sampling schemes compute a set of representative items and, in doing so, score each item with what is commonly called the item's "sampling rate." A sampling rate of 10 indicates that the item represents an estimated 10 individuals in the original data set. -} module OpenTelemetry.Trace.Sampler (+ -- * Types Sampler (..), SamplingResult (..),- parentBased,- parentBasedOptions,+ SamplingDecision (..), ParentBasedOptions (..),- traceIdRatioBased,++ -- * Running samplers+ shouldSample,+ getDescription,++ -- * Built-in samplers alwaysOn, alwaysOff,+ traceIdRatioBased,+ parentBased,+ parentBasedOptions,+ alwaysRecord, ) where -import Data.Binary.Get import Data.Bits-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import qualified Data.Text as T-import Data.Word (Word64)+import qualified Data.HashMap.Strict as H+import Data.Text (Text)+import qualified Data.Text.Lazy as TL+import Data.Text.Lazy.Builder (toLazyText)+import Data.Text.Lazy.Builder.RealFloat (realFloat)+import Data.Word (Word64, byteSwap64)+import GHC.ByteOrder (ByteOrder (..), targetByteOrder) import OpenTelemetry.Attributes (toAttribute) import OpenTelemetry.Context+import OpenTelemetry.Internal.Common.Types (InstrumentationLibrary)+import OpenTelemetry.Internal.Trace.Id (TraceId (..)) import OpenTelemetry.Internal.Trace.Types import OpenTelemetry.Trace.Id import OpenTelemetry.Trace.TraceState as TraceState@@ -52,13 +67,7 @@ @since 0.1.0.0 -} alwaysOn :: Sampler-alwaysOn =- Sampler- { getDescription = "AlwaysOnSampler"- , shouldSample = \ctxt _ _ _ -> do- mspanCtxt <- sequence (getSpanContext <$> lookupSpan ctxt)- pure (RecordAndSample, [], maybe TraceState.empty traceState mspanCtxt)- }+alwaysOn = AlwaysOnSampler {- | Returns @Drop@ always.@@ -68,13 +77,7 @@ @since 0.1.0.0 -} alwaysOff :: Sampler-alwaysOff =- Sampler- { getDescription = "AlwaysOffSampler"- , shouldSample = \ctxt _ _ _ -> do- mspanCtxt <- sequence (getSpanContext <$> lookupSpan ctxt)- pure (Drop, [], maybe TraceState.empty traceState mspanCtxt)- }+alwaysOff = AlwaysOffSampler {- | The TraceIdRatioBased ignores the parent SampledFlag. To respect the parent SampledFlag,@@ -87,28 +90,14 @@ -} traceIdRatioBased :: Double -> Sampler traceIdRatioBased fraction =- if fraction >= 1- then alwaysOn- else sampler+ TraceIdRatioSampler safeFraction traceIdUpperBound sampleRate where- safeFraction = max fraction 0+ safeFraction = max 0 (min 1 fraction) sampleRate = if safeFraction > 0 then toAttribute ((round (1 / safeFraction)) :: Int) else toAttribute (0 :: Int)-- traceIdUpperBound = floor (fraction * fromIntegral ((1 :: Word64) `shiftL` 63)) :: Word64- sampler =- Sampler- { getDescription = "TraceIdRatioBased{" <> T.pack (show fraction) <> "}"- , shouldSample = \ctxt tid _ _ -> do- mspanCtxt <- sequence (getSpanContext <$> lookupSpan ctxt)- let x = runGet getWord64be (L.fromStrict $ B.take 8 $ traceIdBytes tid) `shiftR` 1- if x < traceIdUpperBound- then do- pure (RecordAndSample, [("sampleRate", sampleRate)], maybe TraceState.empty traceState mspanCtxt)- else pure (Drop, [], maybe TraceState.empty traceState mspanCtxt)- }+ traceIdUpperBound = floor (safeFraction * fromIntegral ((1 :: Word64) `shiftL` 63)) :: Word64 {- | This is a composite sampler. ParentBased helps distinguish between the following cases:@@ -125,20 +114,7 @@ @since 0.1.0.0 -}-data ParentBasedOptions = ParentBasedOptions- { rootSampler :: Sampler- -- ^ Sampler called for spans with no parent (root spans)- , remoteParentSampled :: Sampler- -- ^ default: alwaysOn- , remoteParentNotSampled :: Sampler- -- ^ default: alwaysOff- , localParentSampled :: Sampler- -- ^ default: alwaysOn- , localParentNotSampled :: Sampler- -- ^ default: alwaysOff- } - {- | A smart constructor for 'ParentBasedOptions' with reasonable starting defaults. @@ -165,32 +141,128 @@ @since 0.1.0.0 -} parentBased :: ParentBasedOptions -> Sampler-parentBased ParentBasedOptions {..} =- Sampler- { getDescription =- "ParentBased{root="- <> getDescription rootSampler- <> ", remoteParentSampled="- <> getDescription remoteParentSampled- <> ", remoteParentNotSampled="- <> getDescription remoteParentNotSampled- <> ", localParentSampled="- <> getDescription localParentSampled- <> ", localParentNotSampled="- <> getDescription localParentNotSampled- <> "}"- , shouldSample = \ctx tid name csa -> do- mspanCtxt <- sequence (getSpanContext <$> lookupSpan ctx)- case mspanCtxt of- Nothing -> shouldSample rootSampler ctx tid name csa- Just root ->- if OpenTelemetry.Internal.Trace.Types.isRemote root- then- if isSampled $ traceFlags root- then shouldSample remoteParentSampled ctx tid name csa- else shouldSample remoteParentNotSampled ctx tid name csa- else- if isSampled $ traceFlags root- then shouldSample localParentSampled ctx tid name csa- else shouldSample localParentNotSampled ctx tid name csa- }+parentBased = ParentBasedSampler+++{- | A decorator that ensures spans always reach processors (IsRecording=true)+even when the wrapped sampler would DROP them. Per spec:++ - DROP -> RECORD_ONLY (upgraded: processors see it, exporters don't)+ - RECORD_ONLY -> RECORD_ONLY (unchanged)+ - RECORD_AND_SAMPLE -> RECORD_AND_SAMPLE (unchanged)++Useful for span-to-metrics processors or debugging processors that need+visibility into all spans without increasing export volume.++@since 0.2.0.0+-}+alwaysRecord :: Sampler -> Sampler+alwaysRecord = AlwaysRecordSampler+++{- | Execute the sampling decision for a 'Sampler'.++The 'InstrumentationLibrary' parameter is the instrumentation scope of the+'Tracer' creating the span, as required by the spec.+Spec: <https://opentelemetry.io/docs/specs/otel/trace/sdk/#shouldsample>++Non-recursive wrapper handles the two most common leaf samplers+(AlwaysOn / AlwaysOff) inline.++@since 0.0.1.0+-}+shouldSample :: Sampler -> Context -> TraceId -> Text -> SpanArguments -> InstrumentationLibrary -> IO SamplingDecision+shouldSample AlwaysOnSampler ctxt _tid _name _args _scope =+ let !ts = parentTraceState ctxt+ in pure $! SamplingDecision RecordAndSample H.empty ts+shouldSample AlwaysOffSampler ctxt _tid _name _args _scope =+ let !ts = parentTraceState ctxt+ in pure $! SamplingDecision Drop H.empty ts+shouldSample sampler ctxt tid name args scope =+ shouldSampleComplex sampler ctxt tid name args scope+{-# INLINE shouldSample #-}+++shouldSampleComplex :: Sampler -> Context -> TraceId -> Text -> SpanArguments -> InstrumentationLibrary -> IO SamplingDecision+shouldSampleComplex (TraceIdRatioSampler frac upperBound sampleRateAttr) ctxt tid _name _args _scope =+ let !ts = parentTraceState ctxt+ in if frac >= 1+ then pure $! SamplingDecision RecordAndSample (H.singleton "sampleRate" sampleRateAttr) ts+ else+ let !(TraceId _ lo) = tid+ !loBE = case targetByteOrder of+ BigEndian -> lo+ LittleEndian -> byteSwap64 lo+ !x = loBE `shiftR` 1+ in if x < upperBound+ then pure $! SamplingDecision RecordAndSample (H.singleton "sampleRate" sampleRateAttr) ts+ else pure $! SamplingDecision Drop H.empty ts+shouldSampleComplex (ParentBasedSampler ParentBasedOptions {..}) ctxt tid name args scope =+ case parentSpanContext ctxt of+ Nothing -> shouldSample rootSampler ctxt tid name args scope+ Just sc ->+ if OpenTelemetry.Internal.Trace.Types.isRemote sc+ then+ if isSampled (traceFlags sc)+ then shouldSample remoteParentSampled ctxt tid name args scope+ else shouldSample remoteParentNotSampled ctxt tid name args scope+ else+ if isSampled (traceFlags sc)+ then shouldSample localParentSampled ctxt tid name args scope+ else shouldSample localParentNotSampled ctxt tid name args scope+shouldSampleComplex (AlwaysRecordSampler inner) ctxt tid name args scope = do+ decision <- shouldSample inner ctxt tid name args scope+ let !outcome' = case samplingOutcome decision of+ Drop -> RecordOnly+ other -> other+ pure $! decision {samplingOutcome = outcome'}+shouldSampleComplex (CustomSampler _ f) ctxt tid name args scope = f ctxt tid name args scope+shouldSampleComplex AlwaysOnSampler ctxt tid name args scope = shouldSample AlwaysOnSampler ctxt tid name args scope+shouldSampleComplex AlwaysOffSampler ctxt tid name args scope = shouldSample AlwaysOffSampler ctxt tid name args scope+{-# NOINLINE shouldSampleComplex #-}+++{- | Get the sampler's description string.++@since 0.0.1.0+-}+getDescription :: Sampler -> Text+getDescription AlwaysOnSampler = "AlwaysOnSampler"+getDescription AlwaysOffSampler = "AlwaysOffSampler"+getDescription (TraceIdRatioSampler frac _ _) =+ "TraceIdRatioBased{" <> TL.toStrict (toLazyText (realFloat frac)) <> "}"+getDescription (ParentBasedSampler ParentBasedOptions {..}) =+ "ParentBased{root="+ <> getDescription rootSampler+ <> ", remoteParentSampled="+ <> getDescription remoteParentSampled+ <> ", remoteParentNotSampled="+ <> getDescription remoteParentNotSampled+ <> ", localParentSampled="+ <> getDescription localParentSampled+ <> ", localParentNotSampled="+ <> getDescription localParentNotSampled+ <> "}"+getDescription (AlwaysRecordSampler inner) =+ "AlwaysRecord{" <> getDescription inner <> "}"+getDescription (CustomSampler desc _) = desc+++{- | Extract the parent's 'SpanContext' from the 'Context', if present.+Pure: 'getSpanContext' on all 'Span' constructors is non-effectful.+-}+parentSpanContext :: Context -> Maybe SpanContext+parentSpanContext ctxt = case lookupSpan ctxt of+ Nothing -> Nothing+ Just (Span imm) -> Just (spanContext imm)+ Just (FrozenSpan sc) -> Just sc+ Just (Dropped sc) -> Just sc+{-# INLINE parentSpanContext #-}+++-- | Extract the parent's 'TraceState', defaulting to empty.+parentTraceState :: Context -> TraceState+parentTraceState ctxt = case parentSpanContext ctxt of+ Nothing -> TraceState.empty+ Just sc -> traceState sc+{-# INLINE parentTraceState #-}
src/OpenTelemetry/Trace/TraceState.hs view
@@ -1,7 +1,3 @@-------------------------------------------------------------------------------------------------------------------------------------------------------------- {- | Module : OpenTelemetry.Trace.TraceState Copyright : (c) Ian Duncan, 2021@@ -24,13 +20,17 @@ Value (..), empty, fromList,+ lookup, insert, update, delete, toList,+ maxTraceStateEntries, ) where +import Data.List (find) import Data.Text (Text)+import Prelude hiding (lookup) newtype Key = Key Text@@ -53,21 +53,40 @@ empty = TraceState [] -{- | Create a 'TraceState' from a list of key-value pairs+{- | Create a 'TraceState' from a list of key-value pairs. - O(1)+Silently truncates to 32 entries (W3C spec limit).++ O(n) when list exceeds 32 entries, O(1) otherwise. -} fromList :: [(Key, Value)] -> TraceState-fromList = TraceState+fromList = TraceState . take maxTraceStateEntries -{- | Add a key-value pair to a 'TraceState'+{- | Get the value associated with a given key. O(n) -}+lookup :: Key -> TraceState -> Maybe Value+lookup k (TraceState ts) = snd <$> find (\(k', _) -> k' == k) ts+++{- | Add a key-value pair to a 'TraceState'.++If the key already exists, the entry is updated and moved to the front.+The W3C spec limits tracestate to 32 list-members; if inserting a new key+would exceed that limit, the rightmost (oldest) entry is dropped.++ O(n)+-} insert :: Key -> Value -> TraceState -> TraceState insert k v ts = case delete k ts of- (TraceState l) -> TraceState ((k, v) : l)+ (TraceState l) -> TraceState $ take maxTraceStateEntries ((k, v) : l)+++-- | W3C spec maximum: 32 list-members.+maxTraceStateEntries :: Int+maxTraceStateEntries = 32 {- | Update a value in the 'TraceState'. Does nothing if
src/OpenTelemetry/Util.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-}@@ -10,10 +11,6 @@ {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UnliftedFFITypes #-} -------------------------------------------------------------------------------------------------------------------------------------------------------------- {- | Module : OpenTelemetry.Util Copyright : (c) Ian Duncan, 2021@@ -29,6 +26,10 @@ getThreadId, bracketError, + -- * Lock-free IORef modification+ casModifyIORef_,+ casReadModifyIORef_,+ -- * Data structures AppendOnlyBoundedCollection, emptyAppendOnlyBoundedCollection,@@ -36,21 +37,26 @@ appendOnlyBoundedCollectionSize, appendOnlyBoundedCollectionValues, appendOnlyBoundedCollectionDroppedElementCount,++ -- * Vectors+ chunksOfV, ) where import Control.Exception (SomeException) import qualified Control.Exception as EUnsafe import Control.Monad.IO.Unlift+import Data.IORef (IORef) import Data.Kind import qualified Data.Vector as V import Foreign.C (CInt (..)) import GHC.Base (Addr#) import GHC.Conc (ThreadId (ThreadId)) import GHC.Exts (unsafeCoerce#)+import qualified GHC.Exts as Exts import GHC.Generics-import VectorBuilder.Builder (Builder)-import qualified VectorBuilder.Builder as Builder-import qualified VectorBuilder.Vector as Builder+import GHC.IO (IO (IO))+import GHC.IORef (IORef (IORef))+import GHC.STRef (STRef (STRef)) {- | Useful for annotating which constructor in an ADT was chosen@@ -61,7 +67,10 @@ constructorName = genericConstrName . from --- | Detect a constructor from any datatype which derives 'Generic'+{- | Detect a constructor from any datatype which derives 'Generic'++@since 0.0.1.0+-} class HasConstructor (f :: Type -> Type) where genericConstrName :: f x -> String @@ -82,78 +91,227 @@ foreign import ccall unsafe "rts_getThreadId" c_getThreadId :: Addr# -> CInt --- | Get an int representation of a thread id+{- | Get an int representation of a thread id++@since 0.0.1.0+-} getThreadId :: ThreadId -> Int getThreadId (ThreadId tid#) = fromIntegral $ c_getThreadId (unsafeCoerce# tid#) {-# INLINE getThreadId #-} -data AppendOnlyBoundedCollection a = AppendOnlyBoundedCollection- { collection :: Builder a- , maxSize :: {-# UNPACK #-} !Int- , dropped :: {-# UNPACK #-} !Int- }+{- Note [NOINLINE on CAS functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+These functions MUST be NOINLINE. When inlined, GHC's Core-to-STG pass may+wrap the "new" constructor (the result of @f old@) in an updatable thunk rather+than allocating it directly as a constructor. This happens when the modification+function produces a record with a strict field whose value is a locally-allocated+closure (e.g. a DList function composition @dl . (x :)@ in+'AppendOnlyBoundedCollection'). The Core-to-STG pass conservatively inserts a+@case@ to force the strict field, turning the entire constructor into a thunk. +The thunk pointer has tag 0 (untagged). @casMutVar#@ writes this untagged+thunk to the MutVar. On the next read, the thunk is evaluated; it becomes an+indirection to the actual constructor at a different heap address (tag 1). The+CAS then compares the evaluated constructor pointer (tag 1) against the MutVar+contents (the indirection cell, tag 0). These are different addresses, so the+CAS fails *permanently*: every retry reads the indirection, evaluates to the+constructor, and mismatches again. Result: infinite spin-loop. +With NOINLINE, @let !new = f old@ forces the thunk inside the CAS function+before passing the evaluated (tagged) constructor pointer to @casMutVar#@.+The MutVar always contains a properly tagged constructor pointer, so the CAS+comparison works correctly.++Affects all GHC versions tested (9.4 through 9.12), both aarch64 and x86_64.++Note: we deliberately omit @yield#@ on the CAS failure path. NOINLINE already+makes the function call a GC safe point, and each retry re-evaluates @f old@+which allocates, providing another safe point. @yield#@ was measured to add+significant overhead even on the uncontended success path (likely because GHC+cannot prove it is dead code and its presence inhibits tail-call / loop+optimisation).+-}++{- | CAS-based strict IORef modification that avoids the closure and pair+allocation of 'atomicModifyIORef''.++@atomicModifyIORef' ref (\old -> (f old, ()))@ allocates a closure capturing+the modification function, a @(new, ())@ pair, and (in the GHC RTS) a thunk+indirection that is CAS'd into the MutVar.++This function instead reads the current value, applies @f@ strictly, and+performs a compare-and-swap. On success (the common, uncontended case), zero+intermediate heap objects are allocated beyond the new value itself. On CAS+failure (concurrent modification), it retries. Safe because @f@ is pure.++Use for hot-path span operations (addAttribute, addEvent, setStatus, etc.)+where the IORef is rarely contended and the modification is a cheap record+update.++@since 0.0.1.0+-}+casModifyIORef_ :: IORef a -> (a -> a) -> IO ()+casModifyIORef_ (IORef (STRef ref#)) f = IO go#+ where+ go# s0# =+ case Exts.readMutVar# ref# s0# of+ (# s1#, old #) ->+ let !new = f old+ in case Exts.casMutVar# ref# old new s1# of+ (# s2#, 0#, _ #) -> (# s2#, () #)+ (# s2#, _, _ #) -> go# s2#+{-# NOINLINE casModifyIORef_ #-}+++-- NOINLINE is load-bearing: see Note [NOINLINE on CAS functions]++{- | CAS-based IORef modification that also reads the old value before the swap.++Performs a strict read, applies @f@ to decide both the new value and a+pre-swap result, then CAS's the new value in. Returns the old value (before+modification) on success. Retries on CAS failure.++Used by 'endSpan' where we need to atomically set @spanEnd@ and also read the+(unchanged) Tracer field to obtain the processor vector, all without+navigating the Tracer inside an @atomicModifyIORef'@ closure.++@since 0.0.1.0+-}+casReadModifyIORef_ :: IORef a -> (a -> a) -> IO a+casReadModifyIORef_ (IORef (STRef ref#)) f = IO go#+ where+ go# s0# =+ case Exts.readMutVar# ref# s0# of+ (# s1#, old #) ->+ let !new = f old+ in case Exts.casMutVar# ref# old new s1# of+ (# s2#, 0#, _ #) -> (# s2#, old #)+ (# s2#, _, _ #) -> go# s2#+{-# NOINLINE casReadModifyIORef_ #-}+++-- NOINLINE is load-bearing: see Note [NOINLINE on CAS functions]++{- | Bounded append-only collection.++Two constructors: 'EmptyBounded' carries only the capacity (2 words: info+pointer + unboxed Int), avoiding all allocation for the common case of spans+with 0 events or 0 links. 'BoundedCollection' uses a difference list for+O(1) pure append and O(n) materialization at export time.++Safe with 'atomicModifyIORef'' because all operations are pure.++@since 0.0.1.0+-}+data AppendOnlyBoundedCollection a+ = EmptyBounded+ {-# UNPACK #-} !Int+ | BoundedCollection+ !([a] -> [a])+ {-# UNPACK #-} !Int+ {-# UNPACK #-} !Int+ {-# UNPACK #-} !Int++ instance forall a. (Show a) => Show (AppendOnlyBoundedCollection a) where- showsPrec d AppendOnlyBoundedCollection {collection = c, maxSize = m, dropped = r} =- let vec = Builder.build c :: V.Vector a+ showsPrec d c =+ let vec = appendOnlyBoundedCollectionValues c in showParen (d > 10) $- showString "AppendOnlyBoundedCollection {collection = "- . shows vec- . showString ", maxSize = "- . shows m- . showString ", dropped = "- . shows r- . showString "}"+ showString "AppendOnlyBoundedCollection {collection = "+ . shows vec+ . showString ", maxSize = "+ . shows (appendOnlyBoundedCollectionMaxSize c)+ . showString ", dropped = "+ . shows (appendOnlyBoundedCollectionDroppedElementCount c)+ . showString "}" --- | Initialize a bounded collection that admits a maximum size+{- | Initialize a bounded collection that admits a maximum size++@since 0.0.1.0+-} emptyAppendOnlyBoundedCollection :: Int -- ^ Maximum size -> AppendOnlyBoundedCollection a-emptyAppendOnlyBoundedCollection s = AppendOnlyBoundedCollection mempty s 0+emptyAppendOnlyBoundedCollection !s = EmptyBounded s+{-# INLINE emptyAppendOnlyBoundedCollection #-} +{- | O(n). Materializes the difference list into a 'V.Vector' via 'V.fromListN'.+Called once per span at export time.++@since 0.0.1.0+-} appendOnlyBoundedCollectionValues :: AppendOnlyBoundedCollection a -> V.Vector a-appendOnlyBoundedCollectionValues (AppendOnlyBoundedCollection a _ _) = Builder.build a+appendOnlyBoundedCollectionValues (EmptyBounded _) = V.empty+appendOnlyBoundedCollectionValues (BoundedCollection dl sz _ _) =+ V.fromListN sz (dl [])+{-# INLINE appendOnlyBoundedCollectionValues #-} +-- | @since 0.0.1.0 appendOnlyBoundedCollectionSize :: AppendOnlyBoundedCollection a -> Int-appendOnlyBoundedCollectionSize (AppendOnlyBoundedCollection b _ _) = Builder.size b+appendOnlyBoundedCollectionSize (EmptyBounded _) = 0+appendOnlyBoundedCollectionSize (BoundedCollection _ sz _ _) = sz+{-# INLINE appendOnlyBoundedCollectionSize #-} +appendOnlyBoundedCollectionMaxSize :: AppendOnlyBoundedCollection a -> Int+appendOnlyBoundedCollectionMaxSize (EmptyBounded ms) = ms+appendOnlyBoundedCollectionMaxSize (BoundedCollection _ _ ms _) = ms+{-# INLINE appendOnlyBoundedCollectionMaxSize #-}+++-- | @since 0.0.1.0 appendOnlyBoundedCollectionDroppedElementCount :: AppendOnlyBoundedCollection a -> Int-appendOnlyBoundedCollectionDroppedElementCount (AppendOnlyBoundedCollection _ _ d) = d+appendOnlyBoundedCollectionDroppedElementCount (EmptyBounded _) = 0+appendOnlyBoundedCollectionDroppedElementCount (BoundedCollection _ _ _ d) = d+{-# INLINE appendOnlyBoundedCollectionDroppedElementCount #-} +{- | Append an element. O(1): transitions from 'EmptyBounded' to+'BoundedCollection' on first append, then difference-list composition.+Returns the collection unchanged (with incremented drop count) when full.++@since 0.0.1.0+-} appendToBoundedCollection :: AppendOnlyBoundedCollection a -> a -> AppendOnlyBoundedCollection a-appendToBoundedCollection c@(AppendOnlyBoundedCollection b ms d) x =- if appendOnlyBoundedCollectionSize c < ms- then AppendOnlyBoundedCollection (b <> Builder.singleton x) ms d- else AppendOnlyBoundedCollection b ms (d + 1)+appendToBoundedCollection (EmptyBounded ms) x+ | ms <= 0 = BoundedCollection id 0 ms 1+ | otherwise = BoundedCollection (x :) 1 ms 0+appendToBoundedCollection (BoundedCollection dl sz ms d) x+ | sz >= ms = BoundedCollection dl sz ms (d + 1)+ | otherwise = BoundedCollection (dl . (x :)) (sz + 1) ms d+{-# INLINE appendToBoundedCollection #-} +{- | Split a vector into chunks of at most @n@ elements. Used by batch processors.++@since 0.4.0.0+-}+chunksOfV :: Int -> V.Vector a -> [V.Vector a]+chunksOfV n v+ | V.null v = []+ | otherwise =+ let (chunk, rest) = V.splitAt n v+ in chunk : chunksOfV n rest++ {- | Like 'Context.Exception.bracket', but provides the @after@ function with information about uncaught exceptions. @since 0.1.0.0 -} bracketError :: (MonadUnliftIO m) => m a -> (Maybe SomeException -> a -> m b) -> (a -> m c) -> m c+{-# INLINEABLE bracketError #-} bracketError before after thing = withRunInIO $ \run -> EUnsafe.mask $ \restore -> do x <- run before- res1 <- EUnsafe.try $ restore $ run $ thing x- case res1 of- Left (e1 :: SomeException) -> do- -- explicitly ignore exceptions from after. We know that- -- no async exceptions were thrown there, so therefore- -- the stronger exception must come from thing- --- -- https://github.com/fpco/safe-exceptions/issues/2+ y <-+ restore (run $ thing x) `EUnsafe.catch` \(e1 :: SomeException) -> do _ :: Either SomeException b <- EUnsafe.try $ EUnsafe.uninterruptibleMask_ $ run $ after (Just e1) x EUnsafe.throwIO e1- Right y -> do- _ <- EUnsafe.uninterruptibleMask_ $ run $ after Nothing x- return y+ _ <- EUnsafe.uninterruptibleMask_ $ run $ after Nothing x+ return y
test/OpenTelemetry/AttributesSpec.hs view
@@ -2,6 +2,7 @@ module OpenTelemetry.AttributesSpec where +import qualified Data.HashMap.Lazy as H import qualified Data.Text as T import qualified OpenTelemetry.Attributes as A import qualified Test.Hspec as Hspec@@ -9,19 +10,125 @@ spec :: Hspec.Spec spec = Hspec.describe "Attributes" $ do+ -- Common §Attribute: attribute key/value collection+ -- https://opentelemetry.io/docs/specs/otel/common/#attribute Hspec.describe "addAttribute" $ do let overwritesPrevious :: (A.ToAttribute a) => T.Text -> a -> a -> A.Attributes -> Hspec.Spec overwritesPrevious attrKey newValue prevValue attrs = do let addAttr = addAttributeDefault attrKey+ -- Common §Attribute: setting an attribute replaces any existing value for the same key+ -- https://opentelemetry.io/docs/specs/otel/common/#attribute Hspec.it "Overwrites previous value with new value at this key." $ addAttr newValue (addAttr prevValue attrs) `Hspec.shouldBe` addAttr newValue attrs overwritesPrevious Example ("new value" :: T.Text) "prev value" A.emptyAttributes+ -- Common §Attribute: batch attribute updates+ -- https://opentelemetry.io/docs/specs/otel/common/#attribute+ Hspec.describe "addAttributes" $ do+ Hspec.it "Overwrites previous values new values when keys collide" $ do+ let initialAttrs = addAttributeDefault "language" ("english" :: T.Text) A.emptyAttributes+ newAttrMap =+ H.fromList+ [ ("language", A.toAttribute ("morporkian" :: T.Text))+ , ("currency", A.toAttribute ("AM$" :: T.Text))+ ]+ updatedAttrs = A.addAttributes A.defaultAttributeLimits initialAttrs newAttrMap+ A.getAttributeMap updatedAttrs+ `Hspec.shouldBe` newAttrMap++ Hspec.it "new values override existing for same key" $ do+ let initial = addAttributeDefault Example ("old" :: T.Text) A.emptyAttributes+ batch = H.singleton Example ("new" :: T.Text)+ result = A.addAttributes A.defaultAttributeLimits initial batch+ A.lookupAttribute result Example `Hspec.shouldBe` Just (A.toAttribute ("new" :: T.Text))++ -- Implementation-specific: merge helper (not part of the portable Attributes API)+ -- https://opentelemetry.io/docs/specs/otel/common/#attribute Hspec.describe "unsafeMergeAttributesIgnoringLimits" $ do Hspec.it "Is left-biased when keys conflict" $ do let left = addAttributeDefault Example (1 :: Int) A.emptyAttributes right = addAttributeDefault Example (2 :: Int) A.emptyAttributes A.unsafeMergeAttributesIgnoringLimits left right `Hspec.shouldBe` left++ -- Common §Attribute: empty attribute set+ -- https://opentelemetry.io/docs/specs/otel/common/#attribute+ Hspec.describe "emptyAttributes" $ do+ Hspec.it "has count 0" $ do+ A.getCount A.emptyAttributes `Hspec.shouldBe` 0+ Hspec.it "has dropped 0" $ do+ A.getDropped A.emptyAttributes `Hspec.shouldBe` 0++ Hspec.describe "lookupAttribute" $ do+ Hspec.it "finds an added attribute" $ do+ let attrs = addAttributeDefault Example ("hello" :: T.Text) A.emptyAttributes+ A.lookupAttribute attrs Example `Hspec.shouldBe` Just (A.toAttribute ("hello" :: T.Text))++ Hspec.it "returns Nothing for missing key" $ do+ A.lookupAttribute A.emptyAttributes "no-such-key" `Hspec.shouldBe` Nothing++ -- Common §Attribute: strongly-typed attribute keys (API ergonomics)+ -- https://opentelemetry.io/docs/specs/otel/common/#attribute+ Hspec.describe "addAttributeByKey" $ do+ Hspec.it "adds attribute with typed key" $ do+ let key = A.AttributeKey "typed-key"+ attrs = A.addAttributeByKey A.defaultAttributeLimits A.emptyAttributes key (42 :: Int)+ A.lookupAttributeByKey attrs key `Hspec.shouldBe` Just (A.toAttribute (42 :: Int))++ Hspec.describe "lookupAttributeByKey" $ do+ Hspec.it "returns Nothing for missing typed key" $ do+ let key = A.AttributeKey "missing"+ A.lookupAttributeByKey A.emptyAttributes key `Hspec.shouldBe` (Nothing :: Maybe A.Attribute)++ -- Implementation-specific: exposing the underlying attribute map for interop+ -- https://opentelemetry.io/docs/specs/otel/common/#attribute+ Hspec.describe "getAttributeMap" $ do+ Hspec.it "returns the underlying map" $ do+ let attrs = addAttributeDefault Example ("v" :: T.Text) A.emptyAttributes+ m = A.getAttributeMap attrs+ H.lookup Example m `Hspec.shouldBe` Just (A.toAttribute ("v" :: T.Text))++ -- Common §Attribute limits: count and dropped-attribute accounting+ -- https://opentelemetry.io/docs/specs/otel/common/#attribute-limits+ Hspec.describe "getCount / getDropped" $ do+ Hspec.it "getCount increments with addAttribute" $ do+ let a1 = addAttributeDefault "k1" ("v1" :: T.Text) A.emptyAttributes+ a2 = addAttributeDefault "k2" ("v2" :: T.Text) a1+ A.getCount a2 `Hspec.shouldBe` 2++ Hspec.it "getDropped increases when limit exceeded" $ do+ let lim = A.AttributeLimits {attributeCountLimit = Just 1, attributeLengthLimit = Nothing}+ a1 = A.addAttribute lim A.emptyAttributes "k1" ("v1" :: T.Text)+ a2 = A.addAttribute lim a1 "k2" ("v2" :: T.Text)+ A.getDropped a2 `Hspec.shouldBe` 1++ Hspec.describe "addAttributesFromBuilder" $ do+ Hspec.it "adds attributes from a builder" $ do+ let builder = A.attr "bk" ("bv" :: T.Text)+ attrs = A.addAttributesFromBuilder A.defaultAttributeLimits A.emptyAttributes builder+ A.lookupAttribute attrs "bk" `Hspec.shouldBe` Just (A.toAttribute ("bv" :: T.Text))++ -- Implementation-specific: attribute builder helpers+ -- https://opentelemetry.io/docs/specs/otel/common/#attribute+ Hspec.describe "attr builder" $ do+ Hspec.it "attr creates a single-attribute builder" $ do+ let builder = A.attr "test" (True :: Bool)+ attrs = A.addAttributesFromBuilder A.defaultAttributeLimits A.emptyAttributes builder+ A.lookupAttribute attrs "test" `Hspec.shouldBe` Just (A.toAttribute True)++ Hspec.it "optAttr includes Just values" $ do+ let builder = A.optAttr "opt" (Just (7 :: Int))+ attrs = A.addAttributesFromBuilder A.defaultAttributeLimits A.emptyAttributes builder+ A.lookupAttribute attrs "opt" `Hspec.shouldBe` Just (A.toAttribute (7 :: Int))++ Hspec.it "optAttr skips Nothing values" $ do+ let builder = A.optAttr "opt" (Nothing :: Maybe Int)+ attrs = A.addAttributesFromBuilder A.defaultAttributeLimits A.emptyAttributes builder+ A.lookupAttribute attrs "opt" `Hspec.shouldBe` Nothing++ Hspec.it "buildAttrs builds from a builder" $ do+ let builder = A.attr "b1" ("v1" :: T.Text) <> A.attr "b2" (2 :: Int)+ m = A.buildAttrs builder+ H.size m `Hspec.shouldBe` 2 pattern Example :: T.Text
test/OpenTelemetry/BaggageSpec.hs view
@@ -1,15 +1,244 @@ module OpenTelemetry.BaggageSpec where +import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy as L+import Data.Either (isLeft, isRight) import qualified Data.HashMap.Strict as HashMap-import OpenTelemetry.Baggage+import Data.Maybe (fromJust, isJust)+import qualified Data.Text as T+import OpenTelemetry.Baggage (+ Baggage,+ Element (..),+ InvalidBaggage (..),+ decodeBaggageHeader,+ delete,+ empty,+ encodeBaggageHeader,+ encodeBaggageHeaderB,+ fromHashMap,+ insert,+ insertChecked,+ maxBaggageBytes,+ maxMemberBytes,+ maxMembers,+ mkToken,+ property,+ tokenValue,+ values,+ ) import Test.Hspec spec :: Spec spec = describe "Baggage" $ do+ -- Baggage API §Baggage header format: key=value list-members+ -- https://opentelemetry.io/docs/specs/otel/baggage/api/ it "decodes simple header" $ do let baggage = values <$> decodeBaggageHeader "x-api-key=asdf" HashMap.mapKeys tokenValue <$> baggage `shouldBe` Right (HashMap.fromList [("x-api-key", Element {value = "asdf", properties = []})])+ -- Baggage API §Baggage header format: percent-encoding in values+ -- https://opentelemetry.io/docs/specs/otel/baggage/api/ it "decodes percent encoded header" $ do let baggage = values <$> decodeBaggageHeader "Authorization=Basic%20asdf" HashMap.mapKeys tokenValue <$> baggage `shouldBe` Right (HashMap.fromList [("Authorization", Element {value = "Basic asdf", properties = []})])++ it "encodes and decodes simple baggage (roundtrip)" $ do+ let k = fromJust (mkToken "x-key")+ b0 = insert k (Element {value = "hello", properties = []}) empty+ hdr = encodeBaggageHeader b0+ HashMap.mapKeys tokenValue . values <$> decodeBaggageHeader hdr+ `shouldBe` Right (HashMap.fromList [("x-key", Element {value = "hello", properties = []})])++ it "encodes baggage with multiple entries" $ do+ let k1 = fromJust (mkToken "a")+ k2 = fromJust (mkToken "b")+ b0 =+ insert k1 (Element {value = "1", properties = []}) $+ insert k2 (Element {value = "2", properties = []}) empty+ hdr = encodeBaggageHeader b0+ case HashMap.mapKeys tokenValue . values <$> decodeBaggageHeader hdr of+ Left e -> expectationFailure e+ Right m -> do+ HashMap.lookup "a" m `shouldBe` Just (Element {value = "1", properties = []})+ HashMap.lookup "b" m `shouldBe` Just (Element {value = "2", properties = []})++ it "insert overwrites existing key" $ do+ let k = fromJust (mkToken "k")+ b0 = insert k (Element {value = "first", properties = []}) empty+ b1 = insert k (Element {value = "second", properties = []}) b0+ HashMap.mapKeys tokenValue (values b1)+ `shouldBe` HashMap.fromList [("k", Element {value = "second", properties = []})]++ it "delete removes entry" $ do+ let k = fromJust (mkToken "k")+ b0 = insert k (Element {value = "v", properties = []}) empty+ b1 = delete k b0+ values b1 `shouldBe` HashMap.empty++ it "empty baggage encodes to empty" $ do+ encodeBaggageHeader empty `shouldBe` ""++ -- Baggage API §Baggage header format: properties after semicolon+ -- https://opentelemetry.io/docs/specs/otel/baggage/api/+ it "decodes header with properties" $ do+ let expected =+ HashMap.fromList+ [+ ( "key"+ , Element+ { value = "value"+ , properties =+ [ property (fromJust (mkToken "prop1")) Nothing+ , property (fromJust (mkToken "prop2")) (Just "val2")+ ]+ }+ )+ ]+ HashMap.mapKeys tokenValue . values <$> decodeBaggageHeader "key=value;prop1;prop2=val2"+ `shouldBe` Right expected++ it "decodes header with multiple entries" $ do+ let expected =+ HashMap.fromList+ [ ("k1", Element {value = "v1", properties = []})+ , ("k2", Element {value = "v2", properties = []})+ ]+ HashMap.mapKeys tokenValue . values <$> decodeBaggageHeader "k1=v1,k2=v2"+ `shouldBe` Right expected++ it "rejects empty input" $ do+ decodeBaggageHeader "" `shouldSatisfy` isLeft++ -- Baggage API §Baggage header: W3C baggage limits (8192 bytes, 180 members, 4096 bytes per member)+ -- https://opentelemetry.io/docs/specs/otel/baggage/api/+ describe "W3C Baggage size limits" $ do+ it "decode rejects header exceeding 8192 bytes" $ do+ let longVal = B8.replicate (maxBaggageBytes + 1 - 2) 'x'+ hdr = "k=" <> longVal+ decodeBaggageHeader hdr `shouldSatisfy` isLeft++ it "decode accepts header at exactly 8192 bytes" $ do+ let valLen = maxBaggageBytes - 2+ longVal = B8.replicate valLen 'x'+ hdr = "k=" <> longVal+ BS.length hdr `shouldBe` maxBaggageBytes+ decodeBaggageHeader hdr `shouldSatisfy` isRight++ it "decode rejects more than 180 members" $ do+ let mkEntry i = B8.pack ("k" ++ show (i :: Int) ++ "=v")+ entries = map mkEntry [1 .. maxMembers + 1]+ hdr = BS.intercalate "," entries+ decodeBaggageHeader hdr `shouldSatisfy` isLeft++ it "decode accepts exactly 180 members" $ do+ let mkEntry i = B8.pack ("k" ++ show (i :: Int) ++ "=v")+ entries = map mkEntry [1 .. maxMembers]+ hdr = BS.intercalate "," entries+ case decodeBaggageHeader hdr of+ Left err -> expectationFailure err+ Right b -> HashMap.size (values b) `shouldBe` maxMembers++ it "encode skips member exceeding 4096 bytes" $ do+ let shortKey = fromJust (mkToken "short")+ longKey = fromJust (mkToken "long")+ longVal = T.replicate maxMemberBytes "x"+ b =+ insert shortKey (Element "ok" []) $+ insert longKey (Element longVal []) empty+ hdr = encodeBaggageHeader b+ case decodeBaggageHeader hdr of+ Left err -> expectationFailure err+ Right decoded -> do+ let m = HashMap.mapKeys tokenValue (values decoded)+ HashMap.lookup "short" m `shouldBe` Just (Element "ok" [])+ m `shouldSatisfy` (not . HashMap.member "long")++ it "encode respects 8192 byte total limit" $ do+ let bigBaggage = foldr addEntry empty [1 :: Int .. 200]+ addEntry i b = case mkToken (T.pack ("key" ++ show i)) of+ Nothing -> b+ Just k -> insert k (Element (T.replicate 50 "x") []) b+ BS.length (encodeBaggageHeader bigBaggage) `shouldSatisfy` (<= maxBaggageBytes)++ -- Baggage API §Baggage operations: baggage must enforce header limits+ -- https://opentelemetry.io/docs/specs/otel/baggage/api/+ describe "insertChecked" $ do+ it "accepts normal entries" $ do+ let k = fromJust (mkToken "key1")+ insertChecked k (Element "val" []) empty `shouldSatisfy` isRight++ it "rejects when exceeding 180 members" $ do+ let base = foldr addEntry empty [1 :: Int .. maxMembers]+ addEntry i b = case mkToken (T.pack ("k" ++ show i)) of+ Nothing -> b+ Just k -> insert k (Element "v" []) b+ extra = fromJust (mkToken "overflow")+ insertChecked extra (Element "v" []) base `shouldBe` Left TooManyListMembers++ it "rejects when total serialized size exceeds 8192 bytes" $ do+ let base = foldr addEntry empty [1 :: Int .. 80]+ addEntry i b = case mkToken (T.pack ("k" ++ show i)) of+ Nothing -> b+ Just k -> insert k (Element (T.replicate 100 "x") []) b+ extra = fromJust (mkToken "overflow")+ insertChecked extra (Element (T.replicate 100 "x") []) base `shouldBe` Left BaggageTooLong++ it "allows replacing an existing key without exceeding limits" $ do+ let k = fromJust (mkToken "key")+ b0 = insert k (Element "old" []) empty+ insertChecked k (Element "new" []) b0 `shouldSatisfy` isRight++ describe "fromHashMap" $ do+ it "creates Baggage from a HashMap" $ do+ let k = fromJust (mkToken "hm-key")+ hm = HashMap.singleton k (Element "hm-val" [])+ bag = fromHashMap hm+ HashMap.mapKeys tokenValue (values bag)+ `shouldBe` HashMap.fromList [("hm-key", Element "hm-val" [])]++ it "roundtrips with values" $ do+ let k = fromJust (mkToken "rt")+ bag = insert k (Element "v" []) empty+ fromHashMap (values bag) `shouldBe` bag++ -- Implementation-specific: Builder-based encoding matches strict encoding+ -- https://opentelemetry.io/docs/specs/otel/baggage/api/+ describe "encodeBaggageHeaderB" $ do+ it "produces same output as encodeBaggageHeader" $ do+ let k = fromJust (mkToken "b-key")+ bag = insert k (Element "b-val" []) empty+ strict = encodeBaggageHeader bag+ viaBuilder = L.toStrict (B.toLazyByteString (encodeBaggageHeaderB bag))+ viaBuilder `shouldBe` strict++ -- Baggage API §Token: baggage key token constraints+ -- https://opentelemetry.io/docs/specs/otel/baggage/api/+ describe "mkToken edge cases" $ do+ it "rejects empty string" $ do+ mkToken "" `shouldBe` Nothing++ it "rejects token with spaces" $ do+ mkToken "has space" `shouldBe` Nothing++ it "rejects token exceeding 4096 chars" $ do+ mkToken (T.replicate 4097 "a") `shouldBe` Nothing++ it "accepts token at exactly 4096 chars" $ do+ mkToken (T.replicate 4096 "a") `shouldSatisfy` isJust++ it "rejects control characters" $ do+ mkToken "bad\x00key" `shouldBe` Nothing++ describe "decode error paths" $ do+ it "rejects key with invalid characters" $ do+ decodeBaggageHeader "bad key=val" `shouldSatisfy` isLeft++ it "rejects missing equals sign" $ do+ decodeBaggageHeader "keyonly" `shouldSatisfy` isLeft++ -- Implementation-specific: invalid percent-sequences treated as literal (decoder behavior)+ -- https://opentelemetry.io/docs/specs/otel/baggage/api/+ it "passes through invalid percent encoding literally" $ do+ decodeBaggageHeader "k=%ZZ" `shouldSatisfy` isRight
+ test/OpenTelemetry/Context/EnvironmentSpec.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE OverloadedStrings #-}++module OpenTelemetry.Context.EnvironmentSpec (spec) where++import OpenTelemetry.Context.Environment (normalizeKeyToEnvVar)+import Test.Hspec+++spec :: Spec+spec = describe "Context.Environment" $ do+ -- Propagators API §Environment-based propagation: map header names to env vars (W3C, B3, vendor)+ -- https://opentelemetry.io/docs/specs/otel/context/api-propagators/+ describe "normalizeKeyToEnvVar" $ do+ it "uppercases W3C traceparent" $+ normalizeKeyToEnvVar "traceparent" `shouldBe` "TRACEPARENT"++ it "uppercases W3C tracestate" $+ normalizeKeyToEnvVar "tracestate" `shouldBe` "TRACESTATE"++ it "uppercases W3C baggage" $+ normalizeKeyToEnvVar "baggage" `shouldBe` "BAGGAGE"++ it "replaces hyphens with underscores for B3" $+ normalizeKeyToEnvVar "x-b3-traceid" `shouldBe` "X_B3_TRACEID"++ it "handles B3 SpanId" $+ normalizeKeyToEnvVar "x-b3-spanid" `shouldBe` "X_B3_SPANID"++ it "handles B3 Sampled" $+ normalizeKeyToEnvVar "x-b3-sampled" `shouldBe` "X_B3_SAMPLED"++ it "handles Datadog trace id" $+ normalizeKeyToEnvVar "x-datadog-trace-id" `shouldBe` "X_DATADOG_TRACE_ID"++ it "handles Datadog parent id" $+ normalizeKeyToEnvVar "x-datadog-parent-id" `shouldBe` "X_DATADOG_PARENT_ID"++ it "replaces dots with underscores" $+ normalizeKeyToEnvVar "some.dotted.header" `shouldBe` "SOME_DOTTED_HEADER"++ it "prefixes with underscore when name starts with digit" $+ normalizeKeyToEnvVar "1bad-name" `shouldBe` "_1BAD_NAME"++ it "preserves underscores" $+ normalizeKeyToEnvVar "already_has_underscores" `shouldBe` "ALREADY_HAS_UNDERSCORES"
+ test/OpenTelemetry/Context/PropagationSpec.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE OverloadedStrings #-}++module OpenTelemetry.Context.PropagationSpec where++import Control.Concurrent.Async (wait)+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import OpenTelemetry.Context (empty, insert, lookup, newKey)+import OpenTelemetry.Context.ThreadLocal (attachContext, detachContext, getContext)+import OpenTelemetry.Context.ThreadLocal.Propagation+import Test.Hspec+import Prelude hiding (lookup)+++spec :: Spec+spec = describe "Context.ThreadLocal.Propagation" $ do+ -- Context API §Context: propagate implicit context across continuations+ -- https://opentelemetry.io/docs/specs/otel/context/+ describe "propagateContext" $ do+ it "captures caller context for deferred execution" $ do+ k <- newKey "prop-test"+ let ctx = insert k (42 :: Int) empty+ tok <- attachContext ctx+ wrapped <- propagateContext $ do+ ctx' <- getContext+ pure (lookup k ctx')+ detachContext tok+ result <- wrapped+ result `shouldBe` Just 42++ describe "tracedForkIO" $ do+ it "child thread inherits caller context" $ do+ k <- newKey "fork-test"+ let ctx = insert k (99 :: Int) empty+ tok <- attachContext ctx+ mv <- newEmptyMVar+ _ <- tracedForkIO $ do+ ctx' <- getContext+ putMVar mv (lookup k ctx')+ result <- takeMVar mv+ result `shouldBe` Just 99+ detachContext tok++ describe "tracedAsync" $ do+ it "async task inherits caller context" $ do+ k <- newKey "async-test"+ let ctx = insert k (7 :: Int) empty+ tok <- attachContext ctx+ a <- tracedAsync $ do+ ctx' <- getContext+ pure (lookup k ctx')+ result <- wait a+ result `shouldBe` Just 7+ detachContext tok++ describe "tracedConcurrently" $ do+ it "both branches inherit caller context" $ do+ k <- newKey "conc-test"+ let ctx = insert k (33 :: Int) empty+ tok <- attachContext ctx+ (r1, r2) <-+ tracedConcurrently+ (do ctx' <- getContext; pure (lookup k ctx'))+ (do ctx' <- getContext; pure (lookup k ctx'))+ r1 `shouldBe` Just 33+ r2 `shouldBe` Just 33+ detachContext tok++ describe "tracedMapConcurrently" $ do+ it "all workers inherit caller context" $ do+ k <- newKey "map-conc"+ let ctx = insert k (55 :: Int) empty+ tok <- attachContext ctx+ results <- tracedMapConcurrently (\_ -> do ctx' <- getContext; pure (lookup k ctx')) [1 :: Int, 2, 3]+ results `shouldBe` [Just 55, Just 55, Just 55]+ detachContext tok++ describe "tracedForConcurrently" $ do+ it "all workers inherit caller context" $ do+ k <- newKey "for-conc"+ let ctx = insert k (88 :: Int) empty+ tok <- attachContext ctx+ results <- tracedForConcurrently [1 :: Int, 2] $ \_ -> do+ ctx' <- getContext+ pure (lookup k ctx')+ results `shouldBe` [Just 88, Just 88]+ detachContext tok++ describe "tracedWithAsync" $ do+ it "async task inherits caller context" $ do+ k <- newKey "with-async"+ let ctx = insert k (66 :: Int) empty+ tok <- attachContext ctx+ result <- tracedWithAsync (do ctx' <- getContext; pure (lookup k ctx')) wait+ result `shouldBe` Just 66+ detachContext tok
+ test/OpenTelemetry/Context/ThreadLocalSpec.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE OverloadedStrings #-}++module OpenTelemetry.Context.ThreadLocalSpec where++import Data.Maybe (isNothing)+import OpenTelemetry.Context (empty, insert, lookup, newKey)+import OpenTelemetry.Context.ThreadLocal+import Test.Hspec+import Prelude hiding (lookup)+++spec :: Spec+spec = describe "Context.ThreadLocal" $ do+ -- Context API §Context: attach/detach current context (language-specific carrier)+ -- https://opentelemetry.io/docs/specs/otel/context/+ describe "getContext / attachContext" $ do+ it "getContext returns empty context when nothing meaningful attached" $ do+ k <- newKey "clean-state"+ tok <- attachContext (insert k (1 :: Int) empty)+ detachContext tok+ ctx <- getContext+ lookup k ctx `shouldBe` Nothing++ it "attachContext then getContext retrieves the same context" $ do+ k <- newKey "tl-test"+ let ctx = insert k (42 :: Int) empty+ tok <- attachContext ctx+ ctx' <- getContext+ lookup k ctx' `shouldBe` Just 42+ detachContext tok++ it "attachContext returns a token that restores previous context" $ do+ k <- newKey "prev"+ let ctx1 = insert k (1 :: Int) empty+ ctx2 = insert k (2 :: Int) empty+ tok1 <- attachContext ctx1+ tok2 <- attachContext ctx2+ ctx' <- getContext+ lookup k ctx' `shouldBe` Just 2+ detachContext tok2+ restored <- getContext+ lookup k restored `shouldBe` Just 1+ detachContext tok1++ describe "detachContext" $ do+ it "detach restores the context from before attach" $ do+ k1 <- newKey "before"+ let before = insert k1 (42 :: Int) empty+ tok0 <- attachContext before+ k2 <- newKey "detach"+ let ctx = insert k2 (99 :: Int) empty+ tok <- attachContext ctx+ detachContext tok+ ctx' <- getContext+ lookup k1 ctx' `shouldBe` Just 42+ lookup k2 ctx' `shouldBe` Nothing+ detachContext tok0++ it "nested attach/detach restores correctly" $ do+ k <- newKey "nested"+ tok1 <- attachContext (insert k (1 :: Int) empty)+ tok2 <- attachContext (insert k (2 :: Int) empty)+ tok3 <- attachContext (insert k (3 :: Int) empty)+ ctx3 <- getContext+ lookup k ctx3 `shouldBe` Just 3+ detachContext tok3+ ctx2 <- getContext+ lookup k ctx2 `shouldBe` Just 2+ detachContext tok2+ ctx1 <- getContext+ lookup k ctx1 `shouldBe` Just 1+ detachContext tok1++ -- Implementation-specific: LIFO detach validation (error handling)+ -- https://opentelemetry.io/docs/specs/otel/context/+ describe "LIFO validation" $ do+ it "detaching in wrong order does not crash (logs error)" $ do+ k <- newKey "lifo"+ let ctx1 = insert k (1 :: Int) empty+ ctx2 = insert k (2 :: Int) empty+ tok1 <- attachContext ctx1+ tok2 <- attachContext ctx2+ -- Out-of-order detach: should log error but still restore+ detachContext tok1+ detachContext tok2 :: IO ()++ describe "adjustContext" $ do+ it "modifies the current thread context" $ do+ k <- newKey "adjust-tl"+ let ctx = insert k (10 :: Int) empty+ tok <- attachContext ctx+ adjustContext (insert k (20 :: Int))+ ctx' <- getContext+ lookup k ctx' `shouldBe` Just 20+ detachContext tok
+ test/OpenTelemetry/ContextSpec.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module OpenTelemetry.ContextSpec where++import Data.Maybe (isJust, isNothing)+import OpenTelemetry.Context+import Test.Hspec+import Prelude hiding (lookup)+++spec :: Spec+spec = describe "Context" $ do+ -- Context API §Context: empty context+ -- https://opentelemetry.io/docs/specs/otel/context/+ describe "empty" $ do+ -- Context API §Context interactions with OTel: span slot empty in empty context+ -- https://opentelemetry.io/docs/specs/otel/context/+ it "has no span" $ do+ lookupSpan empty `shouldSatisfy` isNothing++ -- Context API §Context interactions with OTel: baggage slot empty in empty context+ -- https://opentelemetry.io/docs/specs/otel/context/+ it "has no baggage" $ do+ lookupBaggage empty `shouldSatisfy` isNothing++ -- Context API §Context: get-value, set-value, and remove-value operations+ -- https://opentelemetry.io/docs/specs/otel/context/+ describe "key/value operations" $ do+ it "insert then lookup retrieves the value" $ do+ k <- newKey "test-key"+ let ctx = insert k (42 :: Int) empty+ lookup k ctx `shouldBe` Just 42++ it "lookup on empty returns Nothing" $ do+ k <- newKey "missing"+ lookup k (empty :: Context) `shouldBe` (Nothing :: Maybe Int)++ it "delete removes a key" $ do+ k <- newKey "del-key"+ let ctx = insert k (10 :: Int) empty+ ctx' = delete k ctx+ lookup k ctx' `shouldBe` Nothing++ it "adjust modifies an existing value" $ do+ k <- newKey "adj-key"+ let ctx = insert k (5 :: Int) empty+ ctx' = adjust (+ 10) k ctx+ lookup k ctx' `shouldBe` Just 15++ it "adjust on missing key is a no-op" $ do+ k <- newKey "no-adj"+ let f :: Int -> Int+ f = (+ 1)+ ctx' = adjust f k empty+ lookup k ctx' `shouldBe` Nothing++ it "union merges two contexts" $ do+ k1 <- newKey "k1"+ k2 <- newKey "k2"+ let ctx1 = insert k1 (1 :: Int) empty+ ctx2 = insert k2 (2 :: Int) empty+ merged = union ctx1 ctx2+ lookup k1 merged `shouldSatisfy` isJust+ lookup k2 merged `shouldSatisfy` isJust++ -- Implementation-specific: Context key diagnostic name+ -- https://opentelemetry.io/docs/specs/otel/context/+ it "keyName returns the name" $ do+ k <- newKey "my-key"+ keyName k `shouldBe` "my-key"++ -- Context API §Context interactions with OTel: active span slot+ -- https://opentelemetry.io/docs/specs/otel/context/+ describe "span slot" $ do+ it "removeSpan clears the span" $ do+ lookupSpan (removeSpan empty) `shouldSatisfy` isNothing++ -- Context API §Context interactions with OTel: baggage slot+ -- https://opentelemetry.io/docs/specs/otel/context/+ describe "baggage slot" $ do+ it "removeBaggage clears baggage" $ do+ lookupBaggage (removeBaggage empty) `shouldSatisfy` isNothing
+ test/OpenTelemetry/Contrib/CarryOnsSpec.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE TypeApplications #-}++module OpenTelemetry.Contrib.CarryOnsSpec where++import Control.Exception (bracket)+import qualified Data.HashMap.Strict as HM+import Data.IORef+import Data.Maybe (fromMaybe, isJust)+import Data.Text (Text)+import OpenTelemetry.Attributes (lookupAttribute, toAttribute)+import qualified OpenTelemetry.Attributes as A+import OpenTelemetry.Common (OptionalTimestamp (..))+import qualified OpenTelemetry.Context as Ctxt+import OpenTelemetry.Context.ThreadLocal (attachContext, detachContext)+import OpenTelemetry.Contrib.CarryOns (alterCarryOns, withCarryOnProcessor)+import OpenTelemetry.Processor.Span (FlushResult (..), ShutdownResult (..), SpanProcessor (..))+import OpenTelemetry.Trace.Core+import OpenTelemetry.Trace.Id+import OpenTelemetry.Trace.TraceState as TraceState+import OpenTelemetry.Util (emptyAppendOnlyBoundedCollection)+import Test.Hspec+++withEmptyContext :: IO a -> IO a+withEmptyContext = bracket (attachContext Ctxt.empty) detachContext . const+++spec :: Spec+spec = describe "Contrib.CarryOns" $ do+ -- Implementation-specific: carry-on attribute bag for span processors+ it "alterCarryOns with id does not throw" $+ withEmptyContext (alterCarryOns id)++ it "withCarryOnProcessor delegates onStart to the inner processor" $ do+ started <- newIORef False+ let inner =+ SpanProcessor+ { spanProcessorOnStart = \_ _ -> writeIORef started True+ , spanProcessorOnEnd = \_ -> pure ()+ , spanProcessorShutdown = pure ShutdownSuccess+ , spanProcessorForceFlush = pure FlushSuccess+ }+ wrapped = withCarryOnProcessor inner+ imm <- newMinimalSpan+ spanProcessorOnStart wrapped imm Ctxt.empty+ readIORef started `shouldReturn` True++ it "withCarryOnProcessor adds carry-on attributes when onEnd runs" $+ withEmptyContext $ do+ captured <- newIORef Nothing+ let inner =+ SpanProcessor+ { spanProcessorOnStart = \_ _ -> pure ()+ , spanProcessorOnEnd = \imm -> do+ hot <- readIORef (spanHot imm)+ writeIORef captured (Just $ hotAttributes hot)+ , spanProcessorShutdown = pure ShutdownSuccess+ , spanProcessorForceFlush = pure FlushSuccess+ }+ wrapped = withCarryOnProcessor inner+ alterCarryOns (HM.insert "carry.on.key" (toAttribute @Text "carry-on-value"))+ imm <- newMinimalSpan+ spanProcessorOnEnd wrapped imm+ mAttrs <- readIORef captured+ mAttrs `shouldSatisfy` isJust+ let Just attrs = mAttrs+ lookupAttribute attrs "carry.on.key" `shouldSatisfy` isJust++ it "withCarryOnProcessor skips attribute merge when carry-ons are empty but still calls inner onEnd" $ do+ ends <- newIORef (0 :: Int)+ let inner =+ SpanProcessor+ { spanProcessorOnStart = \_ _ -> pure ()+ , spanProcessorOnEnd = \_ -> modifyIORef' ends (+ 1)+ , spanProcessorShutdown = pure ShutdownSuccess+ , spanProcessorForceFlush = pure FlushSuccess+ }+ wrapped = withCarryOnProcessor inner+ withEmptyContext $ do+ imm <- newMinimalSpan+ spanProcessorOnEnd wrapped imm+ readIORef ends `shouldReturn` 1+++{- | Minimal ImmutableSpan for exercising 'SpanProcessor' hooks without relying on+'createSpan' / 'endSpan' wiring in this test module.+-}+newMinimalSpan :: IO ImmutableSpan+newMinimalSpan = do+ let dummyProcessor =+ SpanProcessor+ { spanProcessorOnStart = \_ _ -> pure ()+ , spanProcessorOnEnd = \_ -> pure ()+ , spanProcessorShutdown = pure ShutdownSuccess+ , spanProcessorForceFlush = pure FlushSuccess+ }+ tp <- createTracerProvider [dummyProcessor] emptyTracerProviderOptions+ let instrLib = InstrumentationLibrary "test" "1.0.0" "" A.emptyAttributes+ tracer = makeTracer tp instrLib tracerOptions+ limits = defaultSpanLimits+ emptyLinks = emptyAppendOnlyBoundedCollection $ fromMaybe 128 (linkCountLimit limits)+ emptyEv = emptyAppendOnlyBoundedCollection $ fromMaybe 128 (eventCountLimit limits)+ (Right tid) = baseEncodedToTraceId Base16 "aabbccdd00000000000000000000eeff"+ (Right sid) = baseEncodedToSpanId Base16 "0000000000cc00dd"+ sc =+ SpanContext+ { traceFlags = defaultTraceFlags+ , isRemote = False+ , traceState = TraceState.empty+ , spanId = sid+ , traceId = tid+ }+ st <- getTimestamp+ hotRef <-+ newIORef $+ SpanHot+ { hotName = "carry-on-test"+ , hotEnd = NoTimestamp+ , hotAttributes = A.emptyAttributes+ , hotLinks = emptyLinks+ , hotEvents = emptyEv+ , hotStatus = Unset+ }+ pure $+ ImmutableSpan+ { spanContext = sc+ , spanKind = Internal+ , spanStart = st+ , spanParent = Nothing+ , spanTracer = tracer+ , spanHot = hotRef+ }
+ test/OpenTelemetry/Contrib/SpanTraversalsSpec.hs view
@@ -0,0 +1,58 @@+module OpenTelemetry.Contrib.SpanTraversalsSpec where++import qualified OpenTelemetry.Attributes as A+import OpenTelemetry.Context (insertSpan)+import qualified OpenTelemetry.Context as Ctxt+import OpenTelemetry.Contrib.SpanTraversals (IterationInstruction (..), alterSpansUpwards)+import OpenTelemetry.Processor.Span (FlushResult (..), ShutdownResult (..), SpanProcessor (..))+import OpenTelemetry.Trace.Core+import OpenTelemetry.Trace.Id+import OpenTelemetry.Trace.TraceState as TraceState+import Test.Hspec+++spec :: Spec+spec = describe "Contrib.SpanTraversals" $ do+ -- Implementation-specific: walk span parent chain (non-portable helper)+ it "alterSpansUpwards on FrozenSpan returns initial state" $ do+ let (Right tid) = baseEncodedToTraceId Base16 "00000000000000000000000000000001"+ (Right sid) = baseEncodedToSpanId Base16 "000000000000000a"+ sc =+ SpanContext+ { traceFlags = defaultTraceFlags+ , isRemote = False+ , traceState = TraceState.empty+ , spanId = sid+ , traceId = tid+ }+ frozen = wrapSpanContext sc+ st <- alterSpansUpwards frozen (42 :: Int) $ \_ _ _ ->+ error "alterSpansUpwards FrozenSpan: step function must not run"+ st `shouldBe` 42++ it "alterSpansUpwards on Dropped returns initial state" $ do+ tp <- createTracerProvider [] emptyTracerProviderOptions+ let instrLib = InstrumentationLibrary "test" "1.0.0" "" A.emptyAttributes+ tracer = makeTracer tp instrLib tracerOptions+ dropped <- createSpanWithoutCallStack tracer Ctxt.empty "dropped" defaultSpanArguments+ st <- alterSpansUpwards dropped (7 :: Int) $ \_ _ _ ->+ error "alterSpansUpwards Dropped: step function must not run"+ st `shouldBe` 7++ it "alterSpansUpwards walks from child to root counting spans" $ do+ let dummyProcessor =+ SpanProcessor+ { spanProcessorOnStart = \_ _ -> pure ()+ , spanProcessorOnEnd = \_ -> pure ()+ , spanProcessorShutdown = pure ShutdownSuccess+ , spanProcessorForceFlush = pure FlushSuccess+ }+ tp <- createTracerProvider [dummyProcessor] emptyTracerProviderOptions+ let instrLib = InstrumentationLibrary "test" "1.0.0" "" A.emptyAttributes+ tracer = makeTracer tp instrLib tracerOptions+ parent <- createSpanWithoutCallStack tracer Ctxt.empty "parent" defaultSpanArguments+ child <- createSpanWithoutCallStack tracer (insertSpan parent Ctxt.empty) "child" defaultSpanArguments+ count <-+ alterSpansUpwards child (0 :: Int) $ \st _imm _hot ->+ (Continue (st + 1), _hot)+ count `shouldBe` 2
+ test/OpenTelemetry/EnvironmentSpec.hs view
@@ -0,0 +1,245 @@+{-# LANGUAGE OverloadedStrings #-}++module OpenTelemetry.EnvironmentSpec (spec) where++import OpenTelemetry.Environment+import System.Environment (setEnv, unsetEnv)+import Test.Hspec+++spec :: Spec+spec = sequential $+ describe "Environment" $ do+ -- Configuration §SDK environment variables: parsing helpers used by the SDK+ -- https://opentelemetry.io/docs/specs/otel/configuration/sdk-environment-variables/+ describe "lookupBooleanEnv" $ do+ -- SDK environment variables §General rules: boolean-like env parsing (test helper)+ -- https://opentelemetry.io/docs/specs/otel/configuration/sdk-environment-variables/+ it "returns False when env var is unset" $ do+ unsetEnv "OTEL_TEST_BOOL"+ result <- lookupBooleanEnv "OTEL_TEST_BOOL"+ result `shouldBe` False++ it "returns True for 'true'" $ do+ setEnv "OTEL_TEST_BOOL" "true"+ result <- lookupBooleanEnv "OTEL_TEST_BOOL"+ result `shouldBe` True+ unsetEnv "OTEL_TEST_BOOL"++ it "returns True for 'TRUE' (case-insensitive)" $ do+ setEnv "OTEL_TEST_BOOL" "TRUE"+ result <- lookupBooleanEnv "OTEL_TEST_BOOL"+ result `shouldBe` True+ unsetEnv "OTEL_TEST_BOOL"++ it "returns True for 'True'" $ do+ setEnv "OTEL_TEST_BOOL" "True"+ result <- lookupBooleanEnv "OTEL_TEST_BOOL"+ result `shouldBe` True+ unsetEnv "OTEL_TEST_BOOL"++ it "returns False for 'false'" $ do+ setEnv "OTEL_TEST_BOOL" "false"+ result <- lookupBooleanEnv "OTEL_TEST_BOOL"+ result `shouldBe` False+ unsetEnv "OTEL_TEST_BOOL"++ it "returns False for arbitrary string" $ do+ setEnv "OTEL_TEST_BOOL" "banana"+ result <- lookupBooleanEnv "OTEL_TEST_BOOL"+ result `shouldBe` False+ unsetEnv "OTEL_TEST_BOOL"++ -- SDK environment variables §OTEL_METRICS_EXPORTER+ -- https://opentelemetry.io/docs/specs/otel/configuration/sdk-environment-variables/+ describe "lookupMetricsExporterSelection" $ do+ it "returns Nothing when unset" $ do+ unsetEnv "OTEL_METRICS_EXPORTER"+ result <- lookupMetricsExporterSelection+ result `shouldBe` Nothing++ it "returns MetricsExporterOtlp for 'otlp'" $ do+ setEnv "OTEL_METRICS_EXPORTER" "otlp"+ result <- lookupMetricsExporterSelection+ result `shouldBe` Just MetricsExporterOtlp+ unsetEnv "OTEL_METRICS_EXPORTER"++ it "returns MetricsExporterPrometheus for 'prometheus'" $ do+ setEnv "OTEL_METRICS_EXPORTER" "prometheus"+ result <- lookupMetricsExporterSelection+ result `shouldBe` Just MetricsExporterPrometheus+ unsetEnv "OTEL_METRICS_EXPORTER"++ it "returns MetricsExporterConsole for 'console'" $ do+ setEnv "OTEL_METRICS_EXPORTER" "console"+ result <- lookupMetricsExporterSelection+ result `shouldBe` Just MetricsExporterConsole+ unsetEnv "OTEL_METRICS_EXPORTER"++ it "returns MetricsExporterNone for 'none'" $ do+ setEnv "OTEL_METRICS_EXPORTER" "none"+ result <- lookupMetricsExporterSelection+ result `shouldBe` Just MetricsExporterNone+ unsetEnv "OTEL_METRICS_EXPORTER"++ it "is case-insensitive" $ do+ setEnv "OTEL_METRICS_EXPORTER" "OTLP"+ result <- lookupMetricsExporterSelection+ result `shouldBe` Just MetricsExporterOtlp+ unsetEnv "OTEL_METRICS_EXPORTER"++ it "takes first comma-separated segment" $ do+ setEnv "OTEL_METRICS_EXPORTER" "otlp,prometheus"+ result <- lookupMetricsExporterSelection+ result `shouldBe` Just MetricsExporterOtlp+ unsetEnv "OTEL_METRICS_EXPORTER"++ it "returns Custom for unknown value" $ do+ setEnv "OTEL_METRICS_EXPORTER" "zipkin"+ result <- lookupMetricsExporterSelection+ result `shouldBe` Just (MetricsExporterCustom "zipkin")+ unsetEnv "OTEL_METRICS_EXPORTER"++ it "returns Nothing for empty string" $ do+ setEnv "OTEL_METRICS_EXPORTER" ""+ result <- lookupMetricsExporterSelection+ result `shouldBe` Nothing+ unsetEnv "OTEL_METRICS_EXPORTER"++ it "trims whitespace" $ do+ setEnv "OTEL_METRICS_EXPORTER" " otlp "+ result <- lookupMetricsExporterSelection+ result `shouldBe` Just MetricsExporterOtlp+ unsetEnv "OTEL_METRICS_EXPORTER"++ -- SDK environment variables §OTEL_METRIC_EXPORT_INTERVAL+ -- https://opentelemetry.io/docs/specs/otel/configuration/sdk-environment-variables/+ describe "lookupMetricExportIntervalMillis" $ do+ it "returns Nothing when unset" $ do+ unsetEnv "OTEL_METRIC_EXPORT_INTERVAL"+ result <- lookupMetricExportIntervalMillis+ result `shouldBe` Nothing++ it "parses valid positive integer" $ do+ setEnv "OTEL_METRIC_EXPORT_INTERVAL" "5000"+ result <- lookupMetricExportIntervalMillis+ result `shouldBe` Just 5000+ unsetEnv "OTEL_METRIC_EXPORT_INTERVAL"++ it "returns Nothing for zero" $ do+ setEnv "OTEL_METRIC_EXPORT_INTERVAL" "0"+ result <- lookupMetricExportIntervalMillis+ result `shouldBe` Nothing+ unsetEnv "OTEL_METRIC_EXPORT_INTERVAL"++ it "returns Nothing for negative" $ do+ setEnv "OTEL_METRIC_EXPORT_INTERVAL" "-100"+ result <- lookupMetricExportIntervalMillis+ result `shouldBe` Nothing+ unsetEnv "OTEL_METRIC_EXPORT_INTERVAL"++ it "returns Nothing for non-numeric" $ do+ setEnv "OTEL_METRIC_EXPORT_INTERVAL" "abc"+ result <- lookupMetricExportIntervalMillis+ result `shouldBe` Nothing+ unsetEnv "OTEL_METRIC_EXPORT_INTERVAL"++ it "trims whitespace" $ do+ setEnv "OTEL_METRIC_EXPORT_INTERVAL" " 1000 "+ result <- lookupMetricExportIntervalMillis+ result `shouldBe` Just 1000+ unsetEnv "OTEL_METRIC_EXPORT_INTERVAL"++ -- SDK environment variables §OTEL_METRICS_EXEMPLAR_FILTER+ -- https://opentelemetry.io/docs/specs/otel/configuration/sdk-environment-variables/+ describe "lookupMetricsExemplarFilter" $ do+ it "returns Nothing when unset" $ do+ unsetEnv "OTEL_METRICS_EXEMPLAR_FILTER"+ result <- lookupMetricsExemplarFilter+ result `shouldBe` Nothing++ it "returns TraceBased for 'trace_based'" $ do+ setEnv "OTEL_METRICS_EXEMPLAR_FILTER" "trace_based"+ result <- lookupMetricsExemplarFilter+ result `shouldBe` Just MetricsExemplarFilterTraceBased+ unsetEnv "OTEL_METRICS_EXEMPLAR_FILTER"++ it "returns AlwaysOn for 'always_on'" $ do+ setEnv "OTEL_METRICS_EXEMPLAR_FILTER" "always_on"+ result <- lookupMetricsExemplarFilter+ result `shouldBe` Just MetricsExemplarFilterAlwaysOn+ unsetEnv "OTEL_METRICS_EXEMPLAR_FILTER"++ it "returns AlwaysOff for 'always_off'" $ do+ setEnv "OTEL_METRICS_EXEMPLAR_FILTER" "always_off"+ result <- lookupMetricsExemplarFilter+ result `shouldBe` Just MetricsExemplarFilterAlwaysOff+ unsetEnv "OTEL_METRICS_EXEMPLAR_FILTER"++ it "is case-insensitive" $ do+ setEnv "OTEL_METRICS_EXEMPLAR_FILTER" "TRACE_BASED"+ result <- lookupMetricsExemplarFilter+ result `shouldBe` Just MetricsExemplarFilterTraceBased+ unsetEnv "OTEL_METRICS_EXEMPLAR_FILTER"++ it "returns Nothing for unknown value" $ do+ setEnv "OTEL_METRICS_EXEMPLAR_FILTER" "foo"+ result <- lookupMetricsExemplarFilter+ result `shouldBe` Nothing+ unsetEnv "OTEL_METRICS_EXEMPLAR_FILTER"++ -- SDK environment variables §OTEL_LOGS_EXPORTER+ -- https://opentelemetry.io/docs/specs/otel/configuration/sdk-environment-variables/+ describe "lookupLogsExporterSelection" $ do+ it "returns Nothing when unset" $ do+ unsetEnv "OTEL_LOGS_EXPORTER"+ result <- lookupLogsExporterSelection+ result `shouldBe` Nothing++ it "returns LogsExporterOtlp for 'otlp'" $ do+ setEnv "OTEL_LOGS_EXPORTER" "otlp"+ result <- lookupLogsExporterSelection+ result `shouldBe` Just LogsExporterOtlp+ unsetEnv "OTEL_LOGS_EXPORTER"++ it "returns LogsExporterConsole for 'console'" $ do+ setEnv "OTEL_LOGS_EXPORTER" "console"+ result <- lookupLogsExporterSelection+ result `shouldBe` Just LogsExporterConsole+ unsetEnv "OTEL_LOGS_EXPORTER"++ it "returns LogsExporterNone for 'none'" $ do+ setEnv "OTEL_LOGS_EXPORTER" "none"+ result <- lookupLogsExporterSelection+ result `shouldBe` Just LogsExporterNone+ unsetEnv "OTEL_LOGS_EXPORTER"++ it "is case-insensitive" $ do+ setEnv "OTEL_LOGS_EXPORTER" "OTLP"+ result <- lookupLogsExporterSelection+ result `shouldBe` Just LogsExporterOtlp+ unsetEnv "OTEL_LOGS_EXPORTER"++ it "takes first comma-separated segment" $ do+ setEnv "OTEL_LOGS_EXPORTER" "otlp,console"+ result <- lookupLogsExporterSelection+ result `shouldBe` Just LogsExporterOtlp+ unsetEnv "OTEL_LOGS_EXPORTER"++ it "returns Custom for unknown value" $ do+ setEnv "OTEL_LOGS_EXPORTER" "zipkin"+ result <- lookupLogsExporterSelection+ result `shouldBe` Just (LogsExporterCustom "zipkin")+ unsetEnv "OTEL_LOGS_EXPORTER"++ it "returns Nothing for empty string" $ do+ setEnv "OTEL_LOGS_EXPORTER" ""+ result <- lookupLogsExporterSelection+ result `shouldBe` Nothing+ unsetEnv "OTEL_LOGS_EXPORTER"++ it "trims whitespace" $ do+ setEnv "OTEL_LOGS_EXPORTER" " console "+ result <- lookupLogsExporterSelection+ result `shouldBe` Just LogsExporterConsole+ unsetEnv "OTEL_LOGS_EXPORTER"
test/OpenTelemetry/InstrumentationLibrarySpec.hs view
@@ -1,25 +1,137 @@ module OpenTelemetry.InstrumentationLibrarySpec where -import OpenTelemetry.Attributes-import OpenTelemetry.Internal.Common.Types+import OpenTelemetry.Attributes (addAttribute, defaultAttributeLimits, emptyAttributes)+import OpenTelemetry.Internal.Common.Types (+ InstrumentationLibrary (..),+ InstrumentationScope,+ instrumentationLibrary,+ instrumentationScope,+ parseInstrumentationLibrary,+ withLibraryAttributes,+ withSchemaUrl,+ ) import Test.Hspec spec :: Spec-spec = describe "InstrumentationLibrary" $ do+spec = describe "InstrumentationLibrary / InstrumentationScope" $ do+ -- Spec §Instrumentation scope: name, version, schema URL, attributes+ -- https://opentelemetry.io/docs/specs/otel/common/instrumentation-scope/+ describe "InstrumentationScope alias" $ do+ it "is the same type as InstrumentationLibrary" $ do+ let scope = instrumentationScope "my-lib" "1.0" :: InstrumentationScope+ lib = instrumentationLibrary "my-lib" "1.0" :: InstrumentationLibrary+ scope `shouldBe` lib++ it "instrumentationScope produces valid scope with all fields" $ do+ let scope =+ withSchemaUrl+ "https://opentelemetry.io/schemas/1.40.0"+ (instrumentationScope "my-lib" "2.0")+ libraryName scope `shouldBe` "my-lib"+ libraryVersion scope `shouldBe` "2.0"+ librarySchemaUrl scope `shouldBe` "https://opentelemetry.io/schemas/1.40.0"++ -- Glossary §Instrumentation scope: name, version, schema URL, attributes+ -- https://opentelemetry.io/docs/specs/otel/glossary/#instrumentation-scope+ describe "construction helpers" $ do+ it "builds a library with name, version, and empty schema and attributes" $ do+ let lib = instrumentationLibrary "my-lib" "1.0"+ libraryName lib `shouldBe` "my-lib"+ libraryVersion lib `shouldBe` "1.0"+ librarySchemaUrl lib `shouldBe` ""+ libraryAttributes lib `shouldBe` emptyAttributes++ it "withSchemaUrl sets librarySchemaUrl" $ do+ let lib =+ withSchemaUrl "https://example.com" (instrumentationLibrary "x" "1")+ librarySchemaUrl lib `shouldBe` "https://example.com"++ it "withLibraryAttributes sets libraryAttributes" $ do+ let someAttrs = addAttribute defaultAttributeLimits emptyAttributes "k" (True :: Bool)+ lib = withLibraryAttributes someAttrs (instrumentationLibrary "x" "1")+ libraryAttributes lib `shouldBe` someAttrs++ -- Implementation-specific: parse Cabal/GHC-style package IDs into scope fields+ -- https://opentelemetry.io/docs/specs/otel/glossary/#instrumentation-scope describe "parsing" $ do- it "handles a simple example basic example" $ do+ let mkLib n v =+ Just+ InstrumentationLibrary+ { libraryName = n+ , libraryVersion = v+ , librarySchemaUrl = ""+ , libraryAttributes = emptyAttributes+ }++ it "handles a simple versioned package" $ do parseInstrumentationLibrary "hello-world-1.0.5"- `shouldBe` Just (InstrumentationLibrary {libraryName = "hello-world", libraryVersion = "1.0.5", librarySchemaUrl = "", libraryAttributes = emptyAttributes})+ `shouldBe` mkLib "hello-world" "1.0.5" it "handles capital letters and numbers in package names" $ do parseInstrumentationLibrary "HUnit2-v3-1"- `shouldBe` Just (InstrumentationLibrary {libraryName = "HUnit2-v3", libraryVersion = "1", librarySchemaUrl = "", libraryAttributes = emptyAttributes})+ `shouldBe` mkLib "HUnit2-v3" "1" - it "discards trailing content" $ do+ it "discards trailing content after version" $ do parseInstrumentationLibrary "hello-world-1.0.5-inplace"- `shouldBe` Just (InstrumentationLibrary {libraryName = "hello-world", libraryVersion = "1.0.5", librarySchemaUrl = "", libraryAttributes = emptyAttributes})+ `shouldBe` mkLib "hello-world" "1.0.5" - it "handles missing version" $ do+ it "handles GHC-style package-id with hash suffix" $ do+ parseInstrumentationLibrary "base-4.20.2.0-3188"+ `shouldBe` mkLib "base" "4.20.2.0"++ it "handles missing version (bare package name)" $ do parseInstrumentationLibrary "hello-world"- `shouldBe` Just (InstrumentationLibrary {libraryName = "hello-world", libraryVersion = "", librarySchemaUrl = "", libraryAttributes = emptyAttributes})+ `shouldBe` mkLib "hello-world" ""++ it "handles single-segment version" $ do+ parseInstrumentationLibrary "aeson-2"+ `shouldBe` mkLib "aeson" "2"++ it "handles multi-segment package names" $ do+ parseInstrumentationLibrary "hs-opentelemetry-api-0.4.0.0"+ `shouldBe` mkLib "hs-opentelemetry-api" "0.4.0.0"++ it "handles package name with only digits in segments" $ do+ parseInstrumentationLibrary "utf8-string-1.0.2"+ `shouldBe` mkLib "utf8-string" "1.0.2"++ it "rejects empty string" $ do+ (parseInstrumentationLibrary "" :: Maybe InstrumentationLibrary)+ `shouldBe` Nothing++ it "rejects single character" $ do+ (parseInstrumentationLibrary "a" :: Maybe InstrumentationLibrary)+ `shouldBe` Nothing++ it "rejects name ending with dash" $ do+ (parseInstrumentationLibrary "hello-" :: Maybe InstrumentationLibrary)+ `shouldBe` Nothing++ it "rejects pure version string" $ do+ (parseInstrumentationLibrary "1.2.3" :: Maybe InstrumentationLibrary)+ `shouldBe` Nothing++ it "rejects invalid characters" $ do+ (parseInstrumentationLibrary "hello world" :: Maybe InstrumentationLibrary)+ `shouldBe` Nothing++ it "handles two-character package name without version" $ do+ parseInstrumentationLibrary "ab"+ `shouldBe` mkLib "ab" ""++ it "handles package name with version starting with zero" $ do+ parseInstrumentationLibrary "foo-0.1"+ `shouldBe` mkLib "foo" "0.1"++ it "prefers rightmost valid version split" $ do+ parseInstrumentationLibrary "x-1-2"+ `shouldBe` mkLib "x-1" "2"++ it "handles real-world GHC package names" $ do+ parseInstrumentationLibrary "hs-opentelemetry-sdk-0.1.0.0-inplace"+ `shouldBe` mkLib "hs-opentelemetry-sdk" "0.1.0.0"++ it "handles real-world GHC package with letter-only trailing" $ do+ parseInstrumentationLibrary "text-2.1.3-a641"+ `shouldBe` mkLib "text" "2.1.3"
+ test/OpenTelemetry/Internal/LoggingSpec.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE LambdaCase #-}++module OpenTelemetry.Internal.LoggingSpec (spec) where++import Control.Exception (bracket_)+import Data.IORef+import Data.List (isInfixOf)+import OpenTelemetry.Internal.Logging+import Test.Hspec+++spec :: Spec+spec = sequential $+ describe "OpenTelemetry.Internal.Logging" $ do+ -- Implementation-specific: internal log level ordering for filtering+ -- https://opentelemetry.io/docs/specs/otel/error-handling/+ describe "OTelLogLevel" $ do+ it "orders None < Error < Warning < Info < Debug" $ do+ OTelLogNone `shouldSatisfy` (< OTelLogError)+ OTelLogError `shouldSatisfy` (< OTelLogWarning)+ OTelLogWarning `shouldSatisfy` (< OTelLogInfo)+ OTelLogInfo `shouldSatisfy` (< OTelLogDebug)++ -- Error handling §Error handling principles: global error handler+ -- https://opentelemetry.io/docs/specs/otel/error-handling/+ describe "global error handler" $ do+ it "setGlobalErrorHandler and getGlobalErrorHandler roundtrip" $ do+ ref <- newIORef ([] :: [String])+ old <- getGlobalErrorHandler+ let custom msg = modifyIORef ref (msg :)+ bracket_+ (setGlobalErrorHandler custom)+ (setGlobalErrorHandler old)+ $ do+ handler <- getGlobalErrorHandler+ handler "probe"+ msgs <- readIORef ref+ msgs `shouldBe` ["probe"]++ it "otelLogError passes a message containing ERROR and the payload" $ do+ captured <- newIORef Nothing+ old <- getGlobalErrorHandler+ let custom msg = writeIORef captured (Just msg)+ bracket_+ (setGlobalErrorHandler custom)+ (setGlobalErrorHandler old)+ $ do+ otelLogError "test"+ mmsg <- readIORef captured+ mmsg `shouldSatisfy` \case+ Just msg -> "ERROR" `isInfixOf` msg && "test" `isInfixOf` msg+ Nothing -> False++ it "otelLogWarning passes a message containing WARN and the payload" $ do+ captured <- newIORef Nothing+ old <- getGlobalErrorHandler+ let custom msg = writeIORef captured (Just msg)+ bracket_+ (setGlobalErrorHandler custom)+ (setGlobalErrorHandler old)+ $ do+ otelLogWarning "notice"+ mmsg <- readIORef captured+ mmsg `shouldSatisfy` \case+ Just msg -> "WARN" `isInfixOf` msg && "notice" `isInfixOf` msg+ Nothing -> False++ it "invokes the handler only when getOTelLogLevel reaches each minimum" $ do+ lvl <- getOTelLogLevel+ called <- newIORef False+ old <- getGlobalErrorHandler+ let mark _ = writeIORef called True+ let reset = writeIORef called False+ bracket_+ (setGlobalErrorHandler mark)+ (setGlobalErrorHandler old)+ $ do+ reset+ otelLogDebug "x"+ readIORef called >>= (`shouldBe` (lvl >= OTelLogDebug))+ reset+ otelLogInfo "x"+ readIORef called >>= (`shouldBe` (lvl >= OTelLogInfo))+ reset+ otelLogError "x"+ readIORef called >>= (`shouldBe` (lvl >= OTelLogError))
+ test/OpenTelemetry/Log/CoreSpec.hs view
@@ -0,0 +1,537 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module OpenTelemetry.Log.CoreSpec where++import Control.Concurrent.Async (mapConcurrently_)+import Control.Monad (void)+import qualified Data.HashMap.Strict as H+import Data.IORef (atomicModifyIORef', newIORef, readIORef, writeIORef)+import Data.Int (Int64)+import Data.Maybe (isJust)+import qualified Data.Text as T+import qualified OpenTelemetry.Attributes as A+import OpenTelemetry.Common (Timestamp (..), mkTimestamp)+import OpenTelemetry.Context (insertSpan)+import OpenTelemetry.Context.ThreadLocal (adjustContext, getContext)+import OpenTelemetry.Internal.AtomicCounter+import OpenTelemetry.Internal.Common.Types (FlushResult (..), ShutdownResult (..))+import OpenTelemetry.Internal.Log.Core (getLoggerMinSeverity, setLoggerMinSeverity)+import OpenTelemetry.Internal.Log.Types+import OpenTelemetry.Log.Core+import qualified OpenTelemetry.LogAttributes as LA+import OpenTelemetry.Resource+import OpenTelemetry.Resource.OperatingSystem+import OpenTelemetry.Trace.Core (SpanContext (..), defaultTraceFlags, getSpanContext, setSampled, wrapSpanContext)+import OpenTelemetry.Trace.Id (bytesToSpanId, bytesToTraceId)+import qualified OpenTelemetry.Trace.TraceState as TraceState+import Test.Hspec+++newtype TestLogRecordProcessor = TestLogRecordProcessor LogRecordProcessor+++instance Show TestLogRecordProcessor where+ show _ = "LogRecordProcessor {..}"+++spec :: Spec+spec = describe "Core" $ do+ -- Logs Bridge API §LoggerProvider: global provider and no-op defaults+ -- https://opentelemetry.io/docs/specs/otel/logs/bridge-api/+ describe "The global logger provider" $ do+ it "Returns a no-op LoggerProvider when not initialized" $ do+ LoggerProvider {..} <- getGlobalLoggerProvider+ fmap TestLogRecordProcessor loggerProviderProcessors `shouldSatisfy` null+ loggerProviderResource `shouldBe` emptyMaterializedResources+ loggerProviderAttributeLimits `shouldBe` LA.defaultAttributeLimits+ it "Allows a LoggerProvider to be set and returns that with subsequent calls to getGlobalLoggerProvider" $ do+ lp <-+ createLoggerProvider [] $+ LoggerProviderOptions+ { loggerProviderOptionsResource =+ materializeResources $+ toResource+ OperatingSystem+ { osType = "exampleOs"+ , osDescription = Nothing+ , osName = Nothing+ , osVersion = Nothing+ , osBuildId = Nothing+ }+ , loggerProviderOptionsAttributeLimits =+ LA.AttributeLimits+ { attributeCountLimit = Just 50+ , attributeLengthLimit = Just 50+ }+ , loggerProviderOptionsMinSeverity = Nothing+ }++ setGlobalLoggerProvider lp++ glp <- getGlobalLoggerProvider+ fmap TestLogRecordProcessor (loggerProviderProcessors glp) `shouldSatisfy` null+ loggerProviderResource glp `shouldBe` loggerProviderResource lp+ loggerProviderAttributeLimits glp `shouldBe` loggerProviderAttributeLimits lp+ -- Logs Bridge API §LogRecord: mutable attributes on emitted records+ -- https://opentelemetry.io/docs/specs/otel/logs/bridge-api/+ describe "addAttribute" $ do+ it "works" $ do+ lp <- getGlobalLoggerProvider+ let l = makeLogger lp InstrumentationLibrary {libraryName = "exampleLibrary", libraryVersion = "", librarySchemaUrl = "", libraryAttributes = A.emptyAttributes}+ lr <- emitLogRecord l $ emptyLogRecordArguments {attributes = H.fromList [("something", "a thing")]}++ addAttribute lr "anotherThing" ("another thing" :: LA.AnyValue)++ (_, attrs) <- LA.getAttributeMap <$> logRecordGetAttributes lr+ attrs+ `shouldBe` H.fromList+ [ ("anotherThing", "another thing")+ , ("something", "a thing")+ ]+ -- Logs Bridge API §LogRecord: batch attribute updates+ -- https://opentelemetry.io/docs/specs/otel/logs/bridge-api/+ describe "addAttributes" $ do+ it "works" $ do+ lp <- getGlobalLoggerProvider+ let l = makeLogger lp InstrumentationLibrary {libraryName = "exampleLibrary", libraryVersion = "", librarySchemaUrl = "", libraryAttributes = A.emptyAttributes}+ lr <- emitLogRecord l $ emptyLogRecordArguments {attributes = H.fromList [("something", "a thing")]}++ addAttributes lr $+ H.fromList+ [ ("anotherThing", "another thing" :: LA.AnyValue)+ , ("twoThing", "the second another thing")+ ]++ (_, attrs) <- LA.getAttributeMap <$> logRecordGetAttributes lr+ attrs+ `shouldBe` H.fromList+ [ ("anotherThing", "another thing")+ , ("something", "a thing")+ , ("twoThing", "the second another thing")+ ]+ -- Logs Bridge API §LogRecord: observed timestamp field+ -- https://opentelemetry.io/docs/specs/otel/logs/bridge-api/+ describe "observed_timestamp" $ do+ it "defaults to a non-zero timestamp when not set" $ do+ lp <- createLoggerProvider [] emptyLoggerProviderOptions+ let l = makeLogger lp (instrumentationLibrary "test" "1.0")+ lr <- emitLogRecord l emptyLogRecordArguments+ ilr <- readLogRecord lr+ let Timestamp obsNs = logRecordObservedTimestamp ilr+ obsNs `shouldSatisfy` (/= 0)++ it "uses explicit value when provided" $ do+ lp <- createLoggerProvider [] emptyLoggerProviderOptions+ let l = makeLogger lp (instrumentationLibrary "test" "1.0")+ explicit = mkTimestamp 1234567890 0+ lr <- emitLogRecord l emptyLogRecordArguments {observedTimestamp = Just explicit}+ ilr <- readLogRecord lr+ logRecordObservedTimestamp ilr `shouldBe` explicit++ -- Logs Bridge API §LoggerProvider: Shutdown and post-shutdown behavior+ -- https://opentelemetry.io/docs/specs/otel/logs/bridge-api/+ describe "LoggerProvider shutdown" $ do+ it "emitLogRecord does not invoke processors after shutdown" $ do+ callCount <- newAtomicCounter 0+ let countingProcessor =+ LogRecordProcessor+ { logRecordProcessorOnEmit = \_ _ ->+ void $ incrAtomicCounter callCount+ , logRecordProcessorShutdown = pure ShutdownSuccess+ , logRecordProcessorForceFlush = pure FlushSuccess+ }+ lp <- createLoggerProvider [countingProcessor] emptyLoggerProviderOptions+ let l = makeLogger lp (instrumentationLibrary "test" "1.0")+ _ <- emitLogRecord l emptyLogRecordArguments+ beforeShutdown <- readAtomicCounter callCount+ beforeShutdown `shouldBe` 1++ _ <- shutdownLoggerProvider lp Nothing+ _ <- emitLogRecord l emptyLogRecordArguments+ afterShutdown <- readAtomicCounter callCount+ afterShutdown `shouldBe` 1++ it "emitLogRecord still returns a LogRecord after shutdown" $ do+ lp <- createLoggerProvider [] emptyLoggerProviderOptions+ let l = makeLogger lp (instrumentationLibrary "test" "1.0")+ _ <- shutdownLoggerProvider lp Nothing+ lr <- emitLogRecord l emptyLogRecordArguments+ ilr <- readLogRecord lr+ let Timestamp obsNs = logRecordObservedTimestamp ilr+ obsNs `shouldSatisfy` (/= 0)++ it "loggerIsEnabled returns False after shutdown" $ do+ let countingProcessor =+ LogRecordProcessor+ { logRecordProcessorOnEmit = \_ _ -> pure ()+ , logRecordProcessorShutdown = pure ShutdownSuccess+ , logRecordProcessorForceFlush = pure FlushSuccess+ }+ lp <- createLoggerProvider [countingProcessor] emptyLoggerProviderOptions+ let l = makeLogger lp (instrumentationLibrary "test" "1.0")+ enabled1 <- loggerIsEnabled l Nothing Nothing+ enabled1 `shouldBe` True+ _ <- shutdownLoggerProvider lp Nothing+ enabled2 <- loggerIsEnabled l Nothing Nothing+ enabled2 `shouldBe` False++ it "shutdown is idempotent (second call returns failure)" $ do+ let processor =+ LogRecordProcessor+ { logRecordProcessorOnEmit = \_ _ -> pure ()+ , logRecordProcessorShutdown = pure ShutdownSuccess+ , logRecordProcessorForceFlush = pure FlushSuccess+ }+ lp <- createLoggerProvider [processor] emptyLoggerProviderOptions+ r1 <- shutdownLoggerProvider lp Nothing+ r1 `shouldBe` ShutdownSuccess+ r2 <- shutdownLoggerProvider lp Nothing+ r2 `shouldBe` ShutdownFailure++ it "loggerIsEnabled accepts severity parameter" $ do+ let processor =+ LogRecordProcessor+ { logRecordProcessorOnEmit = \_ _ -> pure ()+ , logRecordProcessorShutdown = pure ShutdownSuccess+ , logRecordProcessorForceFlush = pure FlushSuccess+ }+ lp <- createLoggerProvider [processor] emptyLoggerProviderOptions+ let l = makeLogger lp (instrumentationLibrary "test" "1.0")+ enabled <- loggerIsEnabled l (Just Warn) Nothing+ enabled `shouldBe` True++ it "loggerIsEnabled accepts eventName parameter" $ do+ let processor =+ LogRecordProcessor+ { logRecordProcessorOnEmit = \_ _ -> pure ()+ , logRecordProcessorShutdown = pure ShutdownSuccess+ , logRecordProcessorForceFlush = pure FlushSuccess+ }+ lp <- createLoggerProvider [processor] emptyLoggerProviderOptions+ let l = makeLogger lp (instrumentationLibrary "test" "1.0")+ enabled <- loggerIsEnabled l Nothing (Just "my.event")+ enabled `shouldBe` True++ it "loggerIsEnabled accepts both severity and eventName" $ do+ let processor =+ LogRecordProcessor+ { logRecordProcessorOnEmit = \_ _ -> pure ()+ , logRecordProcessorShutdown = pure ShutdownSuccess+ , logRecordProcessorForceFlush = pure FlushSuccess+ }+ lp <- createLoggerProvider [processor] emptyLoggerProviderOptions+ let l = makeLogger lp (instrumentationLibrary "test" "1.0")+ enabled <- loggerIsEnabled l (Just Error4) (Just "error.event")+ enabled `shouldBe` True++ -- Logs Bridge API §LoggerProvider: ForceFlush+ -- https://opentelemetry.io/docs/specs/otel/logs/bridge-api/+ describe "forceFlushLoggerProvider" $ do+ it "returns FlushSuccess when processors succeed" $ do+ let processor =+ LogRecordProcessor+ { logRecordProcessorOnEmit = \_ _ -> pure ()+ , logRecordProcessorShutdown = pure ShutdownSuccess+ , logRecordProcessorForceFlush = pure FlushSuccess+ }+ lp <- createLoggerProvider [processor] emptyLoggerProviderOptions+ result <- forceFlushLoggerProvider lp Nothing+ result `shouldBe` FlushSuccess++ it "returns FlushError when a processor flush throws" $ do+ let failingProcessor =+ LogRecordProcessor+ { logRecordProcessorOnEmit = \_ _ -> pure ()+ , logRecordProcessorShutdown = pure ShutdownSuccess+ , logRecordProcessorForceFlush = error "flush boom"+ }+ lp <- createLoggerProvider [failingProcessor] emptyLoggerProviderOptions+ result <- forceFlushLoggerProvider lp Nothing+ result `shouldBe` FlushError++ it "returns FlushSuccess with no processors" $ do+ lp <- createLoggerProvider [] emptyLoggerProviderOptions+ result <- forceFlushLoggerProvider lp Nothing+ result `shouldBe` FlushSuccess++ -- Logs data model §Trace context fields: correlate logs with traces+ -- https://opentelemetry.io/docs/specs/otel/logs/bridge-api/+ describe "log-trace correlation" $ do+ it "log record carries active span's traceId, spanId, and traceFlags" $ do+ let Right tid = bytesToTraceId "\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\x0f\x10"+ Right sid = bytesToSpanId "\xaa\xbb\xcc\xdd\xee\xff\x11\x22"+ sc =+ SpanContext+ { traceFlags = setSampled defaultTraceFlags+ , isRemote = False+ , traceId = tid+ , spanId = sid+ , traceState = TraceState.empty+ }+ adjustContext (insertSpan (wrapSpanContext sc))+ lp <- createLoggerProvider [] emptyLoggerProviderOptions+ let l = makeLogger lp (instrumentationLibrary "test" "1.0")+ lr <- emitLogRecord l emptyLogRecordArguments+ ilr <- readLogRecord lr+ logRecordTracingDetails ilr `shouldBe` TracingDetails tid sid (setSampled defaultTraceFlags)++ it "log record has no tracing details when no span is active" $ do+ adjustContext (\_ -> mempty)+ lp <- createLoggerProvider [] emptyLoggerProviderOptions+ let l = makeLogger lp (instrumentationLibrary "test" "1.0")+ lr <- emitLogRecord l emptyLogRecordArguments+ ilr <- readLogRecord lr+ logRecordTracingDetails ilr `shouldBe` NoTracingDetails++ it "log record uses explicit context when provided" $ do+ let Right tid = bytesToTraceId "\xf0\xf1\xf2\xf3\xf4\xf5\xf6\xf7\xf8\xf9\xfa\xfb\xfc\xfd\xfe\xff"+ Right sid = bytesToSpanId "\x01\x02\x03\x04\x05\x06\x07\x08"+ sc =+ SpanContext+ { traceFlags = defaultTraceFlags+ , isRemote = False+ , traceId = tid+ , spanId = sid+ , traceState = TraceState.empty+ }+ explicitCtx = insertSpan (wrapSpanContext sc) mempty+ adjustContext (\_ -> mempty)+ lp <- createLoggerProvider [] emptyLoggerProviderOptions+ let l = makeLogger lp (instrumentationLibrary "test" "1.0")+ lr <- emitLogRecord l emptyLogRecordArguments {context = Just explicitCtx}+ ilr <- readLogRecord lr+ logRecordTracingDetails ilr `shouldBe` TracingDetails tid sid defaultTraceFlags++ it "processor receives the current context alongside the log record" $ do+ let Right tid = bytesToTraceId "\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\x0f\x10"+ Right sid = bytesToSpanId "\xaa\xbb\xcc\xdd\xee\xff\x11\x22"+ sc =+ SpanContext+ { traceFlags = setSampled defaultTraceFlags+ , isRemote = False+ , traceId = tid+ , spanId = sid+ , traceState = TraceState.empty+ }+ adjustContext (insertSpan (wrapSpanContext sc))+ ctxRef <- newIORef Nothing+ let capturingProcessor =+ LogRecordProcessor+ { logRecordProcessorOnEmit = \_ ctx -> writeIORef ctxRef (Just ctx)+ , logRecordProcessorShutdown = pure ShutdownSuccess+ , logRecordProcessorForceFlush = pure FlushSuccess+ }+ lp <- createLoggerProvider [capturingProcessor] emptyLoggerProviderOptions+ let l = makeLogger lp (instrumentationLibrary "test" "1.0")+ _ <- emitLogRecord l emptyLogRecordArguments+ mCtx <- readIORef ctxRef+ case mCtx of+ Nothing -> expectationFailure "expected processor to receive context"+ Just _ -> pure ()++ -- Implementation-specific: concurrent mutation of LogRecord attributes+ -- https://opentelemetry.io/docs/specs/otel/logs/bridge-api/+ describe "concurrent addAttribute" $ do+ it "retains all attributes when many threads add unique keys" $ do+ lp <- createLoggerProvider [] emptyLoggerProviderOptions+ let l = makeLogger lp (instrumentationLibrary "test" "1.0")+ lr <- emitLogRecord l emptyLogRecordArguments+ mapConcurrently_ (\i -> addAttribute lr ("key" <> T.pack (show i)) (fromIntegral i :: Int64)) [(1 :: Int) .. 100]+ ilr <- readLogRecord lr+ let (cnt, attrs) = LA.getAttributeMap (logRecordAttributes ilr)+ cnt `shouldBe` 100+ H.size attrs `shouldBe` 100++ -- Common §Attribute limits (applied to LogRecord attributes)+ -- https://opentelemetry.io/docs/specs/otel/common/#attribute-limits+ describe "Log attribute limits" $ do+ it "enforces attributeCountLimit by dropping excess attributes" $ do+ lp <-+ createLoggerProvider [] $+ LoggerProviderOptions+ { loggerProviderOptionsResource = emptyMaterializedResources+ , loggerProviderOptionsAttributeLimits =+ LA.AttributeLimits+ { attributeCountLimit = Just 3+ , attributeLengthLimit = Nothing+ }+ , loggerProviderOptionsMinSeverity = Nothing+ }+ let l = makeLogger lp (instrumentationLibrary "test" "1.0")+ lr <- emitLogRecord l emptyLogRecordArguments+ addAttribute lr "a1" ("v1" :: LA.AnyValue)+ addAttribute lr "a2" ("v2" :: LA.AnyValue)+ addAttribute lr "a3" ("v3" :: LA.AnyValue)+ addAttribute lr "a4" ("v4" :: LA.AnyValue)+ addAttribute lr "a5" ("v5" :: LA.AnyValue)+ ilr <- readLogRecord lr+ let (cnt, _) = LA.getAttributeMap (logRecordAttributes ilr)+ cnt `shouldBe` 3++ it "enforces attributeLengthLimit by truncating string values" $ do+ lp <-+ createLoggerProvider [] $+ LoggerProviderOptions+ { loggerProviderOptionsResource = emptyMaterializedResources+ , loggerProviderOptionsAttributeLimits =+ LA.AttributeLimits+ { attributeCountLimit = Nothing+ , attributeLengthLimit = Just 5+ }+ , loggerProviderOptionsMinSeverity = Nothing+ }+ let l = makeLogger lp (instrumentationLibrary "test" "1.0")+ lr <- emitLogRecord l emptyLogRecordArguments+ addAttribute lr "key" (LA.TextValue "abcdefghij")+ ilr <- readLogRecord lr+ let (_, attrs) = LA.getAttributeMap (logRecordAttributes ilr)+ case H.lookup "key" attrs of+ Just (LA.TextValue t) -> T.length t `shouldSatisfy` (<= 5)+ _ -> expectationFailure "expected TextValue"++ -- Logs SDK §LogRecordProcessor: processor pipeline ordering (implementation)+ -- https://opentelemetry.io/docs/specs/otel/logs/bridge-api/+ describe "Multi-processor ordering" $ do+ it "processors are called in registration order" $ do+ orderRef <- newIORef ([] :: [String])+ let mkProc label =+ LogRecordProcessor+ { logRecordProcessorOnEmit = \_ _ ->+ atomicModifyIORef' orderRef (\xs -> (xs ++ [label], ()))+ , logRecordProcessorShutdown = pure ShutdownSuccess+ , logRecordProcessorForceFlush = pure FlushSuccess+ }+ lp <- createLoggerProvider [mkProc "A", mkProc "B"] emptyLoggerProviderOptions+ let l = makeLogger lp (instrumentationLibrary "test" "1.0")+ _ <- emitLogRecord l emptyLogRecordArguments+ order <- readIORef orderRef+ order `shouldBe` ["A", "B"]++ -- Logs Bridge API §Severity: Logger.isEnabled / minimum severity filtering+ -- https://opentelemetry.io/docs/specs/otel/logs/bridge-api/+ describe "Severity filtering" $ do+ it "loggerIsEnabled returns True when no minSeverity is set" $ do+ lp <- createLoggerProvider [noopProcessor] emptyLoggerProviderOptions+ let l = makeLogger lp (instrumentationLibrary "test" "1.0")+ enabled <- loggerIsEnabled l (Just Debug) Nothing+ enabled `shouldBe` True++ it "loggerIsEnabled returns True when severity >= threshold" $ do+ lp <- createLoggerProvider [noopProcessor] emptyLoggerProviderOptions {loggerProviderOptionsMinSeverity = Just Warn}+ let l = makeLogger lp (instrumentationLibrary "test" "1.0")+ e1 <- loggerIsEnabled l (Just Warn) Nothing+ e1 `shouldBe` True+ e2 <- loggerIsEnabled l (Just Error) Nothing+ e2 `shouldBe` True+ e3 <- loggerIsEnabled l (Just Fatal) Nothing+ e3 `shouldBe` True++ it "loggerIsEnabled returns False when severity < threshold" $ do+ lp <- createLoggerProvider [noopProcessor] emptyLoggerProviderOptions {loggerProviderOptionsMinSeverity = Just Warn}+ let l = makeLogger lp (instrumentationLibrary "test" "1.0")+ e1 <- loggerIsEnabled l (Just Debug) Nothing+ e1 `shouldBe` False+ e2 <- loggerIsEnabled l (Just Info) Nothing+ e2 `shouldBe` False+ e3 <- loggerIsEnabled l (Just Trace) Nothing+ e3 `shouldBe` False++ it "loggerIsEnabled returns True when severity is Nothing (unspecified)" $ do+ lp <- createLoggerProvider [noopProcessor] emptyLoggerProviderOptions {loggerProviderOptionsMinSeverity = Just Error}+ let l = makeLogger lp (instrumentationLibrary "test" "1.0")+ enabled <- loggerIsEnabled l Nothing Nothing+ enabled `shouldBe` True++ it "emitLogRecord skips processors when severity < threshold" $ do+ callCount <- newAtomicCounter 0+ let counting =+ LogRecordProcessor+ { logRecordProcessorOnEmit = \_ _ -> void $ incrAtomicCounter callCount+ , logRecordProcessorShutdown = pure ShutdownSuccess+ , logRecordProcessorForceFlush = pure FlushSuccess+ }+ lp <- createLoggerProvider [counting] emptyLoggerProviderOptions {loggerProviderOptionsMinSeverity = Just Warn}+ let l = makeLogger lp (instrumentationLibrary "test" "1.0")+ _ <- emitLogRecord l emptyLogRecordArguments {severityNumber = Just Debug}+ c1 <- readAtomicCounter callCount+ c1 `shouldBe` 0+ _ <- emitLogRecord l emptyLogRecordArguments {severityNumber = Just Warn}+ c2 <- readAtomicCounter callCount+ c2 `shouldBe` 1+ _ <- emitLogRecord l emptyLogRecordArguments {severityNumber = Just Error}+ c3 <- readAtomicCounter callCount+ c3 `shouldBe` 2++ it "emitLogRecord forwards records with no severity when threshold is set" $ do+ callCount <- newAtomicCounter 0+ let counting =+ LogRecordProcessor+ { logRecordProcessorOnEmit = \_ _ -> void $ incrAtomicCounter callCount+ , logRecordProcessorShutdown = pure ShutdownSuccess+ , logRecordProcessorForceFlush = pure FlushSuccess+ }+ lp <- createLoggerProvider [counting] emptyLoggerProviderOptions {loggerProviderOptionsMinSeverity = Just Error}+ let l = makeLogger lp (instrumentationLibrary "test" "1.0")+ _ <- emitLogRecord l emptyLogRecordArguments {severityNumber = Nothing}+ c <- readAtomicCounter callCount+ c `shouldBe` 1++ it "setLoggerMinSeverity changes threshold at runtime" $ do+ callCount <- newAtomicCounter 0+ let counting =+ LogRecordProcessor+ { logRecordProcessorOnEmit = \_ _ -> void $ incrAtomicCounter callCount+ , logRecordProcessorShutdown = pure ShutdownSuccess+ , logRecordProcessorForceFlush = pure FlushSuccess+ }+ lp <- createLoggerProvider [counting] emptyLoggerProviderOptions+ let l = makeLogger lp (instrumentationLibrary "test" "1.0")+ _ <- emitLogRecord l emptyLogRecordArguments {severityNumber = Just Debug}+ c1 <- readAtomicCounter callCount+ c1 `shouldBe` 1+ setLoggerMinSeverity lp (Just Error)+ _ <- emitLogRecord l emptyLogRecordArguments {severityNumber = Just Debug}+ c2 <- readAtomicCounter callCount+ c2 `shouldBe` 1+ _ <- emitLogRecord l emptyLogRecordArguments {severityNumber = Just Error}+ c3 <- readAtomicCounter callCount+ c3 `shouldBe` 2++ it "getLoggerMinSeverity reads the current threshold" $ do+ lp <- createLoggerProvider [] emptyLoggerProviderOptions+ s0 <- getLoggerMinSeverity lp+ s0 `shouldBe` Nothing+ setLoggerMinSeverity lp (Just Warn)+ s1 <- getLoggerMinSeverity lp+ s1 `shouldBe` Just Warn+ setLoggerMinSeverity lp Nothing+ s2 <- getLoggerMinSeverity lp+ s2 `shouldBe` Nothing++ it "setLoggerMinSeverity to Nothing disables filtering" $ do+ callCount <- newAtomicCounter 0+ let counting =+ LogRecordProcessor+ { logRecordProcessorOnEmit = \_ _ -> void $ incrAtomicCounter callCount+ , logRecordProcessorShutdown = pure ShutdownSuccess+ , logRecordProcessorForceFlush = pure FlushSuccess+ }+ lp <- createLoggerProvider [counting] emptyLoggerProviderOptions {loggerProviderOptionsMinSeverity = Just Fatal}+ let l = makeLogger lp (instrumentationLibrary "test" "1.0")+ _ <- emitLogRecord l emptyLogRecordArguments {severityNumber = Just Debug}+ c1 <- readAtomicCounter callCount+ c1 `shouldBe` 0+ setLoggerMinSeverity lp Nothing+ _ <- emitLogRecord l emptyLogRecordArguments {severityNumber = Just Debug}+ c2 <- readAtomicCounter callCount+ c2 `shouldBe` 1+++noopProcessor :: LogRecordProcessor+noopProcessor =+ LogRecordProcessor+ { logRecordProcessorOnEmit = \_ _ -> pure ()+ , logRecordProcessorShutdown = pure ShutdownSuccess+ , logRecordProcessorForceFlush = pure FlushSuccess+ }
− test/OpenTelemetry/Logs/CoreSpec.hs
@@ -1,91 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}--module OpenTelemetry.Logs.CoreSpec where--import qualified Data.HashMap.Strict as H-import Data.IORef-import qualified Data.Text as T-import qualified OpenTelemetry.Attributes as A-import OpenTelemetry.Internal.Logs.Types-import qualified OpenTelemetry.LogAttributes as LA-import OpenTelemetry.Logs.Core-import OpenTelemetry.Resource-import OpenTelemetry.Resource.OperatingSystem-import Test.Hspec---newtype TestLogRecordProcessor = TestLogRecordProcessor LogRecordProcessor---instance Show TestLogRecordProcessor where- show _ = "LogRecordProcessor {..}"---spec :: Spec-spec = describe "Core" $ do- describe "The global logger provider" $ do- it "Returns a no-op LoggerProvider when not initialized" $ do- LoggerProvider {..} <- getGlobalLoggerProvider- fmap TestLogRecordProcessor loggerProviderProcessors `shouldSatisfy` null- loggerProviderResource `shouldBe` emptyMaterializedResources- loggerProviderAttributeLimits `shouldBe` LA.defaultAttributeLimits- it "Allows a LoggerProvider to be set and returns that with subsequent calls to getGlobalLoggerProvider" $ do- let lp =- createLoggerProvider [] $- LoggerProviderOptions- { loggerProviderOptionsResource =- materializeResources $- toResource- OperatingSystem- { osType = "exampleOs"- , osDescription = Nothing- , osName = Nothing- , osVersion = Nothing- }- , loggerProviderOptionsAttributeLimits =- LA.AttributeLimits- { attributeCountLimit = Just 50- , attributeLengthLimit = Just 50- }- }-- setGlobalLoggerProvider lp-- glp <- getGlobalLoggerProvider- fmap TestLogRecordProcessor (loggerProviderProcessors glp) `shouldSatisfy` null- loggerProviderResource glp `shouldBe` loggerProviderResource lp- loggerProviderAttributeLimits glp `shouldBe` loggerProviderAttributeLimits lp- describe "addAttribute" $ do- it "works" $ do- lp <- getGlobalLoggerProvider- let l = makeLogger lp InstrumentationLibrary {libraryName = "exampleLibrary", libraryVersion = "", librarySchemaUrl = "", libraryAttributes = A.emptyAttributes}- lr <- emitLogRecord l $ emptyLogRecordArguments {attributes = H.fromList [("something", "a thing")]}-- addAttribute lr "anotherThing" ("another thing" :: LA.AnyValue)-- (_, attrs) <- LA.getAttributeMap <$> logRecordGetAttributes lr- attrs- `shouldBe` H.fromList- [ ("anotherThing", "another thing")- , ("something", "a thing")- ]- describe "addAttributes" $ do- it "works" $ do- lp <- getGlobalLoggerProvider- let l = makeLogger lp InstrumentationLibrary {libraryName = "exampleLibrary", libraryVersion = "", librarySchemaUrl = "", libraryAttributes = A.emptyAttributes}- lr <- emitLogRecord l $ emptyLogRecordArguments {attributes = H.fromList [("something", "a thing")]}-- addAttributes lr $- H.fromList- [ ("anotherThing", "another thing" :: LA.AnyValue)- , ("twoThing", "the second another thing")- ]-- (_, attrs) <- LA.getAttributeMap <$> logRecordGetAttributes lr- attrs- `shouldBe` H.fromList- [ ("anotherThing", "another thing")- , ("something", "a thing")- , ("twoThing", "the second another thing")- ]
+ test/OpenTelemetry/MetricSpec.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE OverloadedStrings #-}++module OpenTelemetry.MetricSpec (spec) where++import Data.Maybe (isJust)+import OpenTelemetry.Attributes (emptyAttributes)+import OpenTelemetry.Internal.Common.Types (FlushResult (..), InstrumentationLibrary (..), ShutdownResult (..))+import OpenTelemetry.Metric.Core+import OpenTelemetry.Metric.InstrumentName (validateInstrumentName, validateInstrumentUnit)+import Test.Hspec+++spec :: Spec+spec = do+ -- Metrics API §Instrument naming rules (SDK validation; API does not validate names)+ -- https://opentelemetry.io/docs/specs/otel/metrics/api/#instrument-name-syntax+ describe "validateInstrumentName (SDK uses this; API MUST NOT validate names)" $ do+ it "MUST reject empty names" $+ validateInstrumentName mempty `shouldSatisfy` isJust+ it "MUST reject names longer than 255 characters" $+ validateInstrumentName (mconcat (replicate 256 "a")) `shouldSatisfy` isJust+ it "MUST reject names not starting with a letter" $+ validateInstrumentName "1abc" `shouldSatisfy` isJust+ it "MUST reject disallowed characters" $+ validateInstrumentName "a b" `shouldSatisfy` isJust+ it "accepts typical valid names" $ do+ validateInstrumentName "a" `shouldBe` Nothing+ validateInstrumentName "http.server.duration" `shouldBe` Nothing+ validateInstrumentName "a_B-c/d" `shouldBe` Nothing++ -- Metrics API §Instrument unit: unit field constraints+ -- https://opentelemetry.io/docs/specs/otel/metrics/api/#instrument-unit+ describe "validateInstrumentUnit" $ do+ it "MUST reject units longer than 63 characters" $+ validateInstrumentUnit (mconcat (replicate 64 "x")) `shouldSatisfy` isJust+ it "accepts empty unit (caller may omit)" $+ validateInstrumentUnit mempty `shouldBe` Nothing++ -- Metrics API §Enabled: noop provider returns disabled instruments+ -- https://opentelemetry.io/docs/specs/otel/metrics/api/#enabled+ describe "noopMeterProvider" $ do+ it "SHOULD return disabled synchronous instruments (Enabled API)" $ do+ let mp = noopMeterProvider+ m <- getMeter mp ("test" :: InstrumentationLibrary)+ c <- meterCreateCounterInt64 m "requests" Nothing Nothing defaultAdvisoryParameters+ enabled <- counterEnabled c+ enabled `shouldBe` False+ counterAdd c 1 emptyAttributes+ it "SHOULD return disabled observable instruments (Enabled API)" $ do+ let mp = noopMeterProvider+ m <- getMeter mp ("obs" :: InstrumentationLibrary)+ oc <- meterCreateObservableCounterInt64 m "oc" Nothing Nothing defaultAdvisoryParameters []+ oud <- meterCreateObservableUpDownCounterInt64 m "oud" Nothing Nothing defaultAdvisoryParameters []+ og <- meterCreateObservableGaugeInt64 m "og" Nothing Nothing defaultAdvisoryParameters []+ observableCounterEnabled oc `shouldReturn` False+ observableUpDownCounterEnabled oud `shouldReturn` False+ observableGaugeEnabled og `shouldReturn` False++ -- Metrics API §MeterProvider: Shutdown and ForceFlush on noop provider+ -- https://opentelemetry.io/docs/specs/otel/metrics/api/#meterprovider-operations+ describe "noopMeterProvider shutdown" $ do+ it "implements Shutdown and ForceFlush without error" $ do+ shutdownMeterProvider noopMeterProvider Nothing `shouldReturn` ShutdownSuccess+ forceFlushMeterProvider noopMeterProvider Nothing `shouldReturn` FlushSuccess
+ test/OpenTelemetry/PropagatorSpec.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE OverloadedStrings #-}++module OpenTelemetry.PropagatorSpec where++import Data.List (sort)+import qualified OpenTelemetry.Context as Ctx+import OpenTelemetry.Propagator+import Test.Hspec+++spec :: Spec+spec = describe "Propagator" $ do+ -- Propagators API §TextMap Propagator: carrier get/set keys+ -- https://opentelemetry.io/docs/specs/otel/context/api-propagators/+ describe "TextMap" $ do+ it "emptyTextMap has no keys" $ do+ textMapKeys emptyTextMap `shouldBe` []++ it "textMapInsert then textMapLookup retrieves value" $ do+ let tm = textMapInsert "foo" "bar" emptyTextMap+ textMapLookup "foo" tm `shouldBe` Just "bar"++ it "is case-insensitive on keys" $ do+ let tm = textMapInsert "Content-Type" "text/plain" emptyTextMap+ textMapLookup "content-type" tm `shouldBe` Just "text/plain"+ textMapLookup "CONTENT-TYPE" tm `shouldBe` Just "text/plain"+ textMapKeys tm `shouldMatchList` ["Content-Type"]+ textMapToList tm `shouldMatchList` [("Content-Type", "text/plain")]++ it "textMapDelete removes entry" $ do+ let tm = textMapInsert "k" "v" emptyTextMap+ tm' = textMapDelete "k" tm+ textMapLookup "k" tm' `shouldBe` Nothing++ it "textMapDelete is case-insensitive" $ do+ let tm = textMapInsert "X-Custom" "val" emptyTextMap+ tm' = textMapDelete "x-custom" tm+ textMapLookup "x-custom" tm' `shouldBe` Nothing++ it "textMapKeys returns all keys" $ do+ let tm = textMapInsert "b" "2" $ textMapInsert "a" "1" emptyTextMap+ sort (textMapKeys tm) `shouldBe` ["a", "b"]++ it "textMapToList returns all pairs" $ do+ let tm = textMapFromList [("X", "1"), ("Y", "2")]+ pairs = textMapToList tm+ length pairs `shouldBe` 2++ it "textMapFromList preserves key casing" $ do+ let tm = textMapFromList [("FOO", "bar")]+ textMapLookup "foo" tm `shouldBe` Just "bar"+ textMapToList tm `shouldMatchList` [("FOO", "bar")]++ it "textMapInsert overwrites existing key" $ do+ let tm = textMapInsert "k" "v1" $ textMapInsert "k" "v2" emptyTextMap+ textMapLookup "k" tm `shouldBe` Just "v1"++ -- Propagators API §Composite Propagator: fields, extract, inject+ -- https://opentelemetry.io/docs/specs/otel/context/api-propagators/+ describe "Propagator composition" $ do+ it "mempty propagator fields are empty" $ do+ let p = mempty :: TextMapPropagator+ propagatorFields p `shouldBe` []++ it "composed propagator merges fields" $ do+ let p1 = Propagator {propagatorFields = ["traceparent"], extractor = \_ c -> pure c, injector = \_ o -> pure o}+ p2 = Propagator {propagatorFields = ["baggage"], extractor = \_ c -> pure c, injector = \_ o -> pure o}+ combined = p1 <> p2 :: TextMapPropagator+ propagatorFields combined `shouldBe` ["traceparent", "baggage"]++ it "extract chains extractors" $ do+ let p1 = Propagator {propagatorFields = [], extractor = \_ c -> pure c, injector = \_ o -> pure o}+ p2 = Propagator {propagatorFields = [], extractor = \_ c -> pure c, injector = \_ o -> pure o}+ combined = p1 <> p2 :: TextMapPropagator+ _ <- extract combined emptyTextMap Ctx.empty :: IO Ctx.Context+ pure ()++ it "inject chains injectors left to right" $ do+ let p1 = Propagator {propagatorFields = ["a"], extractor = \_ c -> pure c, injector = \_ tm -> pure (textMapInsert "a" "1" tm)}+ p2 = Propagator {propagatorFields = ["b"], extractor = \_ c -> pure c, injector = \_ tm -> pure (textMapInsert "b" "2" tm)}+ combined = p1 <> p2 :: TextMapPropagator+ result <- inject combined Ctx.empty emptyTextMap+ textMapLookup "a" result `shouldBe` Just "1"+ textMapLookup "b" result `shouldBe` Just "2"++ -- Implementation-specific: global TextMap propagator registry slot+ -- https://opentelemetry.io/docs/specs/otel/context/api-propagators/+ describe "Global TextMapPropagator" $ do+ it "setGlobalTextMapPropagator and getGlobalTextMapPropagator roundtrip" $ do+ let p = Propagator {propagatorFields = ["test-field"], extractor = \_ c -> pure c, injector = \_ o -> pure o} :: TextMapPropagator+ setGlobalTextMapPropagator p+ p' <- getGlobalTextMapPropagator+ propagatorFields p' `shouldBe` ["test-field"]+ setGlobalTextMapPropagator (mempty :: TextMapPropagator)
+ test/OpenTelemetry/RegistrySpec.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE OverloadedStrings #-}++module OpenTelemetry.RegistrySpec where++import qualified Data.HashMap.Strict as H+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.Maybe (isJust, isNothing)+import OpenTelemetry.Exporter.Span (SpanExporter (..))+import OpenTelemetry.Internal.Common.Types (ExportResult (..), FlushResult (..), ShutdownResult (..))+import OpenTelemetry.Registry+import Test.Hspec+++noopExporter :: String -> IO SpanExporter+noopExporter tag = do+ ref <- newIORef tag+ pure+ SpanExporter+ { spanExporterExport = \_ -> readIORef ref >> pure Success+ , spanExporterShutdown = pure ShutdownSuccess+ , spanExporterForceFlush = pure FlushSuccess+ }+++assertJust :: String -> Maybe a -> IO a+assertJust msg Nothing = expectationFailure msg >> error "unreachable"+assertJust _ (Just a) = pure a+++spec :: Spec+spec = do+ -- Implementation-specific: SDK exporter registry for configuration wiring+ describe "OpenTelemetry.Registry" $ do+ describe "Span Exporter Registry" $ do+ it "stores a factory that can be looked up by name" $ do+ registerSpanExporterFactory "reg-test-store" (noopExporter "a")+ result <- lookupSpanExporterFactory "reg-test-store"+ isJust result `shouldBe` True++ it "returns Nothing for unregistered names" $ do+ result <- lookupSpanExporterFactory "no-such-exporter-xyz"+ isNothing result `shouldBe` True++ it "replaces an existing entry on re-registration" $ do+ ref <- newIORef ("" :: String)+ registerSpanExporterFactory "reg-test-replace" $ do+ writeIORef ref "first"+ noopExporter "first"+ registerSpanExporterFactory "reg-test-replace" $ do+ writeIORef ref "second"+ noopExporter "second"+ factory <- assertJust "expected factory" =<< lookupSpanExporterFactory "reg-test-replace"+ _ <- factory+ readIORef ref `shouldReturn` "second"++ it "registerIfAbsent inserts when key is absent and returns True" $ do+ inserted <- registerSpanExporterFactoryIfAbsent "reg-test-absent-new" (noopExporter "first")+ inserted `shouldBe` True+ isJust <$> lookupSpanExporterFactory "reg-test-absent-new" >>= (`shouldBe` True)++ it "registerIfAbsent returns False and preserves original when key exists" $ do+ ref <- newIORef ("" :: String)+ registerSpanExporterFactory "reg-test-absent-dup" $ do+ writeIORef ref "original"+ noopExporter "original"+ inserted <- registerSpanExporterFactoryIfAbsent "reg-test-absent-dup" $ do+ writeIORef ref "replacement"+ noopExporter "replacement"+ inserted `shouldBe` False+ factory <- assertJust "expected factory" =<< lookupSpanExporterFactory "reg-test-absent-dup"+ _ <- factory+ readIORef ref `shouldReturn` "original"++ it "registeredSpanExporterFactories includes all registered entries" $ do+ registerSpanExporterFactory "reg-test-all-a" (noopExporter "a")+ registerSpanExporterFactory "reg-test-all-b" (noopExporter "b")+ allFactories <- registeredSpanExporterFactories+ H.member "reg-test-all-a" allFactories `shouldBe` True+ H.member "reg-test-all-b" allFactories `shouldBe` True++ it "registered factory produces a working exporter" $ do+ registerSpanExporterFactory "reg-test-works" (noopExporter "works")+ factory <- assertJust "expected factory" =<< lookupSpanExporterFactory "reg-test-works"+ exporter <- factory+ result <- spanExporterExport exporter H.empty+ case result of+ Success -> pure ()+ _ -> expectationFailure "expected export Success"++ describe "Text Map Propagator Registry" $ do+ it "stores a propagator that can be looked up by name" $ do+ registerTextMapPropagator "reg-test-prop-store" mempty+ isJust <$> lookupRegisteredTextMapPropagator "reg-test-prop-store" >>= (`shouldBe` True)++ it "returns Nothing for unregistered names" $ do+ isNothing <$> lookupRegisteredTextMapPropagator "no-such-propagator-xyz" >>= (`shouldBe` True)++ it "registerIfAbsent inserts when key is absent and returns True" $ do+ inserted <- registerTextMapPropagatorIfAbsent "reg-test-prop-absent" mempty+ inserted `shouldBe` True++ it "registerIfAbsent returns False when key exists" $ do+ registerTextMapPropagator "reg-test-prop-dup" mempty+ inserted <- registerTextMapPropagatorIfAbsent "reg-test-prop-dup" mempty+ inserted `shouldBe` False++ it "registeredTextMapPropagators includes all registered entries" $ do+ registerTextMapPropagator "reg-test-prop-x" mempty+ registerTextMapPropagator "reg-test-prop-y" mempty+ allProps <- registeredTextMapPropagators+ H.member "reg-test-prop-x" allProps `shouldBe` True+ H.member "reg-test-prop-y" allProps `shouldBe` True
test/OpenTelemetry/ResourceSpec.hs view
@@ -1,15 +1,42 @@-{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeApplications #-} module OpenTelemetry.ResourceSpec where import qualified Data.Text as T+import OpenTelemetry.Attributes (lookupAttribute, toAttribute) import qualified OpenTelemetry.Resource as R import qualified Test.Hspec as Hspec spec :: Hspec.Spec spec = Hspec.describe "Resource" $ do+ -- Resource SDK §Resource Creation: schema URL on materialized resources+ -- https://opentelemetry.io/docs/specs/otel/resource/sdk/+ Hspec.describe "materializeResourcesWithSchema" $ do+ Hspec.it "sets schema when Just is provided" $ do+ let mat =+ R.materializeResourcesWithSchema+ (Just "https://example.com")+ (mkExampleResource "svc" 1)+ R.getMaterializedResourcesSchema mat `Hspec.shouldBe` Just "https://example.com"++ Hspec.it "leaves schema Nothing when not provided" $ do+ let mat = R.materializeResourcesWithSchema Nothing (mkExampleResource "svc" 1)+ R.getMaterializedResourcesSchema mat `Hspec.shouldBe` Nothing++ Hspec.describe "setMaterializedResourcesSchema" $ do+ Hspec.it "overrides an existing schema" $ do+ let mat =+ R.materializeResourcesWithSchema+ (Just "https://example.com")+ (mkExampleResource "svc" 1)+ mat' = R.setMaterializedResourcesSchema (Just "new") mat+ R.getMaterializedResourcesSchema mat' `Hspec.shouldBe` Just "new"++ -- Resource SDK §Merge resources: conflicting attributes use primary (left) value+ -- https://opentelemetry.io/docs/specs/otel/resource/sdk/ Hspec.describe "mergeResources" $ do Hspec.it "Is left-biased when attribute keys conflict" $ do let right = mkExampleResource "Old Right" 3@@ -22,8 +49,51 @@ left = mkExampleResource "New Left" 7 R.materializeResources (left <> right) `Hspec.shouldBe` R.materializeResources left + -- Resource SDK §Merge resources: schema URL merge rules+ -- https://opentelemetry.io/docs/specs/otel/resource/sdk/+ Hspec.describe "Schema URL merge" $ do+ Hspec.it "merge preserves schema when both match" $ do+ let r1 = R.mkResourceWithSchema (Just (T.pack "https://v1")) [ExampleName R..= ("a" :: T.Text), ExampleCount R..= (1 :: Int)]+ r2 = R.mkResourceWithSchema (Just (T.pack "https://v1")) [ExampleName R..= ("b" :: T.Text), ExampleCount R..= (2 :: Int)]+ merged = R.materializeResources (R.mergeResources r1 r2)+ R.getMaterializedResourcesSchema merged `Hspec.shouldBe` Just "https://v1" -mkExampleResource :: T.Text -> Int -> R.Resource 'Nothing+ Hspec.it "merge with one empty schema takes non-empty" $ do+ let r1 = R.mkResourceWithSchema (Just (T.pack "https://v1")) [ExampleName R..= ("a" :: T.Text), ExampleCount R..= (1 :: Int)]+ r2 = R.mkResourceWithSchema Nothing [ExampleName R..= ("b" :: T.Text), ExampleCount R..= (2 :: Int)]+ merged = R.materializeResources (R.mergeResources r1 r2)+ R.getMaterializedResourcesSchema merged `Hspec.shouldBe` Just "https://v1"++ Hspec.it "merge with conflicting schemas takes left (updating) schema" $ do+ let r1 = R.mkResourceWithSchema (Just "https://v1") [ExampleName R..= ("a" :: T.Text)]+ r2 = R.mkResourceWithSchema (Just "https://v2") [ExampleCount R..= (1 :: Int)]+ merged = R.materializeResources (R.mergeResources r1 r2)+ R.getMaterializedResourcesSchema merged `Hspec.shouldBe` Just "https://v1"++ Hspec.describe "getMaterializedResourcesAttributes" $ do+ Hspec.it "returns the attributes from a materialized resource" $ do+ let r = R.mkResource [ExampleName R..= ("svc" :: T.Text)]+ mat = R.materializeResources r+ attrs = R.getMaterializedResourcesAttributes mat+ lookupAttribute attrs "example.name" `Hspec.shouldBe` Just (toAttribute @T.Text "svc")++ -- Resource SDK §Resource Creation: optional attributes+ -- https://opentelemetry.io/docs/specs/otel/resource/sdk/+ Hspec.describe "(.=?)" $ do+ Hspec.it "includes attribute when Just" $ do+ let r = R.mkResource [ExampleName R..=? Just ("svc" :: T.Text)]+ mat = R.materializeResources r+ attrs = R.getMaterializedResourcesAttributes mat+ lookupAttribute attrs "example.name" `Hspec.shouldBe` Just (toAttribute @T.Text "svc")++ Hspec.it "omits attribute when Nothing" $ do+ let r = R.mkResource [ExampleName R..=? (Nothing :: Maybe T.Text)]+ mat = R.materializeResources r+ attrs = R.getMaterializedResourcesAttributes mat+ lookupAttribute attrs "example.name" `Hspec.shouldBe` Nothing+++mkExampleResource :: T.Text -> Int -> R.Resource mkExampleResource name count = R.mkResource [ExampleName R..= name, ExampleCount R..= count]
test/OpenTelemetry/SemanticsConfigSpec.hs view
@@ -11,6 +11,8 @@ spec :: Spec spec = do+ -- Semantic conventions §Stable vs Experimental: OTEL_SEMCONV_STABILITY_OPT_IN+ -- https://opentelemetry.io/docs/specs/semconv/general/stable-vs-experimental/ describe "SemanticsConfig" $ do describe "HttpOption" $ do it "defaults to 'Old' when env var has no value" $ do@@ -31,14 +33,99 @@ , ("http,http/dup", StableAndOld) , ("http,something-random,http/dup", StableAndOld) ]- context "memoization" $ do- it "works" $ do++ describe "databaseOption" $ do+ it "defaults to 'Old' when env var has no value" $ do+ unsetEnv envVarName+ opts <- getSemanticsOptions'+ databaseOption opts `shouldBe` Old++ it "defaults to 'Old' when only http is set" $ do setEnv envVarName "http"- semanticsOptions <- getSemanticsOptions- httpOption semanticsOptions `shouldBe` Stable- it ("does not change when " ++ envVarName ++ " changes") $ do+ opts <- getSemanticsOptions'+ databaseOption opts `shouldBe` Old++ mapM_+ ( \(envVarVal, expectedDb) ->+ it ("returns " ++ show expectedDb ++ " for database when env var is " ++ show envVarVal) $ do+ setEnv envVarName envVarVal+ opts <- getSemanticsOptions'+ databaseOption opts `shouldBe` expectedDb+ )+ [ ("database", Stable)+ , ("database/dup", StableAndOld)+ , ("http,database", Stable)+ , ("http/dup,database/dup", StableAndOld)+ , ("database,http", Stable)+ ]++ describe "independent http and database options" $ do+ it "http=Stable, database=Old when only http set" $ do setEnv envVarName "http"- semanticsOptions <- getSemanticsOptions+ opts <- getSemanticsOptions'+ httpOption opts `shouldBe` Stable+ databaseOption opts `shouldBe` Old++ it "http=Old, database=Stable when only database set" $ do+ setEnv envVarName "database"+ opts <- getSemanticsOptions'+ httpOption opts `shouldBe` Old+ databaseOption opts `shouldBe` Stable++ it "both Stable when both set" $ do+ setEnv envVarName "http,database"+ opts <- getSemanticsOptions'+ httpOption opts `shouldBe` Stable+ databaseOption opts `shouldBe` Stable++ it "http=StableAndOld, database=Stable for mixed" $ do+ setEnv envVarName "http/dup,database"+ opts <- getSemanticsOptions'+ httpOption opts `shouldBe` StableAndOld+ databaseOption opts `shouldBe` Stable++ describe "lookupStability (generalized)" $ do+ it "returns Old for unknown keys when env var is unset" $ do+ unsetEnv envVarName+ opts <- getSemanticsOptions'+ lookupStability "messaging" opts `shouldBe` Old+ lookupStability "rpc" opts `shouldBe` Old++ it "returns Stable for a custom key when present" $ do+ setEnv envVarName "messaging"+ opts <- getSemanticsOptions'+ lookupStability "messaging" opts `shouldBe` Stable+ lookupStability "http" opts `shouldBe` Old++ it "returns StableAndOld for custom/dup key" $ do+ setEnv envVarName "messaging/dup"+ opts <- getSemanticsOptions'+ lookupStability "messaging" opts `shouldBe` StableAndOld++ it "handles multiple custom keys" $ do+ setEnv envVarName "http,messaging/dup,database"+ opts <- getSemanticsOptions'+ lookupStability "http" opts `shouldBe` Stable+ lookupStability "messaging" opts `shouldBe` StableAndOld+ lookupStability "database" opts `shouldBe` Stable+ lookupStability "rpc" opts `shouldBe` Old++ it "trims whitespace around custom keys" $ do+ setEnv envVarName " messaging , http/dup "+ opts <- getSemanticsOptions'+ lookupStability "messaging" opts `shouldBe` Stable+ lookupStability "http" opts `shouldBe` StableAndOld++ -- Implementation-specific: memoized semantics options snapshot+ -- https://opentelemetry.io/docs/specs/semconv/general/stable-vs-experimental/+ context "memoization" $ do+ it "returns a consistent value across calls" $ do+ opts1 <- getSemanticsOptions+ opts2 <- getSemanticsOptions+ httpOption opts1 `shouldBe` httpOption opts2+ it ("does not change when " ++ envVarName ++ " changes") $ do+ baseline <- getSemanticsOptions+ let baselineHttp = httpOption baseline setEnv envVarName "http/dup"- semanticsOptions <- getSemanticsOptions- httpOption semanticsOptions `shouldBe` Stable -- and not StableAndOld because of memoization+ opts <- getSemanticsOptions+ httpOption opts `shouldBe` baselineHttp
+ test/OpenTelemetry/Trace/ExceptionHandlerSpec.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module OpenTelemetry.Trace.ExceptionHandlerSpec where++import Control.Exception (ErrorCall (..), Exception (..), IOException, SomeException, toException)+import qualified Data.HashMap.Strict as H+import Data.IORef (readIORef)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Typeable (Typeable)+import qualified Data.Vector as V+import OpenTelemetry.Attributes (fromAttribute, lookupAttribute)+import OpenTelemetry.Context (empty)+import OpenTelemetry.Processor.Span (FlushResult (..), ShutdownResult (..), SpanProcessor (..))+import OpenTelemetry.Trace.Core (+ Event (..),+ ImmutableSpan (..),+ SpanHot (..),+ TracerOptions (..),+ TracerProviderOptions (..),+ createSpan,+ createTracerProvider,+ defaultSpanArguments,+ emptyTracerProviderOptions,+ instrumentationLibrary,+ makeTracer,+ recordException,+ tracerOptions,+ unsafeReadSpan,+ )+import OpenTelemetry.Trace.ExceptionHandler+import OpenTelemetry.Util (appendOnlyBoundedCollectionValues)+import System.Exit (ExitCode (..))+import Test.Hspec (Spec, describe, expectationFailure, it, shouldBe, shouldNotBe)+++spec :: Spec+spec = describe "ExceptionHandler" $ do+ -- Implementation-specific: classify exceptions before Record Exception+ -- https://opentelemetry.io/docs/specs/otel/trace/api/#record-exception+ describe "ignoreExceptionType" $ do+ it "matches ExitSuccess as IgnoredException" $ do+ let r = ignoreExceptionType @ExitCode (toException ExitSuccess)+ fmap exceptionClassification r `shouldBe` Just IgnoredException+ fmap exceptionAdditionalAttributes r `shouldBe` Just H.empty++ it "matches ExitFailure as IgnoredException" $ do+ let r = ignoreExceptionType @ExitCode (toException (ExitFailure 1))+ fmap exceptionClassification r `shouldBe` Just IgnoredException++ it "does not match ErrorCall" $ do+ case ignoreExceptionType @ExitCode (toException (ErrorCall "boom")) of+ Nothing -> pure ()+ Just _ -> expectationFailure "expected Nothing"++ describe "ignoreExceptionMatching" $ do+ -- Implementation-specific: predicate-based exception filtering+ -- https://opentelemetry.io/docs/specs/otel/trace/api/#record-exception+ it "matches only when predicate holds" $ do+ let h = ignoreExceptionMatching @ExitCode (== ExitSuccess)+ fmap exceptionClassification (h (toException ExitSuccess)) `shouldBe` Just IgnoredException+ case h (toException (ExitFailure 1)) of+ Nothing -> pure ()+ Just _ -> expectationFailure "expected Nothing"++ describe "recordExceptionType" $ do+ -- Implementation-specific: type-directed Record Exception classification+ -- https://opentelemetry.io/docs/specs/otel/trace/api/#record-exception+ it "matches IOException as RecordedException" $ do+ let ioEx :: SomeException+ ioEx = toException (userError "io")+ r = recordExceptionType @IOException ioEx+ fmap exceptionClassification r `shouldBe` Just RecordedException++ it "does not match ErrorCall" $ do+ case recordExceptionType @IOException (toException (ErrorCall "e")) of+ Nothing -> pure ()+ Just _ -> expectationFailure "expected Nothing"++ describe "classifyException" $ do+ -- Implementation-specific: user-defined exception classification+ -- https://opentelemetry.io/docs/specs/otel/trace/api/#record-exception+ it "dispatches on the lifted exception value" $ do+ let h =+ classifyException @ExitCode $ \e -> case e of+ ExitSuccess -> ExceptionResponse IgnoredException H.empty+ ExitFailure _ -> ExceptionResponse RecordedException H.empty+ fmap exceptionClassification (h (toException ExitSuccess)) `shouldBe` Just IgnoredException+ fmap exceptionClassification (h (toException (ExitFailure 1))) `shouldBe` Just RecordedException++ describe "exitSuccessHandler" $ do+ -- Implementation-specific: common Haskell process exit handling+ -- https://opentelemetry.io/docs/specs/otel/trace/api/#record-exception+ it "ignores ExitSuccess only" $ do+ fmap exceptionClassification (exitSuccessHandler (toException ExitSuccess))+ `shouldBe` Just IgnoredException+ case exitSuccessHandler (toException (ExitFailure 1)) of+ Nothing -> pure ()+ Just _ -> expectationFailure "expected Nothing"++ describe "defaultExceptionResponse" $ do+ -- Implementation-specific: default when no handler matches+ -- https://opentelemetry.io/docs/specs/otel/trace/api/#record-exception+ it "is ErrorException with no extra attributes" $ do+ exceptionClassification defaultExceptionResponse `shouldBe` ErrorException+ exceptionAdditionalAttributes defaultExceptionResponse `shouldBe` H.empty++ describe "resolveException" $ do+ -- Implementation-specific: tracer vs provider handler precedence+ -- https://opentelemetry.io/docs/specs/otel/trace/api/#record-exception+ it "uses tracer handlers before provider handlers" $ do+ let ioEx = toException (userError "probe") :: SomeException+ tp <-+ createTracerProvider [] $+ emptyTracerProviderOptions+ { tracerProviderOptionsExceptionHandlers = [ignoreExceptionType @IOException]+ }+ let tracer =+ makeTracer tp (instrumentationLibrary "test" "1") $+ tracerOptions {tracerExceptionHandlerOptions = [recordExceptionType @IOException]}+ exceptionClassification (resolveException tracer ioEx) `shouldBe` RecordedException++ it "falls through to provider when tracer handlers do not match" $ do+ let ioEx = toException (userError "probe") :: SomeException+ tp <-+ createTracerProvider [] $+ emptyTracerProviderOptions+ { tracerProviderOptionsExceptionHandlers = [ignoreExceptionType @IOException]+ }+ let tracer = makeTracer tp (instrumentationLibrary "test" "1") tracerOptions+ exceptionClassification (resolveException tracer ioEx) `shouldBe` IgnoredException++ it "uses default when no handler matches" $ do+ let ex = toException (ErrorCall "nope") :: SomeException+ tp <- createTracerProvider [] emptyTracerProviderOptions+ let tracer = makeTracer tp (instrumentationLibrary "test" "1") tracerOptions+ let got = resolveException tracer ex+ exceptionClassification got `shouldBe` exceptionClassification defaultExceptionResponse+ exceptionAdditionalAttributes got `shouldBe` exceptionAdditionalAttributes defaultExceptionResponse++ -- Trace API §Record Exception: record an exception on a span+ -- https://opentelemetry.io/docs/specs/otel/trace/api/#record-exception+ describe "recordException" $ do+ it "recordException uses displayException for exception.message" $ do+ -- OTel Semconv: exception.message SHOULD use displayException for human-readable output+ -- https://opentelemetry.io/docs/specs/semconv/exceptions/exceptions-spans/+ let ex = DisplayDiffersFromShow+ tp <- createTracerProvider [dummySpanProcessor] emptyTracerProviderOptions+ let tracer = makeTracer tp (instrumentationLibrary "test" "1") tracerOptions+ s <- createSpan tracer empty "span" defaultSpanArguments+ recordException s H.empty Nothing ex+ imm <- unsafeReadSpan s+ hot <- readIORef (spanHot imm)+ let evts = appendOnlyBoundedCollectionValues (hotEvents hot)+ V.length evts `shouldBe` 1+ let evt = V.head evts+ eventName evt `shouldBe` "exception"+ (lookupAttribute (eventAttributes evt) "exception.message" >>= fromAttribute @Text)+ `shouldBe` Just (T.pack (displayException ex))+ (lookupAttribute (eventAttributes evt) "exception.message" >>= fromAttribute @Text)+ `shouldNotBe` Just (T.pack (show ex))+++data DisplayDiffersFromShow = DisplayDiffersFromShow+ deriving (Typeable)+++instance Show DisplayDiffersFromShow where+ show _ = "ShowForm"+++instance Exception DisplayDiffersFromShow where+ displayException _ = "DisplayForm"+++dummySpanProcessor :: SpanProcessor+dummySpanProcessor =+ SpanProcessor+ { spanProcessorOnStart = \_ _ -> pure ()+ , spanProcessorOnEnd = \_ -> pure ()+ , spanProcessorShutdown = pure ShutdownSuccess+ , spanProcessorForceFlush = pure FlushSuccess+ }
+ test/OpenTelemetry/Trace/IdCodecSpec.hs view
@@ -0,0 +1,278 @@+{-# LANGUAGE OverloadedStrings #-}++module OpenTelemetry.Trace.IdCodecSpec (spec) where++import Data.Bits (shiftR, (.&.))+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as C8+import Data.Char (toLower)+import Data.Word (Word8)+import qualified Hedgehog as H+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import OpenTelemetry.Internal.Trace.Id+import Test.Hspec+import Test.Hspec.Hedgehog (hedgehog)+++genHexChar :: H.Gen Char+genHexChar = Gen.element $ ['0' .. '9'] ++ ['a' .. 'f']+++genHexCharMixed :: H.Gen Char+genHexCharMixed = Gen.element $ ['0' .. '9'] ++ ['a' .. 'f'] ++ ['A' .. 'F']+++genHexBS :: Int -> H.Gen BS.ByteString+genHexBS n = C8.pack <$> Gen.list (Range.singleton n) genHexChar+++genHexBSMixed :: Int -> H.Gen BS.ByteString+genHexBSMixed n = C8.pack <$> Gen.list (Range.singleton n) genHexCharMixed+++genNonZeroHexBS :: Int -> H.Gen BS.ByteString+genNonZeroHexBS n = Gen.filter (not . BS.all (== 0x30)) (genHexBS n)+++genTraceId :: H.Gen TraceId+genTraceId = do+ hex <- genNonZeroHexBS 32+ case baseEncodedToTraceId Base16 hex of+ Right tid -> pure tid+ Left _ -> genTraceId+++genSpanId :: H.Gen SpanId+genSpanId = do+ hex <- genNonZeroHexBS 16+ case baseEncodedToSpanId Base16 hex of+ Right sid -> pure sid+ Left _ -> genSpanId+++genFlags :: H.Gen Word8+genFlags = Gen.word8 Range.constantBounded+++nibToHex :: Int -> Char+nibToHex n+ | n < 10 = toEnum (n + fromEnum '0')+ | otherwise = toEnum (n - 10 + fromEnum 'a')+++isLeft :: Either a b -> Bool+isLeft (Left _) = True+isLeft _ = False+++spec :: Spec+spec = do+ -- Trace API §SpanContext: TraceId (16-byte id, lowercase hex)+ -- https://opentelemetry.io/docs/specs/otel/trace/api/#spancontext+ describe "TraceId hex round-trip" $ do+ it "encode . decode = identity for random lowercase hex" $ hedgehog $ do+ hex <- H.forAll $ genHexBS 32+ let Right tid = baseEncodedToTraceId Base16 hex+ traceIdBaseEncodedByteString Base16 tid H.=== hex++ it "normalizes uppercase hex to lowercase" $ hedgehog $ do+ hex <- H.forAll $ genHexBSMixed 32+ let Right tid = baseEncodedToTraceId Base16 hex+ rehex = traceIdBaseEncodedByteString Base16 tid+ rehex H.=== C8.map toLower hex++ it "rejects wrong length" $ do+ baseEncodedToTraceId Base16 "00" `shouldSatisfy` isLeft+ baseEncodedToTraceId Base16 (C8.replicate 31 'a') `shouldSatisfy` isLeft+ baseEncodedToTraceId Base16 (C8.replicate 33 'a') `shouldSatisfy` isLeft++ it "rejects invalid hex characters" $ do+ baseEncodedToTraceId Base16 "zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz" `shouldSatisfy` isLeft+ baseEncodedToTraceId Base16 "0000000000000000000000000000000g" `shouldSatisfy` isLeft+ baseEncodedToTraceId Base16 "000000000000000000000000000000 0" `shouldSatisfy` isLeft++ it "correctly decodes known value" $ do+ let Right tid = baseEncodedToTraceId Base16 "4bf92f3577b34da6a3ce929d0e0e4736"+ bs = traceIdBytes tid+ BS.length bs `shouldBe` 16+ BS.index bs 0 `shouldBe` 0x4b+ BS.index bs 1 `shouldBe` 0xf9+ BS.index bs 15 `shouldBe` 0x36++ -- Trace API §SpanContext: SpanId (8-byte id, lowercase hex)+ -- https://opentelemetry.io/docs/specs/otel/trace/api/#spancontext+ describe "SpanId hex round-trip" $ do+ it "encode . decode = identity" $ hedgehog $ do+ hex <- H.forAll $ genHexBS 16+ let Right sid = baseEncodedToSpanId Base16 hex+ spanIdBaseEncodedByteString Base16 sid H.=== hex++ it "rejects wrong length" $ do+ baseEncodedToSpanId Base16 "00" `shouldSatisfy` isLeft+ baseEncodedToSpanId Base16 (C8.replicate 15 'a') `shouldSatisfy` isLeft++ it "correctly decodes known value" $ do+ let Right sid = baseEncodedToSpanId Base16 "00f067aa0ba902b7"+ bs = spanIdBytes sid+ BS.length bs `shouldBe` 8+ BS.index bs 0 `shouldBe` 0x00+ BS.index bs 1 `shouldBe` 0xf0+ BS.index bs 7 `shouldBe` 0xb7++ -- Trace API §SpanContext: TraceId binary form (16 bytes)+ -- https://opentelemetry.io/docs/specs/otel/trace/api/#spancontext+ describe "TraceId bytes round-trip" $ do+ it "bytesToTraceId (traceIdBytes tid) = Right tid" $ hedgehog $ do+ tid <- H.forAll genTraceId+ bytesToTraceId (traceIdBytes tid) H.=== Right tid++ it "rejects wrong length bytes" $ do+ bytesToTraceId (BS.replicate 15 0) `shouldSatisfy` isLeft+ bytesToTraceId (BS.replicate 17 0) `shouldSatisfy` isLeft++ -- Trace API §SpanContext: SpanId binary form (8 bytes)+ -- https://opentelemetry.io/docs/specs/otel/trace/api/#spancontext+ describe "SpanId bytes round-trip" $ do+ it "bytesToSpanId (spanIdBytes sid) = Right sid" $ hedgehog $ do+ sid <- H.forAll genSpanId+ bytesToSpanId (spanIdBytes sid) H.=== Right sid++ -- Trace API §SpanContext: invalid zero TraceId / SpanId (OTel + W3C traceparent rules)+ -- https://opentelemetry.io/docs/specs/otel/trace/api/#spancontext+ describe "isEmptyTraceId / isEmptySpanId" $ do+ it "nilTraceId is empty" $+ isEmptyTraceId nilTraceId `shouldBe` True++ it "nilSpanId is empty" $+ isEmptySpanId nilSpanId `shouldBe` True++ it "non-zero TraceId is not empty" $ hedgehog $ do+ tid <- H.forAll genTraceId+ H.assert $ not (isEmptyTraceId tid)++ it "non-zero SpanId is not empty" $ hedgehog $ do+ sid <- H.forAll genSpanId+ H.assert $ not (isEmptySpanId sid)++ -- Propagators API §W3C Trace Context: traceparent header (version 00)+ -- https://opentelemetry.io/docs/specs/otel/context/api-propagators/+ describe "decodeTraceparent" $ do+ it "parses valid v00 traceparent" $ do+ let Just (ver, tid, sid, fl) =+ decodeTraceparent "00-4bf92f3577b34da6a3ce929d0e0e4736-00f067aa0ba902b7-01"+ ver `shouldBe` 0+ fl `shouldBe` 1+ traceIdBaseEncodedByteString Base16 tid `shouldBe` "4bf92f3577b34da6a3ce929d0e0e4736"+ spanIdBaseEncodedByteString Base16 sid `shouldBe` "00f067aa0ba902b7"++ it "parses flags=00" $ do+ let Just (_, _, _, fl) =+ decodeTraceparent "00-4bf92f3577b34da6a3ce929d0e0e4736-00f067aa0ba902b7-00"+ fl `shouldBe` 0++ it "round-trips through encode/decode" $ hedgehog $ do+ tid <- H.forAll genTraceId+ sid <- H.forAll genSpanId+ fl <- H.forAll genFlags+ let encoded = encodeTraceparent 0 tid sid fl+ Just (ver', tid', sid', fl') = decodeTraceparent encoded+ ver' H.=== 0+ tid' H.=== tid+ sid' H.=== sid+ fl' H.=== fl++ it "encodeTraceparent produces correct format" $ do+ let Right tid = baseEncodedToTraceId Base16 "4bf92f3577b34da6a3ce929d0e0e4736"+ Right sid = baseEncodedToSpanId Base16 "00f067aa0ba902b7"+ encodeTraceparent 0 tid sid 1 `shouldBe` "00-4bf92f3577b34da6a3ce929d0e0e4736-00f067aa0ba902b7-01"++ it "encodeTraceparent has length 55" $ hedgehog $ do+ tid <- H.forAll genTraceId+ sid <- H.forAll genSpanId+ BS.length (encodeTraceparent 0 tid sid 1) H.=== 55++ it "encodeTraceparent has dashes at correct positions" $ hedgehog $ do+ tid <- H.forAll genTraceId+ sid <- H.forAll genSpanId+ let bs = encodeTraceparent 0 tid sid 1+ BS.index bs 2 H.=== 0x2d+ BS.index bs 35 H.=== 0x2d+ BS.index bs 52 H.=== 0x2d++ it "rejects too-short input" $+ decodeTraceparent "00-4bf92f3577b34da6a3ce929d0e0e4736-00f067aa0ba902b7-0" `shouldBe` Nothing++ it "rejects too-long input for v00" $+ decodeTraceparent "00-4bf92f3577b34da6a3ce929d0e0e4736-00f067aa0ba902b7-01-extra" `shouldBe` Nothing++ it "rejects missing dashes" $ do+ decodeTraceparent "00X4bf92f3577b34da6a3ce929d0e0e4736-00f067aa0ba902b7-01" `shouldBe` Nothing+ decodeTraceparent "00-4bf92f3577b34da6a3ce929d0e0e4736X00f067aa0ba902b7-01" `shouldBe` Nothing+ decodeTraceparent "00-4bf92f3577b34da6a3ce929d0e0e4736-00f067aa0ba902b7X01" `shouldBe` Nothing++ it "rejects all-zero trace ID" $+ decodeTraceparent "00-00000000000000000000000000000000-00f067aa0ba902b7-01" `shouldBe` Nothing++ it "rejects all-zero span ID" $+ decodeTraceparent "00-4bf92f3577b34da6a3ce929d0e0e4736-0000000000000000-01" `shouldBe` Nothing++ it "rejects invalid hex in trace ID" $+ decodeTraceparent "00-4bf92f3577b34da6a3ce929d0e0e473g-00f067aa0ba902b7-01" `shouldBe` Nothing++ it "rejects invalid hex in span ID" $+ decodeTraceparent "00-4bf92f3577b34da6a3ce929d0e0e4736-00f067aa0ba902bx-01" `shouldBe` Nothing++ it "rejects invalid hex in version" $+ decodeTraceparent "0g-4bf92f3577b34da6a3ce929d0e0e4736-00f067aa0ba902b7-01" `shouldBe` Nothing++ it "rejects invalid hex in flags" $+ decodeTraceparent "00-4bf92f3577b34da6a3ce929d0e0e4736-00f067aa0ba902b7-0z" `shouldBe` Nothing++ it "rejects uppercase hex (W3C TC2 HEXDIGLC)" $ do+ decodeTraceparent "00-4BF92F3577B34DA6A3CE929D0E0E4736-00F067AA0BA902B7-01"+ `shouldBe` Nothing++ it "rejects version ff (W3C TC2)" $ do+ decodeTraceparent "ff-4bf92f3577b34da6a3ce929d0e0e4736-00f067aa0ba902b7-01"+ `shouldBe` Nothing++ -- Implementation-specific: SIMD-accelerated hex decode validation+ -- https://opentelemetry.io/docs/specs/otel/trace/api/#spancontext+ describe "SIMD hex decode edge cases" $ do+ it "decodes every possible byte value correctly" $ do+ mapM_+ ( \i -> do+ let hi = i `shiftR` 4+ lo = i .&. 0x0f+ hexStr =+ C8.pack [nibToHex hi, nibToHex lo]+ <> C8.replicate 14 '0'+ case baseEncodedToSpanId Base16 hexStr of+ Right sid -> BS.index (spanIdBytes sid) 0 `shouldBe` fromIntegral i+ Left err -> expectationFailure $ "Failed for " ++ show i ++ ": " ++ err+ )+ [0 .. 255 :: Int]++ it "rejects each non-hex ASCII char at every position" $ do+ let badChars = ['\0', ' ', '/', ':', '@', 'G', '`', 'g', '\127']+ mapM_+ ( \bad ->+ mapM_+ ( \pos -> do+ let base = replicate 16 '0'+ withBad = take pos base ++ [bad] ++ drop (pos + 1) base+ baseEncodedToSpanId Base16 (C8.pack withBad) `shouldSatisfy` isLeft+ )+ [0 .. 15 :: Int]+ )+ badChars++ it "rejects chars just outside hex ranges" $ do+ let justOutside = ['/', ':', '@', 'G', '`', 'g']+ mapM_+ ( \c -> do+ let hex = c : replicate 15 '0'+ baseEncodedToSpanId Base16 (C8.pack hex) `shouldSatisfy` isLeft+ )+ justOutside
+ test/OpenTelemetry/Trace/MonadSpec.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module OpenTelemetry.Trace.MonadSpec where++import Control.Monad.IO.Class (MonadIO)+import Control.Monad.IO.Unlift (MonadUnliftIO)+import Control.Monad.Trans.Reader (ReaderT (..), ask, runReaderT)+import qualified OpenTelemetry.Attributes as A+import OpenTelemetry.Processor.Span (FlushResult (..), ShutdownResult (..), SpanProcessor (..))+import OpenTelemetry.Trace.Core+import qualified OpenTelemetry.Trace.Monad as TM+import Test.Hspec+++newtype TestM a = TestM {runTestM :: ReaderT Tracer IO a}+ deriving newtype (Functor, Applicative, Monad, MonadIO, MonadUnliftIO)+++instance TM.MonadTracer TestM where+ getTracer = TestM ask+++spec :: Spec+spec = describe "Trace.Monad" $ do+ -- Trace API §Creating a Span: span lifecycle (start/end) via convenience API+ -- https://opentelemetry.io/docs/specs/otel/trace/api/#span-operations+ it "inSpan creates and ends a span without throwing" $ do+ t <- mkTracer+ runReaderT (runTestM $ TM.inSpan "monad-span" defaultSpanArguments $ pure ()) t++ -- Trace API §IsRecording: recording state visible to instrumentation+ -- https://opentelemetry.io/docs/specs/otel/trace/api/#isrecording+ it "inSpan' provides a recording span to the callback" $ do+ t <- mkTracer+ recording <-+ runReaderT+ ( runTestM $+ TM.inSpan' "monad-span-prime" defaultSpanArguments isRecording+ )+ t+ recording `shouldBe` True++ -- Trace API §Tracer: obtaining the active tracer (library pattern)+ -- https://opentelemetry.io/docs/specs/otel/trace/api/#tracer+ it "getTracer returns the tracer from the Reader environment" $ do+ t <- mkTracer+ tr <- runReaderT (runTestM TM.getTracer) t+ tracerName tr `shouldBe` tracerName t+++mkTracer :: IO Tracer+mkTracer = do+ let dummyProcessor =+ SpanProcessor+ { spanProcessorOnStart = \_ _ -> pure ()+ , spanProcessorOnEnd = \_ -> pure ()+ , spanProcessorShutdown = pure ShutdownSuccess+ , spanProcessorForceFlush = pure FlushSuccess+ }+ tp <- createTracerProvider [dummyProcessor] emptyTracerProviderOptions+ let instrLib = InstrumentationLibrary "test" "1.0.0" "" A.emptyAttributes+ pure $ makeTracer tp instrLib tracerOptions
test/OpenTelemetry/Trace/SamplerSpec.hs view
@@ -1,12 +1,29 @@ module OpenTelemetry.Trace.SamplerSpec where import Control.Monad+import qualified Data.ByteString.Char8 as BS+import qualified Data.Text as T+import Data.Word (Word64) import qualified OpenTelemetry.Context as Context import OpenTelemetry.Trace.Core import OpenTelemetry.Trace.Id-import OpenTelemetry.Trace.Sampler+import OpenTelemetry.Trace.Sampler (+ ParentBasedOptions (..),+ Sampler,+ SamplingDecision (..),+ SamplingResult (..),+ alwaysOff,+ alwaysOn,+ alwaysRecord,+ getDescription,+ parentBased,+ parentBasedOptions,+ shouldSample,+ traceIdRatioBased,+ ) import qualified OpenTelemetry.Trace.TraceState as TraceState import Test.Hspec+import Text.Printf (printf) builtInNonCompositeSamplers :: [Sampler]@@ -17,11 +34,14 @@ ] --- TODO, these would largely be good candidates for quickcheck spec :: Spec spec = describe "Sampler" $ do+ -- Trace SDK §Sampling+ -- https://opentelemetry.io/docs/specs/otel/trace/sdk/#sampling describe "built-in non-composite samplers" $ do forM_ builtInNonCompositeSamplers $ \sampler -> do+ -- Trace SDK §Sampling API: SamplingResult TraceState matches parent SpanContext+ -- https://opentelemetry.io/docs/specs/otel/trace/sdk/#sampling specify (show (getDescription sampler) ++ " returns parent tracestate") $ do let (Right aTraceId) = baseEncodedToTraceId Base16 "00000000000000000000000000000001" (Right parentSpanId) = baseEncodedToSpanId Base16 "000000000000000a"@@ -35,10 +55,12 @@ } traceParent = wrapSpanContext remoteSpan parentContext = Context.insertSpan traceParent Context.empty- (_, _, ts) <- shouldSample sampler parentContext aTraceId "test" defaultSpanArguments+ SamplingDecision _ _ ts <- shouldSample sampler parentContext aTraceId "test" defaultSpanArguments "test-scope" ts `shouldBe` traceState remoteSpan describe "alwaysOff" $ do+ -- Trace SDK §Built-in samplers: AlwaysOffSampler → Drop decision+ -- https://opentelemetry.io/docs/specs/otel/trace/sdk/#built-in-samplers it "returns Drop" $ do let (Right aTraceId) = baseEncodedToTraceId Base16 "00000000000000000000000000000001" (Right parentSpanId) = baseEncodedToSpanId Base16 "000000000000000a"@@ -52,10 +74,54 @@ } traceParent = wrapSpanContext remoteSpan parentContext = Context.insertSpan traceParent Context.empty- (res, _, _) <- shouldSample alwaysOff parentContext aTraceId "test" defaultSpanArguments+ SamplingDecision res _ _ <- shouldSample alwaysOff parentContext aTraceId "test" defaultSpanArguments "test-scope" res `shouldBe` Drop + describe "alwaysRecord" $ do+ -- Trace SDK §Recording-only samplers: upgrade sampling decision to record-only+ -- https://opentelemetry.io/docs/specs/otel/trace/sdk/#recording-only-samplers+ it "upgrades alwaysOff from Drop to RecordOnly" $ do+ let (Right aTraceId) = baseEncodedToTraceId Base16 "00000000000000000000000000000001"+ (Right parentSpanId) = baseEncodedToSpanId Base16 "000000000000000a"+ remoteSpan =+ SpanContext+ { traceFlags = defaultTraceFlags+ , isRemote = False+ , traceState = TraceState.empty+ , spanId = parentSpanId+ , traceId = aTraceId+ }+ traceParent = wrapSpanContext remoteSpan+ parentContext = Context.insertSpan traceParent Context.empty+ sampler = alwaysRecord alwaysOff+ SamplingDecision res _ _ <- shouldSample sampler parentContext aTraceId "test" defaultSpanArguments "test-scope"+ res `shouldBe` RecordOnly+ -- Trace SDK §Recording-only samplers: preserve RecordAndSample when already sampled+ -- https://opentelemetry.io/docs/specs/otel/trace/sdk/#recording-only-samplers+ it "leaves alwaysOn as RecordAndSample" $ do+ let (Right aTraceId) = baseEncodedToTraceId Base16 "00000000000000000000000000000001"+ (Right parentSpanId) = baseEncodedToSpanId Base16 "000000000000000a"+ remoteSpan =+ SpanContext+ { traceFlags = defaultTraceFlags+ , isRemote = False+ , traceState = TraceState.empty+ , spanId = parentSpanId+ , traceId = aTraceId+ }+ traceParent = wrapSpanContext remoteSpan+ parentContext = Context.insertSpan traceParent Context.empty+ sampler = alwaysRecord alwaysOn+ SamplingDecision res _ _ <- shouldSample sampler parentContext aTraceId "test" defaultSpanArguments "test-scope"+ res `shouldBe` RecordAndSample+ -- Implementation-specific: composite sampler description formatting+ -- https://opentelemetry.io/docs/specs/otel/trace/sdk/#sampling+ it "wraps the inner sampler description" $ do+ getDescription (alwaysRecord alwaysOff) `shouldBe` "AlwaysRecord{AlwaysOffSampler}"+ describe "alwaysOn" $ do+ -- Trace SDK §Built-in samplers: AlwaysOnSampler → RecordAndSample+ -- https://opentelemetry.io/docs/specs/otel/trace/sdk/#built-in-samplers it "returns RecordAndSample" $ do let (Right aTraceId) = baseEncodedToTraceId Base16 "00000000000000000000000000000001" (Right parentSpanId) = baseEncodedToSpanId Base16 "000000000000000a"@@ -69,13 +135,15 @@ } traceParent = wrapSpanContext remoteSpan parentContext = Context.insertSpan traceParent Context.empty- (res, _, _) <- shouldSample alwaysOn parentContext aTraceId "test" defaultSpanArguments+ SamplingDecision res _ _ <- shouldSample alwaysOn parentContext aTraceId "test" defaultSpanArguments "test-scope" res `shouldBe` RecordAndSample describe "traceIdRatioBased" $ do+ -- Trace SDK §TraceIdRatioBased sampler: deterministic sampling by TraceId+ -- https://opentelemetry.io/docs/specs/otel/trace/sdk/#traceidratiobased it "drops spans that are outside of the sample ratio" $ do let sampler = traceIdRatioBased 0.5- (Right aTraceId) = baseEncodedToTraceId Base16 "ffffffffffffffff0000000000000000"+ (Right aTraceId) = baseEncodedToTraceId Base16 "0000000000000000ffffffffffffffff" (Right parentSpanId) = baseEncodedToSpanId Base16 "0000000000000001" remoteSpan = SpanContext@@ -87,8 +155,10 @@ } traceParent = wrapSpanContext remoteSpan parentContext = Context.insertSpan traceParent Context.empty- (res, _, _) <- shouldSample sampler parentContext aTraceId "test" defaultSpanArguments+ SamplingDecision res _ _ <- shouldSample sampler parentContext aTraceId "test" defaultSpanArguments "test-scope" res `shouldBe` Drop+ -- Trace SDK §TraceIdRatioBased sampler: spans inside ratio are RecordAndSample+ -- https://opentelemetry.io/docs/specs/otel/trace/sdk/#traceidratiobased it "samples spans that are within the sample ratio" $ do let sampler = traceIdRatioBased 0.5 (Right aTraceId) = baseEncodedToTraceId Base16 "00000000000000000000000000000000"@@ -103,12 +173,14 @@ } traceParent = wrapSpanContext remoteSpan parentContext = Context.insertSpan traceParent Context.empty- (res, _, _) <- shouldSample sampler parentContext aTraceId "test" defaultSpanArguments+ SamplingDecision res _ _ <- shouldSample sampler parentContext aTraceId "test" defaultSpanArguments "test-scope" res `shouldBe` RecordAndSample+ -- Trace SDK §TraceIdRatioBased sampler: monotonicity across ratios+ -- https://opentelemetry.io/docs/specs/otel/trace/sdk/#traceidratiobased it "higher sample ratios sample spans that are also by lower ratios" $ do let conservativeSampler = traceIdRatioBased 0.5 permissiveSampler = traceIdRatioBased 0.75- (Right aTraceId) = baseEncodedToTraceId Base16 "3fffffffffffffff0000000000000000"+ (Right aTraceId) = baseEncodedToTraceId Base16 "00000000000000003fffffffffffffff" (Right parentSpanId) = baseEncodedToSpanId Base16 "0000000000000001" remoteSpan = SpanContext@@ -121,7 +193,288 @@ traceParent = wrapSpanContext remoteSpan parentContext = Context.insertSpan traceParent Context.empty do- (resConservative, _, _) <- shouldSample permissiveSampler parentContext aTraceId "test" defaultSpanArguments- (resPermissive, _, _) <- shouldSample conservativeSampler parentContext aTraceId "test" defaultSpanArguments+ SamplingDecision resConservative _ _ <- shouldSample permissiveSampler parentContext aTraceId "test" defaultSpanArguments "test-scope"+ SamplingDecision resPermissive _ _ <- shouldSample conservativeSampler parentContext aTraceId "test" defaultSpanArguments "test-scope" resConservative `shouldBe` RecordAndSample resPermissive `shouldBe` RecordAndSample++ -- Trace SDK §TraceIdRatioBased sampler: uses TraceId least-significant 8 bytes+ -- https://opentelemetry.io/docs/specs/otel/trace/sdk/#traceidratiobased+ it "sampling depends only on the lower 8 bytes (hi bytes are irrelevant)" $ do+ let sampler = traceIdRatioBased 0.5+ (Right parentSpanId) = baseEncodedToSpanId Base16 "0000000000000001"+ mkCtx tid =+ let sc =+ SpanContext+ { traceFlags = defaultTraceFlags+ , isRemote = False+ , traceState = TraceState.empty+ , spanId = parentSpanId+ , traceId = tid+ }+ in Context.insertSpan (wrapSpanContext sc) Context.empty+ -- Same lo bytes (near zero → should sample), different hi bytes+ (Right tid1) = baseEncodedToTraceId Base16 "00000000000000000000000000000001"+ (Right tid2) = baseEncodedToTraceId Base16 "ffffffffffffffff0000000000000001"+ (Right tid3) = baseEncodedToTraceId Base16 "abcdef01234567890000000000000001"+ SamplingDecision r1 _ _ <- shouldSample sampler (mkCtx tid1) tid1 "test" defaultSpanArguments "test-scope"+ SamplingDecision r2 _ _ <- shouldSample sampler (mkCtx tid2) tid2 "test" defaultSpanArguments "test-scope"+ SamplingDecision r3 _ _ <- shouldSample sampler (mkCtx tid3) tid3 "test" defaultSpanArguments "test-scope"+ r1 `shouldBe` r2+ r2 `shouldBe` r3++ -- Trace SDK §TraceIdRatioBased sampler: different TraceId suffix → different decision+ -- https://opentelemetry.io/docs/specs/otel/trace/sdk/#traceidratiobased+ it "different lo bytes produce different sampling decisions" $ do+ let sampler = traceIdRatioBased 0.5+ (Right parentSpanId) = baseEncodedToSpanId Base16 "0000000000000001"+ mkCtx tid =+ let sc =+ SpanContext+ { traceFlags = defaultTraceFlags+ , isRemote = False+ , traceState = TraceState.empty+ , spanId = parentSpanId+ , traceId = tid+ }+ in Context.insertSpan (wrapSpanContext sc) Context.empty+ -- Same hi bytes, different lo bytes: one near zero (sampled), one near max (dropped)+ (Right tidLow) = baseEncodedToTraceId Base16 "00000000000000000000000000000001"+ (Right tidHigh) = baseEncodedToTraceId Base16 "0000000000000000fffffffffffffffe"+ SamplingDecision rLow _ _ <- shouldSample sampler (mkCtx tidLow) tidLow "test" defaultSpanArguments "test-scope"+ SamplingDecision rHigh _ _ <- shouldSample sampler (mkCtx tidHigh) tidHigh "test" defaultSpanArguments "test-scope"+ rLow `shouldBe` RecordAndSample+ rHigh `shouldBe` Drop++ describe "traceIdRatioBased property tests" $ do+ -- Implementation-specific: statistical check of TraceIdRatioBased distribution+ -- https://opentelemetry.io/docs/specs/otel/trace/sdk/#traceidratiobased+ it "samples approximately the configured ratio over many trials" $ do+ let sampler = traceIdRatioBased 0.5+ trials = 1000+ (Right parentSpanId) = baseEncodedToSpanId Base16 "0000000000000001"+ results <- forM [1 .. trials] $ \i -> do+ let step = (maxBound :: Word64) `div` fromIntegral (trials + 1)+ hi = fromIntegral (i * 7919) :: Word64+ lo = fromIntegral i * step+ (Right tid) =+ baseEncodedToTraceId Base16 $+ BS.pack $+ printf "%016x%016x" hi lo+ remoteSpan =+ SpanContext+ { traceFlags = defaultTraceFlags+ , isRemote = False+ , traceState = TraceState.empty+ , spanId = parentSpanId+ , traceId = tid+ }+ traceParent = wrapSpanContext remoteSpan+ parentContext = Context.insertSpan traceParent Context.empty+ SamplingDecision res _ _ <- shouldSample sampler parentContext tid "test" defaultSpanArguments "test-scope"+ pure (res == RecordAndSample)+ let sampledCount = length (filter id results)+ ratio = fromIntegral sampledCount / fromIntegral trials :: Double+ ratio `shouldSatisfy` (\r -> r > 0.35 && r < 0.65)++ -- Trace SDK §TraceIdRatioBased sampler: ratio 0 → always Drop+ -- https://opentelemetry.io/docs/specs/otel/trace/sdk/#traceidratiobased+ it "traceIdRatioBased 0.0 never samples" $ do+ let sampler = traceIdRatioBased 0.0+ (Right parentSpanId) = baseEncodedToSpanId Base16 "0000000000000001"+ forM_ [1 .. 64 :: Int] $ \i -> do+ let trials = 64+ step = (maxBound :: Word64) `div` fromIntegral (trials + 1)+ hi = fromIntegral (i * 7919) :: Word64+ lo = fromIntegral i * step+ (Right tid) =+ baseEncodedToTraceId Base16 $+ BS.pack $+ printf "%016x%016x" hi lo+ remoteSpan =+ SpanContext+ { traceFlags = defaultTraceFlags+ , isRemote = False+ , traceState = TraceState.empty+ , spanId = parentSpanId+ , traceId = tid+ }+ traceParent = wrapSpanContext remoteSpan+ parentContext = Context.insertSpan traceParent Context.empty+ SamplingDecision res _ _ <- shouldSample sampler parentContext tid "test" defaultSpanArguments "test-scope"+ res `shouldBe` Drop++ -- Trace SDK §TraceIdRatioBased sampler: ratio 1 → always RecordAndSample+ -- https://opentelemetry.io/docs/specs/otel/trace/sdk/#traceidratiobased+ it "traceIdRatioBased 1.0 always samples" $ do+ let sampler = traceIdRatioBased 1.0+ (Right parentSpanId) = baseEncodedToSpanId Base16 "0000000000000001"+ forM_ [1 .. 64 :: Int] $ \i -> do+ let trials = 64+ step = (maxBound :: Word64) `div` fromIntegral (trials + 1)+ hi = fromIntegral (i * 7919) :: Word64+ lo = fromIntegral i * step+ (Right tid) =+ baseEncodedToTraceId Base16 $+ BS.pack $+ printf "%016x%016x" hi lo+ remoteSpan =+ SpanContext+ { traceFlags = defaultTraceFlags+ , isRemote = False+ , traceState = TraceState.empty+ , spanId = parentSpanId+ , traceId = tid+ }+ traceParent = wrapSpanContext remoteSpan+ parentContext = Context.insertSpan traceParent Context.empty+ SamplingDecision res _ _ <- shouldSample sampler parentContext tid "test" defaultSpanArguments "test-scope"+ res `shouldBe` RecordAndSample++ describe "parentBased" $ do+ -- Trace SDK §ParentBased sampler: root span uses root sampler+ -- https://opentelemetry.io/docs/specs/otel/trace/sdk/#parentbased+ it "delegates to rootSampler when no parent span" $ do+ let sampler = parentBased (parentBasedOptions alwaysOff)+ (Right aTraceId) = baseEncodedToTraceId Base16 "00000000000000000000000000000001"+ SamplingDecision res _ _ <- shouldSample sampler Context.empty aTraceId "test" defaultSpanArguments "test-scope"+ res `shouldBe` Drop++ -- Trace SDK §ParentBased sampler: root span with AlwaysOn root sampler+ -- https://opentelemetry.io/docs/specs/otel/trace/sdk/#parentbased+ it "delegates to rootSampler alwaysOn when no parent" $ do+ let sampler = parentBased (parentBasedOptions alwaysOn)+ (Right aTraceId) = baseEncodedToTraceId Base16 "00000000000000000000000000000001"+ SamplingDecision res _ _ <- shouldSample sampler Context.empty aTraceId "test" defaultSpanArguments "test-scope"+ res `shouldBe` RecordAndSample++ -- Trace SDK §ParentBased sampler: remote parent sampled → remoteParentSampled+ -- https://opentelemetry.io/docs/specs/otel/trace/sdk/#parentbased+ it "delegates to remoteParentSampled when remote parent is sampled" $ do+ let sampler = parentBased (parentBasedOptions alwaysOff)+ (Right aTraceId) = baseEncodedToTraceId Base16 "00000000000000000000000000000001"+ (Right parentSpanId) = baseEncodedToSpanId Base16 "000000000000000a"+ remoteSpan =+ SpanContext+ { traceFlags = setSampled defaultTraceFlags+ , isRemote = True+ , traceState = TraceState.empty+ , spanId = parentSpanId+ , traceId = aTraceId+ }+ traceParent = wrapSpanContext remoteSpan+ parentContext = Context.insertSpan traceParent Context.empty+ SamplingDecision res _ _ <- shouldSample sampler parentContext aTraceId "test" defaultSpanArguments "test-scope"+ res `shouldBe` RecordAndSample++ -- Trace SDK §ParentBased sampler: remote parent not sampled → remoteParentNotSampled+ -- https://opentelemetry.io/docs/specs/otel/trace/sdk/#parentbased+ it "delegates to remoteParentNotSampled when remote parent is not sampled" $ do+ let sampler = parentBased (parentBasedOptions alwaysOn)+ (Right aTraceId) = baseEncodedToTraceId Base16 "00000000000000000000000000000001"+ (Right parentSpanId) = baseEncodedToSpanId Base16 "000000000000000a"+ remoteSpan =+ SpanContext+ { traceFlags = defaultTraceFlags+ , isRemote = True+ , traceState = TraceState.empty+ , spanId = parentSpanId+ , traceId = aTraceId+ }+ traceParent = wrapSpanContext remoteSpan+ parentContext = Context.insertSpan traceParent Context.empty+ SamplingDecision res _ _ <- shouldSample sampler parentContext aTraceId "test" defaultSpanArguments "test-scope"+ res `shouldBe` Drop++ -- Trace SDK §ParentBased sampler: local parent sampled → localParentSampled+ -- https://opentelemetry.io/docs/specs/otel/trace/sdk/#parentbased+ it "delegates to localParentSampled when local parent is sampled" $ do+ let sampler = parentBased (parentBasedOptions alwaysOff)+ (Right aTraceId) = baseEncodedToTraceId Base16 "00000000000000000000000000000001"+ (Right parentSpanId) = baseEncodedToSpanId Base16 "000000000000000a"+ localSpan =+ SpanContext+ { traceFlags = setSampled defaultTraceFlags+ , isRemote = False+ , traceState = TraceState.empty+ , spanId = parentSpanId+ , traceId = aTraceId+ }+ traceParent = wrapSpanContext localSpan+ parentContext = Context.insertSpan traceParent Context.empty+ SamplingDecision res _ _ <- shouldSample sampler parentContext aTraceId "test" defaultSpanArguments "test-scope"+ res `shouldBe` RecordAndSample++ -- Trace SDK §ParentBased sampler: local parent not sampled → localParentNotSampled+ -- https://opentelemetry.io/docs/specs/otel/trace/sdk/#parentbased+ it "delegates to localParentNotSampled when local parent is not sampled" $ do+ let sampler = parentBased (parentBasedOptions alwaysOn)+ (Right aTraceId) = baseEncodedToTraceId Base16 "00000000000000000000000000000001"+ (Right parentSpanId) = baseEncodedToSpanId Base16 "000000000000000a"+ localSpan =+ SpanContext+ { traceFlags = defaultTraceFlags+ , isRemote = False+ , traceState = TraceState.empty+ , spanId = parentSpanId+ , traceId = aTraceId+ }+ traceParent = wrapSpanContext localSpan+ parentContext = Context.insertSpan traceParent Context.empty+ SamplingDecision res _ _ <- shouldSample sampler parentContext aTraceId "test" defaultSpanArguments "test-scope"+ res `shouldBe` Drop++ -- Trace SDK §ParentBased sampler: configurable remoteParentNotSampled delegate+ -- https://opentelemetry.io/docs/specs/otel/trace/sdk/#parentbased+ it "custom remoteParentNotSampled overrides default" $ do+ let opts =+ (parentBasedOptions alwaysOff)+ { remoteParentNotSampled = alwaysOn+ }+ sampler = parentBased opts+ (Right aTraceId) = baseEncodedToTraceId Base16 "00000000000000000000000000000001"+ (Right parentSpanId) = baseEncodedToSpanId Base16 "000000000000000a"+ remoteSpan =+ SpanContext+ { traceFlags = defaultTraceFlags+ , isRemote = True+ , traceState = TraceState.empty+ , spanId = parentSpanId+ , traceId = aTraceId+ }+ traceParent = wrapSpanContext remoteSpan+ parentContext = Context.insertSpan traceParent Context.empty+ SamplingDecision res _ _ <- shouldSample sampler parentContext aTraceId "test" defaultSpanArguments "test-scope"+ res `shouldBe` RecordAndSample++ -- Implementation-specific: ParentBased sampler description aggregates child names+ -- https://opentelemetry.io/docs/specs/otel/trace/sdk/#sampling+ it "description includes all child sampler names" $ do+ let desc = getDescription (parentBased (parentBasedOptions alwaysOn))+ desc `shouldSatisfy` ("ParentBased{root=" `T.isInfixOf`)++ describe "traceIdRatioBased description" $ do+ -- Implementation-specific: TraceIdRatioBased getDescription formatting+ -- https://opentelemetry.io/docs/specs/otel/trace/sdk/#sampling+ it "description is TraceIdRatioBased{1.0} when ratio >= 1" $ do+ let desc = getDescription (traceIdRatioBased 1.0)+ desc `shouldSatisfy` T.isPrefixOf "TraceIdRatioBased{"+ -- Implementation-specific: TraceIdRatioBased getDescription formatting+ -- https://opentelemetry.io/docs/specs/otel/trace/sdk/#sampling+ it "description is TraceIdRatioBased{0.0} when ratio <= 0" $ do+ let desc = getDescription (traceIdRatioBased 0.0)+ desc `shouldSatisfy` T.isPrefixOf "TraceIdRatioBased{"+ -- Implementation-specific: TraceIdRatioBased getDescription formatting+ -- https://opentelemetry.io/docs/specs/otel/trace/sdk/#sampling+ it "description for ratio 0.5" $ do+ getDescription (traceIdRatioBased 0.5) `shouldSatisfy` T.isPrefixOf "TraceIdRatioBased{"+ -- Implementation-specific: TraceIdRatioBased clamps invalid ratios for description+ -- https://opentelemetry.io/docs/specs/otel/trace/sdk/#sampling+ it "clamps ratio > 1 to 1" $ do+ let desc = getDescription (traceIdRatioBased 2.0)+ desc `shouldSatisfy` T.isPrefixOf "TraceIdRatioBased{"+ -- Implementation-specific: TraceIdRatioBased clamps invalid ratios for description+ -- https://opentelemetry.io/docs/specs/otel/trace/sdk/#sampling+ it "clamps negative ratio to 0" $ do+ let desc = getDescription (traceIdRatioBased (-1.0))+ desc `shouldSatisfy` T.isPrefixOf "TraceIdRatioBased{"
test/OpenTelemetry/Trace/TraceFlagsSpec.hs view
@@ -1,14 +1,51 @@ module OpenTelemetry.Trace.TraceFlagsSpec where +import Data.Word (Word8) import OpenTelemetry.Trace.Core import Test.Hspec spec :: Spec spec = describe "TraceFlags" $ do- it "starts unsampled by default" $ do- defaultTraceFlags `shouldSatisfy` (not . isSampled)- specify "setSampled updates flags correctly" $ do- setSampled defaultTraceFlags `shouldSatisfy` isSampled- specify "unsetSampled updates flags correctly" $ do- unsetSampled (setSampled defaultTraceFlags) `shouldSatisfy` (not . isSampled)+ -- Trace API §TraceFlags: sampled flag (bit 0)+ -- https://opentelemetry.io/docs/specs/otel/trace/api/#traceflags+ describe "sampled bit" $ do+ it "starts unsampled by default" $ do+ defaultTraceFlags `shouldSatisfy` (not . isSampled)+ specify "setSampled updates flags correctly" $ do+ setSampled defaultTraceFlags `shouldSatisfy` isSampled+ specify "unsetSampled updates flags correctly" $ do+ unsetSampled (setSampled defaultTraceFlags) `shouldSatisfy` (not . isSampled)++ -- Trace API §TraceFlags: random trace flag (W3C Level 2, bit 1)+ -- https://opentelemetry.io/docs/specs/otel/trace/api/#traceflags+ describe "W3C Level 2 random bit" $ do+ it "starts without random flag by default" $ do+ defaultTraceFlags `shouldSatisfy` (not . isRandom)++ it "setRandom sets bit 1" $ do+ setRandom defaultTraceFlags `shouldSatisfy` isRandom++ it "unsetRandom clears bit 1" $ do+ unsetRandom (setRandom defaultTraceFlags) `shouldSatisfy` (not . isRandom)++ it "random and sampled are independent" $ do+ let both = setRandom (setSampled defaultTraceFlags)+ both `shouldSatisfy` isSampled+ both `shouldSatisfy` isRandom+ unsetSampled both `shouldSatisfy` isRandom+ unsetSampled both `shouldSatisfy` (not . isSampled)+ unsetRandom both `shouldSatisfy` isSampled+ unsetRandom both `shouldSatisfy` (not . isRandom)++ it "random flag roundtrips through Word8" $ do+ let flags = setRandom (setSampled defaultTraceFlags)+ w = traceFlagsValue flags+ w `shouldBe` (0x03 :: Word8)+ traceFlagsFromWord8 w `shouldSatisfy` isSampled+ traceFlagsFromWord8 w `shouldSatisfy` isRandom++ it "traceFlagsFromWord8 preserves random bit from remote context" $ do+ let remoteFlags = traceFlagsFromWord8 0x02+ remoteFlags `shouldSatisfy` isRandom+ remoteFlags `shouldSatisfy` (not . isSampled)
test/OpenTelemetry/Trace/TracerSpec.hs view
@@ -1,14 +1,42 @@ module OpenTelemetry.Trace.TracerSpec where import qualified OpenTelemetry.Attributes as A-import OpenTelemetry.Processor.Span (SpanProcessor (..))+import OpenTelemetry.Context (empty, insertSpan)+import OpenTelemetry.Processor.Span (FlushResult (..), ShutdownResult (..), SpanProcessor (..)) import OpenTelemetry.Trace.Core+import OpenTelemetry.Trace.Id (Base (Base16), baseEncodedToSpanId, baseEncodedToTraceId) import OpenTelemetry.Trace.Sampler+import qualified OpenTelemetry.Trace.TraceState as TraceState import Test.Hspec +dummyProcessor :: SpanProcessor+dummyProcessor =+ SpanProcessor+ { spanProcessorOnStart = \_ _ -> pure ()+ , spanProcessorOnEnd = \_ -> pure ()+ , spanProcessorShutdown = pure ShutdownSuccess+ , spanProcessorForceFlush = pure FlushSuccess+ }+++parentSpanContextWithTraceState :: TraceState.TraceState -> SpanContext+parentSpanContextWithTraceState parentTs =+ let (Right tId) = baseEncodedToTraceId Base16 "00000000000000000000000000000001"+ (Right pSId) = baseEncodedToSpanId Base16 "000000000000000a"+ in SpanContext+ { traceFlags = setSampled defaultTraceFlags+ , isRemote = False+ , traceId = tId+ , spanId = pSId+ , traceState = parentTs+ }++ spec :: Spec spec = describe "Tracer" $ do+ -- Trace API §Tracer: whether a tracer will produce spans (SDK wiring)+ -- https://opentelemetry.io/docs/specs/otel/trace/api/#tracer describe "tracerIsEnabled" $ do it "returns False when TracerProvider has no processors" $ do tp <- createTracerProvider [] emptyTracerProviderOptions@@ -21,8 +49,8 @@ SpanProcessor { spanProcessorOnStart = \_ _ -> pure () , spanProcessorOnEnd = \_ -> pure ()- , spanProcessorShutdown = error "not implemented in test"- , spanProcessorForceFlush = pure ()+ , spanProcessorShutdown = pure ShutdownSuccess+ , spanProcessorForceFlush = pure FlushSuccess } tp <- createTracerProvider [dummyProcessor] emptyTracerProviderOptions let instrLib = InstrumentationLibrary "test" "1.0.0" "" A.emptyAttributes@@ -34,17 +62,44 @@ SpanProcessor { spanProcessorOnStart = \_ _ -> pure () , spanProcessorOnEnd = \_ -> pure ()- , spanProcessorShutdown = error "not implemented in test"- , spanProcessorForceFlush = pure ()+ , spanProcessorShutdown = pure ShutdownSuccess+ , spanProcessorForceFlush = pure FlushSuccess } dummyProcessor2 = SpanProcessor { spanProcessorOnStart = \_ _ -> pure () , spanProcessorOnEnd = \_ -> pure ()- , spanProcessorShutdown = error "not implemented in test"- , spanProcessorForceFlush = pure ()+ , spanProcessorShutdown = pure ShutdownSuccess+ , spanProcessorForceFlush = pure FlushSuccess } tp <- createTracerProvider [dummyProcessor1, dummyProcessor2] emptyTracerProviderOptions let instrLib = InstrumentationLibrary "test" "1.0.0" "" A.emptyAttributes tracer = makeTracer tp instrLib tracerOptions tracerIsEnabled tracer `shouldBe` True++ -- Trace API §SpanContext: TraceState is part of immutable span context; child inherits parent TraceState+ -- https://opentelemetry.io/docs/specs/otel/trace/api/#spancontext+ describe "TraceState inheritance (regression: Dropped child must not reset traceState)" $ do+ it "inherits parent TraceState when TracerProvider has no processors (FrozenSpan parent)" $ do+ let parentTs =+ TraceState.insert (TraceState.Key "vendor") (TraceState.Value "value") TraceState.empty+ parentSpan = wrapSpanContext $ parentSpanContextWithTraceState parentTs+ ctx = insertSpan parentSpan empty+ tp <- createTracerProvider [] emptyTracerProviderOptions+ let instrLib = InstrumentationLibrary "test" "1.0.0" "" A.emptyAttributes+ t = makeTracer tp instrLib tracerOptions+ child <- createSpan t ctx "child" defaultSpanArguments+ childCtx <- getSpanContext child+ traceState childCtx `shouldBe` parentTs++ it "inherits parent TraceState when parent is Dropped but TracerProvider has processors" $ do+ let parentTs =+ TraceState.insert (TraceState.Key "vendor") (TraceState.Value "value") TraceState.empty+ parentSpan = wrapDroppedContext $ parentSpanContextWithTraceState parentTs+ ctx = insertSpan parentSpan empty+ tp <- createTracerProvider [dummyProcessor] emptyTracerProviderOptions+ let instrLib = InstrumentationLibrary "test" "1.0.0" "" A.emptyAttributes+ t = makeTracer tp instrLib tracerOptions+ child <- createSpan t ctx "child" defaultSpanArguments+ childCtx <- getSpanContext child+ traceState childCtx `shouldBe` parentTs
+ test/OpenTelemetry/Trace/UtilsSpec.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module OpenTelemetry.Trace.UtilsSpec where++import qualified Data.HashMap.Strict as H+import Data.IORef+import Data.Maybe (isJust, isNothing)+import Data.Text (Text)+import qualified Data.Vector as V+import OpenTelemetry.Attributes (lookupAttribute)+import qualified OpenTelemetry.Attributes as A+import OpenTelemetry.Context (empty, insertSpan)+import OpenTelemetry.Context.ThreadLocal (attachContext)+import OpenTelemetry.Processor.Span (FlushResult (..), ShutdownResult (..), SpanProcessor (..))+import OpenTelemetry.Trace.Core+import OpenTelemetry.Util (appendOnlyBoundedCollectionValues)+import System.IO.Error (userError)+import Test.Hspec+++dummyProcessor :: SpanProcessor+dummyProcessor =+ SpanProcessor+ { spanProcessorOnStart = \_ _ -> pure ()+ , spanProcessorOnEnd = \_ -> pure ()+ , spanProcessorShutdown = pure ShutdownSuccess+ , spanProcessorForceFlush = pure FlushSuccess+ }+++withTracer :: (Tracer -> IO a) -> IO a+withTracer f = do+ tp <- createTracerProvider [dummyProcessor] emptyTracerProviderOptions+ let lib = InstrumentationLibrary "test" "1.0.0" "" A.emptyAttributes+ t = makeTracer tp lib tracerOptions+ f t+++spec :: Spec+spec = describe "Trace utilities" $ do+ -- Trace API §Span Kind: SpanKind values+ -- https://opentelemetry.io/docs/specs/otel/trace/api/#spankind+ describe "SpanKind Eq" $ do+ it "compares equal SpanKinds" $ do+ Server `shouldBe` Server+ Client `shouldBe` Client+ Producer `shouldBe` Producer+ Consumer `shouldBe` Consumer+ Internal `shouldBe` Internal++ it "distinguishes different SpanKinds" $ do+ Client `shouldNotBe` Server+ Producer `shouldNotBe` Consumer+ Internal `shouldNotBe` Client++ -- Context API §Context interactions with OTel: active context (thread-local helper)+ -- https://opentelemetry.io/docs/specs/otel/context/+ describe "getActiveSpan" $ do+ it "returns Nothing when no span is active" $ do+ _ <- attachContext empty+ result <- getActiveSpan+ result `shouldSatisfy` isNothing++ it "returns the active span from thread-local context" $ withTracer $ \t -> do+ s <- createSpan t empty "test-span" defaultSpanArguments+ _ <- attachContext (insertSpan s empty)+ result <- getActiveSpan+ result `shouldSatisfy` isJust+ let Just activeSpan = result+ activeSc <- getSpanContext activeSpan+ expectedSc <- getSpanContext s+ spanId activeSc `shouldBe` spanId expectedSc++ describe "withActiveSpan" $ do+ it "does nothing when there is no active span" $ do+ _ <- attachContext empty+ ref <- newIORef False+ withActiveSpan $ \_ -> writeIORef ref True+ readIORef ref `shouldReturn` False++ it "runs the action with the active span" $ withTracer $ \t -> do+ s <- createSpan t empty "test-span" defaultSpanArguments+ _ <- attachContext (insertSpan s empty)+ ref <- newIORef False+ withActiveSpan $ \_ -> writeIORef ref True+ readIORef ref `shouldReturn` True++ describe "getActiveSpanContext" $ do+ it "returns Nothing when no span is active" $ do+ _ <- attachContext empty+ result <- getActiveSpanContext+ result `shouldSatisfy` isNothing++ it "returns the active SpanContext" $ withTracer $ \t -> do+ s <- createSpan t empty "test-span" defaultSpanArguments+ expectedSc <- getSpanContext s+ _ <- attachContext (insertSpan s empty)+ result <- getActiveSpanContext+ result `shouldSatisfy` isJust+ let Just sc = result+ traceId sc `shouldBe` traceId expectedSc+ spanId sc `shouldBe` spanId expectedSc++ -- Trace API §Add Events: event name and attributes+ -- https://opentelemetry.io/docs/specs/otel/trace/api/#add-events+ describe "newEvent" $ do+ it "creates an event with just a name" $ do+ let e = newEvent "my-event"+ newEventName e `shouldBe` "my-event"+ newEventAttributes e `shouldBe` H.empty+ newEventTimestamp e `shouldBe` Nothing++ describe "newEventWith" $ do+ it "creates an event with name and attributes" $ do+ let attrs = H.fromList [("key" :: Text, A.toAttribute ("val" :: Text))]+ e = newEventWith "my-event" attrs+ newEventName e `shouldBe` "my-event"+ newEventAttributes e `shouldBe` attrs++ -- Trace API §Record exception: exception event and span status+ -- https://opentelemetry.io/docs/specs/otel/trace/api/#record-exception+ describe "recordError" $ do+ it "sets span status to Error and records exception event" $ withTracer $ \t -> do+ s <- createSpan t empty "test-span" defaultSpanArguments+ let err = userError "something broke"+ recordError s err+ endSpan s Nothing+ is <- unsafeReadSpan s+ hot <- readIORef (spanHot is)+ hotStatus hot `shouldSatisfy` \case Error _ -> True; _ -> False+ let evts = appendOnlyBoundedCollectionValues (hotEvents hot)+ V.length evts `shouldBe` 1+ let evt = V.head evts+ eventName evt `shouldBe` "exception"+ lookupAttribute (eventAttributes evt) "exception.type" `shouldSatisfy` isJust+ lookupAttribute (eventAttributes evt) "exception.message" `shouldSatisfy` isJust
test/Spec.hs view
@@ -1,68 +1,54 @@-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--import Control.Exception-import Control.Monad.IO.Unlift (MonadUnliftIO)-import Control.Monad.Reader-import qualified Data.Bifunctor-import Data.IORef-import Data.Maybe (isJust)-import qualified Data.Vector as V-import OpenTelemetry.Attributes (lookupAttribute)--- Specs- import qualified OpenTelemetry.AttributesSpec as Attributes import qualified OpenTelemetry.BaggageSpec as Baggage import OpenTelemetry.Context+import qualified OpenTelemetry.Context.EnvironmentSpec as ContextEnvironment+import qualified OpenTelemetry.Context.PropagationSpec as ContextPropagation+import qualified OpenTelemetry.Context.ThreadLocalSpec as ContextThreadLocal+import qualified OpenTelemetry.ContextSpec as ContextSpec+import qualified OpenTelemetry.Contrib.CarryOnsSpec as CarryOns+import qualified OpenTelemetry.Contrib.SpanTraversalsSpec as SpanTraversals+import qualified OpenTelemetry.EnvironmentSpec as Environment import qualified OpenTelemetry.InstrumentationLibrarySpec as InstrumentationLibrary-import qualified OpenTelemetry.Logs.CoreSpec as CoreSpec+import qualified OpenTelemetry.Internal.LoggingSpec as Logging+import qualified OpenTelemetry.Log.CoreSpec as CoreSpec+import qualified OpenTelemetry.MetricSpec as MetricsSpec+import qualified OpenTelemetry.PropagatorSpec as PropagatorSpec+import qualified OpenTelemetry.RegistrySpec as Registry import qualified OpenTelemetry.ResourceSpec as Resource import qualified OpenTelemetry.SemanticsConfigSpec as SemanticsConfigSpec-import OpenTelemetry.Trace.Core+import qualified OpenTelemetry.Trace.ExceptionHandlerSpec as ExceptionHandler+import qualified OpenTelemetry.Trace.IdCodecSpec as IdCodec+import qualified OpenTelemetry.Trace.MonadSpec as TraceMonad import qualified OpenTelemetry.Trace.SamplerSpec as Sampler import qualified OpenTelemetry.Trace.TraceFlagsSpec as TraceFlags import qualified OpenTelemetry.Trace.TracerSpec as Tracer-import OpenTelemetry.Util+import qualified OpenTelemetry.Trace.UtilsSpec as Utils import Test.Hspec-import qualified VectorBuilder.Vector as Builder -newtype TestException = TestException String- deriving (Show)---instance Exception TestException---exceptionTest :: IO ()-exceptionTest = do- tp <- getGlobalTracerProvider- let t = OpenTelemetry.Trace.Core.makeTracer tp "test" tracerOptions- spanToCheck <- newIORef undefined- handle (\(TestException _) -> pure ()) $ do- inSpan' t "test" defaultSpanArguments $ \span -> do- liftIO $ writeIORef spanToCheck span- throw $ TestException "wow"- spanState <- unsafeReadSpan =<< readIORef spanToCheck- let ev = V.head $ appendOnlyBoundedCollectionValues $ spanEvents spanState- eventName ev `shouldBe` "exception"- eventAttributes ev `shouldSatisfy` \attrs ->- isJust (lookupAttribute attrs "exception.type")- && isJust (lookupAttribute attrs "exception.message")- && isJust (lookupAttribute attrs "exception.stacktrace")-- main :: IO () main = hspec $ do- -- describe "inSpan" $ do- -- it "records exceptions" $ do- -- exceptionTest Attributes.spec Baggage.spec+ ContextSpec.spec+ ContextEnvironment.spec+ ContextThreadLocal.spec+ ContextPropagation.spec+ CarryOns.spec+ SpanTraversals.spec+ Environment.spec Resource.spec InstrumentationLibrary.spec+ Logging.spec+ ExceptionHandler.spec+ IdCodec.spec+ TraceMonad.spec Sampler.spec TraceFlags.spec Tracer.spec+ Utils.spec SemanticsConfigSpec.spec CoreSpec.spec+ MetricsSpec.spec+ PropagatorSpec.spec+ Registry.spec