hs-opentelemetry-sdk 0.0.3.6 → 1.0.0.0
raw patch · 55 files changed
Files
- ChangeLog.md +177/−4
- LICENSE +1/−1
- README.md +13/−3
- hs-opentelemetry-sdk.cabal +108/−34
- src/OpenTelemetry/Configuration.hs +101/−0
- src/OpenTelemetry/Configuration/Create.hs +388/−0
- src/OpenTelemetry/Configuration/Parse.hs +398/−0
- src/OpenTelemetry/Configuration/Types.hs +261/−0
- src/OpenTelemetry/Log.hs +301/−0
- src/OpenTelemetry/MeterProvider.hs +1325/−0
- src/OpenTelemetry/Metric.hs +252/−0
- src/OpenTelemetry/Metric/ExporterSelection.hs +49/−0
- src/OpenTelemetry/Metric/View.hs +107/−0
- src/OpenTelemetry/MetricReader.hs +91/−0
- src/OpenTelemetry/Processor/Batch.hs +5/−366
- src/OpenTelemetry/Processor/Batch/LogRecord.hs +199/−0
- src/OpenTelemetry/Processor/Batch/Span.hs +419/−0
- src/OpenTelemetry/Processor/Simple.hs +7/−60
- src/OpenTelemetry/Processor/Simple/LogRecord.hs +100/−0
- src/OpenTelemetry/Processor/Simple/Span.hs +115/−0
- src/OpenTelemetry/Resource/Cloud/Detector.hs +172/−0
- src/OpenTelemetry/Resource/Container/Detector.hs +125/−0
- src/OpenTelemetry/Resource/Detect.hs +193/−0
- src/OpenTelemetry/Resource/Detector/AWS/EC2.hs +132/−0
- src/OpenTelemetry/Resource/Detector/AWS/ECS.hs +177/−0
- src/OpenTelemetry/Resource/Detector/AWS/EKS.hs +146/−0
- src/OpenTelemetry/Resource/Detector/Azure.hs +107/−0
- src/OpenTelemetry/Resource/Detector/GCP.hs +125/−0
- src/OpenTelemetry/Resource/Detector/Heroku.hs +58/−0
- src/OpenTelemetry/Resource/Detector/Internal.hs +22/−0
- src/OpenTelemetry/Resource/Detector/Metadata.hs +203/−0
- src/OpenTelemetry/Resource/FaaS/Detector.hs +121/−0
- src/OpenTelemetry/Resource/Host/Detector.hs +76/−12
- src/OpenTelemetry/Resource/Kubernetes/Detector.hs +116/−0
- src/OpenTelemetry/Resource/OperatingSystem/Detector.hs +78/−12
- src/OpenTelemetry/Resource/Process/Detector.hs +38/−17
- src/OpenTelemetry/Resource/Service/Detector.hs +9/−0
- src/OpenTelemetry/Resource/Telemetry/Detector.hs +3/−2
- src/OpenTelemetry/SDK.hs +90/−0
- src/OpenTelemetry/Trace.hs +175/−107
- src/OpenTelemetry/Trace/Id/Generator/Default.hs +1/−13
- src/platform/unix/OpenTelemetry/Platform.hs +28/−0
- src/platform/windows/OpenTelemetry/Platform.hs +16/−0
- test/OpenTelemetry/BaggageSpec.hs +35/−2
- test/OpenTelemetry/ConfigurationSpec.hs +450/−0
- test/OpenTelemetry/ContextInSpanSpec.hs +47/−0
- test/OpenTelemetry/ContextSpec.hs +173/−18
- test/OpenTelemetry/LogSpec.hs +257/−0
- test/OpenTelemetry/MeterProviderSpec.hs +501/−0
- test/OpenTelemetry/MetricReaderSpec.hs +65/−0
- test/OpenTelemetry/Resource/DetectorSpec.hs +624/−0
- test/OpenTelemetry/ResourceSpec.hs +68/−5
- test/OpenTelemetry/Trace/CallStackSpec.hs +207/−0
- test/OpenTelemetry/TraceSpec.hs +467/−46
- test/Spec.hs +75/−1
ChangeLog.md view
@@ -1,5 +1,182 @@ # Changelog for hs-opentelemetry-sdk +## Unreleased++## 1.0.0.0 - 2026-05-29++### Spec conformance (1.55.0 audit)+- **NaN/Inf silently dropped for all metric instrument types.**+ Previously only histograms filtered non-finite double values. Now+ `addSumDbl`, `setSumDbl`, and `recordGauge` also drop NaN and Infinity.+ Spec: <https://opentelemetry.io/docs/specs/otel/metrics/sdk/>++### Performance+- **Batch processor**: switched to `unagi-chan` bounded queue with power-of-two+ sizing. `tryWriteChan` is non-blocking; drain uses `estimatedLength` for+ batch sizing. Export groups spans by tracer at drain time. Concurrent chunk+ export via `mapConcurrently_`.+- **Simple processor**: synchronous export in `onEnd`/`onEmit` (no thread+ overhead). Matches Go/Java/Python SDK design for low-throughput use cases.+- **Metrics**: `AtomicBucketArray` for histogram buckets (single+ `MutableByteArray#` with `fetchAddIntArray#`, zero vector copying on record).+ Separate `SumIntCell`/`SumDblCell` to avoid boxing. Binary search for bucket+ index. `OptionalDouble` sentinel for min/max instead of `Maybe Double`.+- **Default ID generator**: thread-local xoshiro256++ in C, replacing the+ Haskell `random` package (`System.Random.Stateful`) that was used on+ `origin/main`. No contention, no syscalls, no Haskell allocation after+ initial seed.++### Bug fixes+- **Batch processor shutdown deadlock fixed.**+ Second `shutdownTracerProvider` / `shutdownLoggerProvider` call would hang+ forever because `putTMVar` blocks when the worker has already consumed the+ signal. Fixed with `tryPutTMVar` + `IORef` shutdown guard. `OnEnd`/`OnEmit`+ are now also guarded to prevent buffer growth after shutdown.+- **Counter rejects negative values.**+ Monotonic counters now drop negative deltas per spec. Previously, negative+ values were summed into the same cell, producing incorrect monotonic sums.+- **`MeterProvider.shutdown` is now idempotent.**+ Second call returns `ShutdownSuccess` immediately without re-running+ collection, export, or exporter shutdown.+- **`OTEL_SDK_DISABLED=true` no longer disables propagators.**+ `detectPropagators` is now always called, even when the SDK is disabled,+ so `setGlobalTextMapPropagator` runs and instrumentation libraries can+ still propagate context.+- **`service.name` precedence fixed.**+ `OTEL_SERVICE_NAME` now takes precedence over `service.name` defined in+ `OTEL_RESOURCE_ATTRIBUTES`, matching the spec.+- **OTLP exporters return `Failure` after shutdown.**+ `spanExporterExport` and `logRecordExporterExport` now check a shutdown+ flag and return `Failure Nothing` after `shutdown()` is called.+- **Simple processors have 30s export timeout.**+ `export()` in simple span and log record processors is now wrapped in a+ `timeout` to prevent indefinite blocking.+- **BSP default `maxQueueSize` fixed from 1024 to 2048.**+ Now matches the spec default and the documentation table.++### Changes+- **`detectPropagators` and `createFromConfig` now set the global propagator.**+ The SDK initialization path (`initializeGlobalTracerProvider` and+ `createFromConfig`) now calls `setGlobalTextMapPropagator`, making propagators+ available via the global API. Instrumentation libraries (WAI, http-client,+ hw-kafka-client) now use `getGlobalTextMapPropagator` instead of extracting+ propagators from the `TracerProvider`.+- **`OTEL_PROPAGATORS` values are now deduplicated and whitespace-stripped.**+ Per spec: "Values MUST be deduplicated in order to register a Propagator only once."+- **Breaking: `SimpleSpanProcessor` and `SimpleLogRecordProcessor` now export synchronously.**+ `onEnd` / `onEmit` calls the exporter directly on the calling thread instead of+ enqueueing to an unbounded async channel. This matches the OTel specification+ ("passes finished spans directly to the configured SpanExporter") and the behavior+ of every other OTel SDK: Go, Java, .NET, C++, Rust, and Python all export+ synchronously in their simple processors. The previous unbounded `unagi-chan`+ queue could grow without bound under backpressure. Use `BatchSpanProcessor` /+ `BatchLogRecordProcessor` for non-blocking, production-grade processing.+- **Metric storage: per-instrument `IORef` replaces global `IORef`.**+ Each instrument now owns its own `IORef (HashMap Attributes Cell)`, eliminating+ cross-instrument contention on the recording hot path. Same-name instrument+ re-registration shares the underlying `IORef` (spec MUST). `SdkMeterStorageState`,+ `DimKey`, and `seriesCountByDims` are removed.+- **Fix: TOCTOU race in instrument registration.** `getOrCreateInstrumentStorage`+ now performs the lookup and insertion inside a single `atomicModifyIORef'`, preventing+ duplicate `IORef`s for the same instrument under concurrent registration.+- **Fix: delta temporality lost-update bug.** `collectResourceMetrics` now atomically+ snapshots and resets each instrument's cell map in one `atomicModifyIORef'`, preventing+ recordings between snapshot and reset from being silently dropped.+- **Fix: metric export grouping.** `buildResourceExport` now groups by+ `InstrumentationLibrary` (scope) with each instrument producing an independent+ metric export, rather than merging instruments that share (scope, name, kind, unit,+ description) but differ in histogram aggregation or export attribute keys.+- **Fix: `OTEL_CONFIG_FILE` resource.schema_url.** `buildResource` now applies+ `resourceSchemaUrl` from the config to the materialized resource.+- **Fix: view matching ignoring unit and meter scope.** `findMatchingView`,+ `shouldDropInstrument`, `viewOverrideName`, `viewOverrideDescription`, and+ `exportKeysFor` now receive real instrument unit and meter scope. Previously+ views with unit or meter-name/version/schema_url selectors never matched.+- **Fix: batch processor worker crash on export exception.** Both batch span and+ batch log processors now catch `SomeException` around `publish`, preventing the+ worker `Async` from dying permanently on a transient exporter failure.+- **Fix: unsorted explicit histogram bucket boundaries.** Advisory and view-supplied+ bucket boundaries are now sorted before use, preventing incorrect bucket placement.+- **Fix: batch processor off-by-one in queue capacity.** Both `BatchSpanProcessor`+ and `BatchLogRecordProcessor` rejected items when `count + 1 >= maxQueueSize`,+ meaning a queue configured for 1024 items only held 1023. Changed to+ `count >= maxQueueSize` so the queue accepts exactly `maxQueueSize` items.+- **Fix: simple processor shutdown flags used non-atomic `writeIORef`.** Both+ `SimpleSpanProcessor` and `SimpleLogRecordProcessor` now use `atomicWriteIORef`+ for the shutdown flag, ensuring happens-before visibility to concurrent readers.+- **Fix: `MeterProvider` shutdown flag used non-atomic `writeIORef`.** Now uses+ `atomicWriteIORef` for the shutdown boolean.+- **Fix: `detectSpanLimits` swapped `OTEL_SPAN_LINK_COUNT_LIMIT` and+ `OTEL_EVENT_ATTRIBUTE_COUNT_LIMIT`.** Positional applicative construction+ mapped link count limit to `eventAttributeCountLimit` and vice versa.+ Corrected field ordering.+- **Batch processor `ForceFlush` now blocks until the worker completes an export cycle.**+ Previously `ForceFlush` signaled the worker and returned immediately, offering no+ guarantee that buffered spans/logs were exported before the caller continued. The new+ implementation uses a generation counter with a timeout derived from `exportTimeoutMillis`.+- **Batch processor `maxExportBatchSize` is now enforced as a hard per-export limit.**+ The buffer is drained fully, then chunked into batches of at most `maxExportBatchSize`+ items before each chunk is exported separately. Matches the OTel spec requirement.+- **Per-export timeout on batch processor.** Individual export calls are wrapped in+ `System.Timeout.timeout exportTimeoutMillis`. A timed-out export returns `Failure`+ without killing the worker.+- **`ReadableLogRecord` is now a true point-in-time snapshot.** `mkReadableLogRecord`+ reads the `IORef` and stores the `ImmutableLogRecord` directly, so exporters see+ a consistent view regardless of concurrent mutations. `mkReadableLogRecord` is now+ `IO` (breaking change to the internal API).+- **Observable callback handles now support real unregistration.** `ObservableCallbackHandle.unregisterObservableCallback`+ removes the callback from the meter's collection registry. Previously it was a no-op.+ Internally, callbacks are stored in an `IntMap` keyed by unique ID rather than a `Seq`.+- Implement declarative SDK configuration via `OTEL_CONFIG_FILE` (`OpenTelemetry.Configuration`)+ - YAML parsing with environment variable substitution (`${VAR}`, `${env:VAR:-default}`)+ - In-memory configuration data model (`OpenTelemetry.Configuration.Types`)+ - Full `Create` operation: TracerProvider, MeterProvider, LoggerProvider, Propagators from config+ - Supports OTLP HTTP, console, and none exporters; batch and simple processors+ - Sampler configuration: always_on, always_off, trace_id_ratio_based, parent_based+ - Resource, attribute limits, span limits, propagator configuration+- **Shutdown/ForceFlush propagation audit:**+ - Batch span processor now calls `spanExporterShutdown` during processor shutdown (was missing)+ - Batch log processor now calls `logRecordExporterShutdown` during processor shutdown+ - `MeterProvider` shutdown now does a final collect + export + `metricExporterShutdown` when an exporter is configured+ - `MeterProvider` forceFlush now does collect + export + `metricExporterForceFlush` when an exporter is configured+ - `SdkMeterProviderOptions` gains `metricExporter :: Maybe MetricExporter` field+ - Periodic metric reader stop now calls `metricExporterShutdown` after final export+ - `forceFlushTracerProvider` exported from `OpenTelemetry.Trace` (SDK)+- Implement `SimpleLogRecordProcessor`: processes log records inline, passes them to configured `LogRecordExporter`+- Implement `BatchLogRecordProcessor`: batches log records with configurable queue size, export interval, and timeout+- Batch/simple span processors now call `spanExporterForceFlush` during processor `ForceFlush`+- IsValid test coverage expanded for TraceId-only and SpanId-only zero cases+- Track `startTimeUnixNano` across all data points (was hardcoded to 0)+- `ForceFlush` on `MeterProvider` now triggers a metric collect+- `View` supports name and description overrides+- `ViewSelector` expanded: name (wildcard), kind, unit, meter_name, meter_version, meter_schema_url criteria (spec MUST)+- `findAllMatchingViews` for multi-view-stream support+- Instrument name matching is now case-insensitive (spec MUST)+- Cardinality overflow: excess series aggregated under `otel.metric.overflow=true` (spec SHOULD)+- Default explicit histogram bounds updated to spec: `[0, 5, 10, 25, 50, 75, 100, 250, 500, 750, 1000, 2500, 5000, 7500, 10000]`+- NaN/Inf measurements silently dropped in recordHist/recordExpHist (spec MUST)+- Advisory `Attributes` parameter used as fallback when View has no `attribute_keys` (spec SHOULD)+- `ExemplarFilter`: TraceBased (default), AlwaysOn, AlwaysOff: replaces boolean `exemplarCaptureTraceContext`+- `OTEL_METRICS_EXEMPLAR_FILTER` env var fully wired into SDK+- New `OpenTelemetry.Metrics.ExporterSelection` module: wire `OTEL_METRICS_EXPORTER` to concrete `MetricExporter`+- Comprehensive test coverage for all instrument types, views, delta temporality, observables+- `SdkMeterProviderOptions`: `aggregationTemporality`, `views`, `exemplarOptions`+- `OpenTelemetry.Metrics.View`: instrument selection and aggregation overrides (including drop).+- Exponential histogram aggregation, exemplars, delta temporality with post-collect reset (gauges unchanged).+- Observable callbacks collected in FIFO order; `MetricReader.periodicMetricReaderOptionsFromEnv` for `OTEL_METRIC_EXPORT_INTERVAL`.++## 0.1.0.1++- Update dependency bounds for hs-opentelemetry-api 0.3.0.0++## 0.1.0.0++- Support new versions of dependencies.+- Windows: Replace POSIX-only functionality with a stub, so the package could be built at all (#114).+- Support `OTEL_SDK_DISABLED` (#148).+- Add Datadog as a known propagator (#117).+- Documentation improvements+ ## 0.0.3.6 - Raise minimum version bounds for `random` to 1.2.0. This fixes duplicate ID generation issues in highly concurrent systems.@@ -30,7 +207,3 @@ ## 0.0.1.0 - Initial release--## Unreleased changes--- Documentation improvements
LICENSE view
@@ -1,4 +1,4 @@-Copyright Ian Duncan (c) 2021+Copyright Ian Duncan (c) 2021-2026 All rights reserved.
README.md view
@@ -1,9 +1,9 @@ # OpenTelemetry SDK for Haskell -This package provides everything a functioning implementation of-the OpenTelemetry the API, useful for exporting a variety of-tracing, logging, and metric data.+[](https://hackage.haskell.org/package/hs-opentelemetry-sdk) +This package provides everything a functioning implementation of the OpenTelemetry the API requires, useful for exporting a variety of tracing, logging, and metric data.+ ## Why use OpenTelemetry tracing? If you’re running a user-facing software service, it probably qualifies as a distributed service. You might have a proxy, an application and a database, or a more complicated microservice architecture. Regardless of the level of complexity, a distributed system means that multiple distinct services must work together in concert.@@ -75,6 +75,16 @@ ## Install Dependencies Add `hs-opentelemetry-sdk` to your `package.yaml` or Cabal file.++## Metrics (SDK)++1. Build a resource (e.g. `emptyMaterializedResources` or service detectors).+2. `createMeterProvider resource defaultSdkMeterProviderOptions` (adjust `views`, `aggregationTemporality`, `exemplarOptions`, `cardinalityLimit` as needed).+3. `getMeter provider yourInstrumentationLibrary` and create instruments (`meterCreateCounterInt64`, `meterCreateHistogram`, …).+4. Export: build a `MetricExporter` (e.g. `otlpMetricExporter` from `loadExporterEnvironmentVariables`), then either `forkPeriodicMetricReader env exporter =<< periodicMetricReaderOptionsFromEnv`, or on each scrape call `exportMetricsOnce env exporter` (pull-style HTTP handler).+5. Use `otlpMetricExporter` from `OpenTelemetry.Exporter.OTLP.Metric` with `loadExporterEnvironmentVariables` / `OTLPExporterConfig` for OTLP/HTTP, or `renderPrometheusText` from `OpenTelemetry.Exporter.Prometheus` for Prometheus text.++Shutdown: stop the periodic reader (if any), then `meterProviderShutdown` on the provider. ## Trace Your Code
hs-opentelemetry-sdk.cabal view
@@ -1,37 +1,69 @@ cabal-version: 1.22 --- This file has been generated from package.yaml by hpack version 0.35.2.+-- This file has been generated from package.yaml by hpack version 0.38.3. -- -- see: https://github.com/sol/hpack -name: hs-opentelemetry-sdk-version: 0.0.3.6-synopsis: OpenTelemetry SDK for use in applications.-description: Please see the README on GitHub at <https://github.com/iand675/hs-opentelemetry/tree/main/sdk#readme>-category: OpenTelemetry, Telemetry, Monitoring, Observability, Metrics-homepage: https://github.com/iand675/hs-opentelemetry#readme-bug-reports: https://github.com/iand675/hs-opentelemetry/issues-author: Ian Duncan, Jade Lovelace-maintainer: ian@iankduncan.com-copyright: 2023 Ian Duncan, Mercury Technologies-license: BSD3-license-file: LICENSE-build-type: Simple+name: hs-opentelemetry-sdk+version: 1.0.0.0+synopsis: OpenTelemetry SDK for use in applications.+description: Please see the README on GitHub at <https://github.com/iand675/hs-opentelemetry/tree/main/sdk#readme>+category: OpenTelemetry, Telemetry, Monitoring, Observability, Metrics+homepage: https://github.com/iand675/hs-opentelemetry#readme+bug-reports: https://github.com/iand675/hs-opentelemetry/issues+author: Ian Duncan, Jade Lovelace+maintainer: ian@iankduncan.com+copyright: 2024 Ian Duncan, Mercury Technologies+license: BSD3+license-file: LICENSE+build-type: Simple extra-source-files: README.md- ChangeLog.md extra-doc-files:+ ChangeLog.md docs/img/traces_spans.png source-repository head type: git location: https://github.com/iand675/hs-opentelemetry +flag tls-metadata+ description: Enable TLS-based metadata detection (requires crypton-connection >= 0.3.1). Disable for LTS 21.x (GHC 9.4) which lacks crypton-connection.+ manual: False+ default: True+ library exposed-modules:+ OpenTelemetry.SDK+ OpenTelemetry.Configuration+ OpenTelemetry.Configuration.Create+ OpenTelemetry.Configuration.Parse+ OpenTelemetry.Configuration.Types+ OpenTelemetry.Log+ OpenTelemetry.MetricReader+ OpenTelemetry.MeterProvider+ OpenTelemetry.Metric+ OpenTelemetry.Metric.ExporterSelection+ OpenTelemetry.Metric.View OpenTelemetry.Processor.Batch+ OpenTelemetry.Processor.Batch.LogRecord+ OpenTelemetry.Processor.Batch.Span OpenTelemetry.Processor.Simple+ OpenTelemetry.Processor.Simple.LogRecord+ OpenTelemetry.Processor.Simple.Span+ OpenTelemetry.Resource.Cloud.Detector+ OpenTelemetry.Resource.Container.Detector+ OpenTelemetry.Resource.Detect+ OpenTelemetry.Resource.Detector.AWS.EC2+ OpenTelemetry.Resource.Detector.AWS.ECS+ OpenTelemetry.Resource.Detector.AWS.EKS+ OpenTelemetry.Resource.Detector.Azure+ OpenTelemetry.Resource.Detector.GCP+ OpenTelemetry.Resource.Detector.Heroku+ OpenTelemetry.Resource.Detector.Metadata+ OpenTelemetry.Resource.FaaS.Detector OpenTelemetry.Resource.Host.Detector+ OpenTelemetry.Resource.Kubernetes.Detector OpenTelemetry.Resource.OperatingSystem.Detector OpenTelemetry.Resource.Process.Detector OpenTelemetry.Resource.Service.Detector@@ -39,13 +71,18 @@ OpenTelemetry.Trace OpenTelemetry.Trace.Id.Generator.Default other-modules:+ OpenTelemetry.Resource.Detector.Internal Paths_hs_opentelemetry_sdk reexported-modules: OpenTelemetry.Attributes , OpenTelemetry.Baggage , OpenTelemetry.Context , OpenTelemetry.Context.ThreadLocal+ , OpenTelemetry.Exporter.Span+ , OpenTelemetry.Exporter.LogRecord , OpenTelemetry.Exporter+ , OpenTelemetry.Processor.Span+ , OpenTelemetry.Processor.LogRecord , OpenTelemetry.Processor , OpenTelemetry.Propagator , OpenTelemetry.Resource@@ -70,35 +107,75 @@ src ghc-options: -Wall build-depends:- async+ aeson+ , async , base >=4.7 && <5 , bytestring- , hs-opentelemetry-api >=0.0.3 && <0.2- , hs-opentelemetry-exporter-otlp ==0.0.1.*- , hs-opentelemetry-propagator-b3 ==0.0.1.*- , hs-opentelemetry-propagator-w3c ==0.0.1.*+ , case-insensitive+ , clock+ , containers+ , directory+ , hashable+ , hs-opentelemetry-api ==1.0.*+ , hs-opentelemetry-exporter-handle ==1.0.*+ , hs-opentelemetry-exporter-otlp ==1.0.*+ , hs-opentelemetry-propagator-b3 ==1.0.*+ , hs-opentelemetry-propagator-datadog ==1.0.*+ , hs-opentelemetry-propagator-jaeger ==1.0.*+ , hs-opentelemetry-propagator-w3c ==1.0.*+ , hs-opentelemetry-propagator-xray ==1.0.*+ , hs-opentelemetry-semantic-conventions >=1.40 && <2+ , http-client , http-types , network-bsd+ , process , random >=1.2.0+ , scientific , stm , text- , transformers- , unagi-chan- , unix+ , time+ , unix-compat >=0.7.1 , unordered-containers , vector , vector-builder+ , yaml default-language: Haskell2010+ if os(windows)+ other-modules:+ OpenTelemetry.Platform+ hs-source-dirs:+ src/platform/windows+ else+ other-modules:+ OpenTelemetry.Platform+ hs-source-dirs:+ src/platform/unix+ build-depends:+ unix+ if flag(tls-metadata)+ cpp-options: -DTLS_METADATA+ build-depends:+ crypton-connection+ , crypton-x509+ , crypton-x509-store+ , http-client-tls+ , tls test-suite hs-opentelemetry-sdk-test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: OpenTelemetry.BaggageSpec+ OpenTelemetry.ConfigurationSpec+ OpenTelemetry.ContextInSpanSpec OpenTelemetry.ContextSpec+ OpenTelemetry.LogSpec+ OpenTelemetry.MeterProviderSpec+ OpenTelemetry.MetricReaderSpec+ OpenTelemetry.Resource.DetectorSpec OpenTelemetry.ResourceSpec+ OpenTelemetry.Trace.CallStackSpec OpenTelemetry.TraceSpec- Paths_hs_opentelemetry_sdk hs-source-dirs: test ghc-options: -threaded -rtsopts -with-rtsopts=-N@@ -107,21 +184,18 @@ , base >=4.7 && <5 , bytestring , clock+ , containers+ , directory , hs-opentelemetry-api- , hs-opentelemetry-exporter-otlp ==0.0.1.*- , hs-opentelemetry-propagator-b3 ==0.0.1.*- , hs-opentelemetry-propagator-w3c ==0.0.1.*+ , hs-opentelemetry-exporter-in-memory+ , hs-opentelemetry-propagator-b3+ , hs-opentelemetry-propagator-w3c , hs-opentelemetry-sdk+ , hs-opentelemetry-semantic-conventions , hspec- , http-types- , network-bsd- , random >=1.2.0- , stm+ , process , text- , transformers- , unagi-chan , unix , unordered-containers , vector- , vector-builder default-language: Haskell2010
+ src/OpenTelemetry/Configuration.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Declarative SDK configuration via OTEL_CONFIG_FILE.+See: https://opentelemetry.io/docs/specs/otel/configuration/sdk/++Usage:++@+import OpenTelemetry.Configuration++main :: IO ()+main = do+ result <- initializeFromConfigFile+ case result of+ Nothing -> pure () -- OTEL_CONFIG_FILE not set, use default initialization+ Just components -> do+ -- Use otelTracerProvider, otelMeterProvider, etc.+ otelShutdown components+@++Or from a specific file:++@+components <- initializeFromFile "config.yaml"+@+-}+module OpenTelemetry.Configuration (+ -- * Initialization+ initializeFromConfigFile,+ initializeFromFile,+ initializeFromText,++ -- * Components+ OTelSignals (..),+ OTelComponents,++ -- * Configuration model+ OTelConfiguration (..),+ emptyConfiguration,++ -- * Parsing+ parseConfigFile,+ parseConfigBytes,+ ConfigParseError (..),++ -- * Creation+ createFromConfig,+) where++import Control.Applicative ((<|>))+import Control.Exception (throwIO)+import Data.Text (Text)+import OpenTelemetry.Configuration.Create+import OpenTelemetry.Configuration.Parse+import OpenTelemetry.Configuration.Types+import OpenTelemetry.Internal.Logging (otelLogDebug)+import System.Environment (lookupEnv)+++{- | Check for a declarative config file and initialize from it if set.++Checks @OTEL_EXPERIMENTAL_CONFIG_FILE@ first (per the evolving+<https://opentelemetry.io/docs/specs/otel/configuration/file-configuration/ file configuration spec>),+then falls back to @OTEL_CONFIG_FILE@ for backward compatibility.+Returns @Nothing@ if neither env var is set.++@since 0.1.0.0+-}+initializeFromConfigFile :: IO (Maybe OTelSignals)+initializeFromConfigFile = do+ mPath <- lookupEnv "OTEL_EXPERIMENTAL_CONFIG_FILE"+ mPathLegacy <- lookupEnv "OTEL_CONFIG_FILE"+ case mPath <|> mPathLegacy of+ Nothing -> do+ otelLogDebug "OTEL_EXPERIMENTAL_CONFIG_FILE / OTEL_CONFIG_FILE not set, skipping file-based configuration"+ pure Nothing+ Just path -> Just <$> initializeFromFile path+++{- | Parse and create SDK components from a YAML configuration file.++@since 0.1.0.0+-}+initializeFromFile :: FilePath -> IO OTelSignals+initializeFromFile path = do+ result <- parseConfigFile path+ case result of+ Left err -> throwIO $ userError $ "Failed to parse OTEL config file " <> path <> ": " <> show err+ Right cfg -> createFromConfig cfg+++{- | Parse and create SDK components from YAML text content.++@since 0.1.0.0+-}+initializeFromText :: Text -> IO OTelSignals+initializeFromText content = do+ result <- parseConfigBytes content+ case result of+ Left err -> throwIO $ userError $ "Failed to parse OTEL config: " <> show err+ Right cfg -> createFromConfig cfg
+ src/OpenTelemetry/Configuration/Create.hs view
@@ -0,0 +1,388 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++{- | Implements the "Create" operation from the OpenTelemetry Configuration SDK spec.+Interprets the in-memory configuration model and produces SDK components.+See: https://opentelemetry.io/docs/specs/otel/configuration/sdk/#create+-}+module OpenTelemetry.Configuration.Create (+ createFromConfig,+ OTelSignals (..),+ OTelComponents,+) where++import Control.Monad (when)+import qualified Data.CaseInsensitive as CI+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Network.HTTP.Types.Header (Header)+import OpenTelemetry.Attributes (AttributeLimits (..), defaultAttributeLimits)+import OpenTelemetry.Configuration.Types+import qualified OpenTelemetry.Exporter.Handle.LogRecord as HandleLog+import qualified OpenTelemetry.Exporter.Handle.Metric as HandleMetric+import qualified OpenTelemetry.Exporter.Handle.Span as HandleSpan+import OpenTelemetry.Exporter.LogRecord (LogRecordExporter, LogRecordExporterArguments (..), mkLogRecordExporter)+import OpenTelemetry.Exporter.Metric (MetricExporter)+import OpenTelemetry.Exporter.OTLP.LogRecord (otlpLogRecordExporter)+import OpenTelemetry.Exporter.OTLP.Metric (otlpMetricExporter)+import OpenTelemetry.Exporter.OTLP.Span (CompressionFormat (..), OTLPExporterConfig (..), otlpExporter)+import OpenTelemetry.Exporter.Span (SpanExporter (..))+import OpenTelemetry.Internal.Common.Types (ExportResult (..))+import OpenTelemetry.Internal.Logging (otelLogWarning)+import OpenTelemetry.Log.Core (LoggerProvider, LoggerProviderOptions (..), createLoggerProvider, emptyLoggerProviderOptions, shutdownLoggerProvider)+import OpenTelemetry.MeterProvider+import OpenTelemetry.Metric.Core (MeterProvider (..), shutdownMeterProvider)+import OpenTelemetry.MetricReader+import OpenTelemetry.Processor.Batch.LogRecord (batchLogRecordProcessor)+import qualified OpenTelemetry.Processor.Batch.LogRecord as BlogProc+import OpenTelemetry.Processor.Batch.Span (BatchTimeoutConfig (..), batchProcessor, batchTimeoutConfig)+import OpenTelemetry.Processor.LogRecord (LogRecordProcessor)+import qualified OpenTelemetry.Processor.Simple.LogRecord as SlogProc+import OpenTelemetry.Processor.Simple.Span (SimpleProcessorConfig (..), simpleProcessor)+import OpenTelemetry.Processor.Span (SpanProcessor)+import OpenTelemetry.Propagator (TextMapPropagator, setGlobalTextMapPropagator)+import OpenTelemetry.Propagator.B3 (b3MultiTraceContextPropagator, b3TraceContextPropagator)+import OpenTelemetry.Propagator.W3CBaggage+import OpenTelemetry.Propagator.W3CTraceContext+import OpenTelemetry.Resource+import OpenTelemetry.Trace.Core+import OpenTelemetry.Trace.Id.Generator.Default (defaultIdGenerator)+import OpenTelemetry.Trace.Sampler+++-- | @since 1.0.0.0+data OTelSignals = OTelSignals+ { otelTracerProvider :: !TracerProvider+ , otelMeterProvider :: !MeterProvider+ , otelLoggerProvider :: !LoggerProvider+ , otelPropagators :: !TextMapPropagator+ , otelShutdown :: !(IO ())+ }+++{-# DEPRECATED OTelComponents "Use OTelSignals instead" #-}+++type OTelComponents = OTelSignals+++{- | Create SDK components from a parsed configuration model.+Returns all three providers and the composite propagator.++@since 0.1.0.0+-}+createFromConfig :: OTelConfiguration -> IO OTelSignals+createFromConfig cfg = do+ let disabled = fromMaybe False (configDisabled cfg)+ if disabled+ then do+ tp <- createTracerProvider [] emptyTracerProviderOptions+ (mp, _env) <- createMeterProvider emptyMaterializedResources defaultSdkMeterProviderOptions+ lp <- createLoggerProvider [] emptyLoggerProviderOptions+ pure+ OTelSignals+ { otelTracerProvider = tp+ , otelMeterProvider = mp+ , otelLoggerProvider = lp+ , otelPropagators = mempty+ , otelShutdown = pure ()+ }+ else do+ let globalAttrLimits = configAttrLimits cfg++ -- Resource+ let res = buildResource cfg++ -- Propagators+ props <- buildPropagators cfg+ setGlobalTextMapPropagator props++ -- TracerProvider+ (spanProcessors, _spanShutdowns) <- buildSpanProcessors cfg+ let tpOpts =+ emptyTracerProviderOptions+ { tracerProviderOptionsIdGenerator = defaultIdGenerator+ , tracerProviderOptionsSampler = buildSampler cfg+ , tracerProviderOptionsAttributeLimits = globalAttrLimits+ , tracerProviderOptionsSpanLimits = buildSpanLimits cfg+ , tracerProviderOptionsPropagators = props+ , tracerProviderOptionsResources = res+ }+ tp <- createTracerProvider spanProcessors tpOpts++ -- MeterProvider+ mp <- buildMeterProvider cfg res++ -- LoggerProvider+ (lp, _logShutdowns) <- buildLoggerProvider cfg globalAttrLimits res++ let shutdown = do+ _ <- shutdownTracerProvider tp Nothing+ _ <- shutdownMeterProvider mp Nothing+ _ <- shutdownLoggerProvider lp Nothing+ pure ()++ pure+ OTelSignals+ { otelTracerProvider = tp+ , otelMeterProvider = mp+ , otelLoggerProvider = lp+ , otelPropagators = props+ , otelShutdown = shutdown+ }+++configAttrLimits :: OTelConfiguration -> AttributeLimits+configAttrLimits cfg = case configAttributeLimits cfg of+ Nothing -> defaultAttributeLimits+ Just al ->+ defaultAttributeLimits+ { attributeCountLimit = alAttributeCountLimit al+ , attributeLengthLimit = alAttributeValueLengthLimit al+ }+++buildResource :: OTelConfiguration -> MaterializedResources+buildResource cfg = case configResource cfg of+ Nothing -> emptyMaterializedResources+ Just rc ->+ let attrs = maybe [] (map (\(k, v) -> (k, toAttribute v)) . Map.toList) (resourceAttributes rc)+ r = mkResource (map Just attrs)+ schema = fmap T.unpack (resourceSchemaUrl rc)+ in materializeResourcesWithSchema schema r+++buildPropagators :: OTelConfiguration -> IO TextMapPropagator+buildPropagators cfg = case configPropagator cfg of+ Nothing -> pure $ w3cTraceContextPropagator <> w3cBaggagePropagator+ Just pc -> case propagatorComposite pc of+ Nothing -> pure $ w3cTraceContextPropagator <> w3cBaggagePropagator+ Just names -> mconcat <$> mapM resolvePropagator names+ where+ resolvePropagator name = case T.toLower name of+ "tracecontext" -> pure w3cTraceContextPropagator+ "baggage" -> pure w3cBaggagePropagator+ "b3" -> pure b3TraceContextPropagator+ "b3multi" -> pure b3MultiTraceContextPropagator+ "none" -> pure mempty+ unknown -> do+ otelLogWarning $ "Unknown propagator " <> show unknown <> ", skipping"+ pure mempty+++buildSampler :: OTelConfiguration -> Sampler+buildSampler cfg = case configTracerProvider cfg of+ Nothing -> parentBased (parentBasedOptions alwaysOn)+ Just tp -> case tpSampler tp of+ Nothing -> parentBased (parentBasedOptions alwaysOn)+ Just sc -> resolveSampler sc+ where+ resolveSampler SamplerAlwaysOn = alwaysOn+ resolveSampler SamplerAlwaysOff = alwaysOff+ resolveSampler (SamplerTraceIdRatioBased r) = traceIdRatioBased (ratioValue r)+ resolveSampler (SamplerParentBased pb) =+ parentBased+ ParentBasedOptions+ { rootSampler = maybe alwaysOn resolveSampler (pbRoot pb)+ , remoteParentSampled = maybe alwaysOn resolveSampler (pbRemoteParentSampled pb)+ , remoteParentNotSampled = maybe alwaysOff resolveSampler (pbRemoteParentNotSampled pb)+ , localParentSampled = maybe alwaysOn resolveSampler (pbLocalParentSampled pb)+ , localParentNotSampled = maybe alwaysOff resolveSampler (pbLocalParentNotSampled pb)+ }+++buildSpanLimits :: OTelConfiguration -> SpanLimits+buildSpanLimits cfg = case configTracerProvider cfg >>= tpLimits of+ Nothing -> defaultSpanLimits+ Just sl ->+ SpanLimits+ { spanAttributeValueLengthLimit = slAttributeValueLengthLimit sl+ , spanAttributeCountLimit = slAttributeCountLimit sl+ , eventCountLimit = slEventCountLimit sl+ , linkCountLimit = slLinkCountLimit sl+ , eventAttributeCountLimit = slEventAttributeCountLimit sl+ , linkAttributeCountLimit = slLinkAttributeCountLimit sl+ }+++buildSpanProcessors :: OTelConfiguration -> IO ([SpanProcessor], [IO ()])+buildSpanProcessors cfg = case configTracerProvider cfg >>= tpProcessors of+ Nothing -> pure ([], [])+ Just procs -> do+ results <- mapM buildOneSpanProcessor procs+ let (sps, shutdowns) = unzip (concatMap (maybe [] pure) results)+ pure (sps, shutdowns)+++buildOneSpanProcessor :: SpanProcessorConfig -> IO (Maybe (SpanProcessor, IO ()))+buildOneSpanProcessor (SpanProcessorBatch bsp) = do+ exporter <- buildSpanExporter (bspExporter bsp)+ let conf =+ batchTimeoutConfig+ { maxQueueSize = fromMaybe (maxQueueSize batchTimeoutConfig) (bspMaxQueueSize bsp)+ , scheduledDelayMillis = fromMaybe (scheduledDelayMillis batchTimeoutConfig) (bspScheduleDelay bsp)+ , exportTimeoutMillis = fromMaybe (exportTimeoutMillis batchTimeoutConfig) (bspExportTimeout bsp)+ , maxExportBatchSize = fromMaybe (maxExportBatchSize batchTimeoutConfig) (bspMaxExportBatchSize bsp)+ }+ processor <- batchProcessor conf exporter+ pure $ Just (processor, pure ())+buildOneSpanProcessor (SpanProcessorSimple ssp) = do+ exporter <- buildSpanExporter (sspExporter ssp)+ processor <- simpleProcessor SimpleProcessorConfig {spanExporter = exporter, simpleSpanExportTimeoutMicros = 30_000_000}+ pure $ Just (processor, pure ())+buildOneSpanProcessor SpanProcessorUnknown = do+ otelLogWarning "Unrecognized span processor type in configuration; this processor will be skipped"+ pure Nothing+++buildSpanExporter :: SpanExporterConfig -> IO SpanExporter+buildSpanExporter (SpanExporterOtlpHttp otlpCfg) = do+ let envConfig = otlpHttpToExporterConfig otlpCfg+ otlpExporter envConfig+buildSpanExporter (SpanExporterConsole _) = pure $ HandleSpan.stdoutExporter' HandleSpan.defaultFormatter+buildSpanExporter SpanExporterNone =+ pure $+ SpanExporter+ { spanExporterExport = \_ -> pure Success+ , spanExporterShutdown = pure ShutdownSuccess+ , spanExporterForceFlush = pure FlushSuccess+ }+++buildMeterProvider :: OTelConfiguration -> MaterializedResources -> IO MeterProvider+buildMeterProvider cfg res = case configMeterProvider cfg >>= mpReaders of+ Nothing -> do+ (mp, _env) <- createMeterProvider res defaultSdkMeterProviderOptions+ pure mp+ Just readers -> do+ case readers of+ [] -> do+ (mp, _env) <- createMeterProvider res defaultSdkMeterProviderOptions+ pure mp+ (MetricReaderPeriodic pmc : rest) -> do+ when (not (null rest)) $+ otelLogWarning "Multiple metric readers configured; only the first is currently supported — additional readers will be ignored"+ case pmrTimeout pmc of+ Just _ -> otelLogWarning "metric_reader.periodic.timeout is configured but not yet supported; the setting will be ignored"+ Nothing -> pure ()+ mExporter <- buildMetricExporter (pmrExporter pmc)+ case mExporter of+ Just ex -> do+ let opts = defaultSdkMeterProviderOptions {metricExporter = Just ex}+ (mp, env) <- createMeterProvider res opts+ let interval = fromMaybe 60000 (pmrInterval pmc)+ readerOpts = PeriodicMetricReaderOptions {periodicIntervalMicros = interval * 1000}+ handle <- forkPeriodicMetricReader env ex readerOpts+ pure+ mp+ { meterProviderShutdown = \mTimeout -> do+ stopPeriodicMetricReader handle+ meterProviderShutdown mp mTimeout+ }+ Nothing -> do+ (mp, _env) <- createMeterProvider res defaultSdkMeterProviderOptions+ pure mp+++buildMetricExporter :: PushMetricExporterConfig -> IO (Maybe MetricExporter)+buildMetricExporter (PushMetricExporterOtlpHttp otlpCfg) = do+ let envConfig = otlpHttpToExporterConfig otlpCfg+ ex <- otlpMetricExporter envConfig+ pure (Just ex)+buildMetricExporter (PushMetricExporterConsole _) = do+ ex <- HandleMetric.stdoutMetricExporter+ pure (Just ex)+buildMetricExporter PushMetricExporterNone = pure Nothing+++buildLoggerProvider :: OTelConfiguration -> AttributeLimits -> MaterializedResources -> IO (LoggerProvider, [IO ()])+buildLoggerProvider cfg attrLimits res = case configLoggerProvider cfg >>= lpProcessors of+ Nothing -> do+ lp <- createLoggerProvider [] (LoggerProviderOptions res attrLimits Nothing)+ pure (lp, [])+ Just procs -> do+ results <- mapM buildOneLogProcessor procs+ let (lps, shutdowns) = unzip (concatMap (maybe [] pure) results)+ lpOpts = LoggerProviderOptions res attrLimits Nothing+ lp <- createLoggerProvider lps lpOpts+ pure (lp, shutdowns)+++buildOneLogProcessor :: LogRecordProcessorConfig -> IO (Maybe (LogRecordProcessor, IO ()))+buildOneLogProcessor (LogRecordProcessorBatch blp) = do+ exporter <- buildLogExporter (blpExporter blp)+ let conf =+ BlogProc.BatchLogRecordProcessorConfig+ { BlogProc.batchLogExporter = exporter+ , BlogProc.batchLogMaxQueueSize = fromMaybe 2048 (blpMaxQueueSize blp)+ , BlogProc.batchLogScheduledDelayMillis = fromMaybe 1000 (blpScheduleDelay blp)+ , BlogProc.batchLogExportTimeoutMillis = fromMaybe 30000 (blpExportTimeout blp)+ , BlogProc.batchLogMaxExportBatchSize = fromMaybe 512 (blpMaxExportBatchSize blp)+ }+ processor <- batchLogRecordProcessor conf+ pure $ Just (processor, pure ())+buildOneLogProcessor (LogRecordProcessorSimple slp) = do+ exporter <- buildLogExporter (slpExporter slp)+ let conf = SlogProc.SimpleLogRecordProcessorConfig {SlogProc.simpleLogRecordExporter = exporter, SlogProc.simpleLogRecordExportTimeoutMicros = 30_000_000}+ processor <- SlogProc.simpleLogRecordProcessor conf+ pure $ Just (processor, pure ())+buildOneLogProcessor LogRecordProcessorUnknown = do+ otelLogWarning "Unrecognized log record processor type in configuration; this processor will be skipped"+ pure Nothing+++buildLogExporter :: LogRecordExporterConfig -> IO LogRecordExporter+buildLogExporter (LogRecordExporterOtlpHttp otlpCfg) = do+ let envConfig = otlpHttpToExporterConfig otlpCfg+ otlpLogRecordExporter envConfig+buildLogExporter (LogRecordExporterConsole _) = HandleLog.stdoutLogRecordExporter+buildLogExporter LogRecordExporterNone =+ mkLogRecordExporter+ LogRecordExporterArguments+ { logRecordExporterArgumentsExport = \_ -> pure Success+ , logRecordExporterArgumentsForceFlush = pure FlushSuccess+ , logRecordExporterArgumentsShutdown = pure ()+ }+++otlpHttpToExporterConfig :: OtlpHttpExporterConfig -> OTLPExporterConfig+otlpHttpToExporterConfig cfg' =+ OTLPExporterConfig+ { otlpEndpoint = fmap T.unpack (otlpCfgEndpoint cfg')+ , otlpTracesEndpoint = fmap T.unpack (otlpSignalEndpoint cfg')+ , otlpMetricsEndpoint = Nothing+ , otlpInsecure = False+ , otlpSpanInsecure = False+ , otlpMetricInsecure = False+ , otlpCertificate = Nothing+ , otlpTracesCertificate = Nothing+ , otlpMetricCertificate = Nothing+ , otlpHeaders = fmap headersFromMap (otlpCfgHeaders cfg')+ , otlpTracesHeaders = Nothing+ , otlpMetricsHeaders = Nothing+ , otlpCompression = otlpCfgCompression cfg' >>= parseCompression+ , otlpTracesCompression = Nothing+ , otlpMetricsCompression = Nothing+ , otlpTimeout = otlpCfgTimeout cfg'+ , otlpTracesTimeout = Nothing+ , otlpMetricsTimeout = Nothing+ , otlpProtocol = Nothing+ , otlpTracesProtocol = Nothing+ , otlpMetricsProtocol = Nothing+ }+++headersFromMap :: Map.Map Text Text -> [Header]+headersFromMap = map (\(k, v) -> (CI.mk (T.encodeUtf8 k), T.encodeUtf8 v)) . Map.toList+++parseCompression :: Text -> Maybe CompressionFormat+parseCompression t = case T.toLower t of+ "gzip" -> Just GZip+ "none" -> Just None+ _ -> Nothing
+ src/OpenTelemetry/Configuration/Parse.hs view
@@ -0,0 +1,398 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- | YAML configuration file parser with environment variable substitution.+Implements the "Parse" operation from the OpenTelemetry Configuration SDK spec.+See: https://opentelemetry.io/docs/specs/otel/configuration/sdk/#parse+-}+module OpenTelemetry.Configuration.Parse (+ parseConfigFile,+ parseConfigBytes,+ ConfigParseError (..),+) where++import Control.Exception (Exception, try)+import Data.Aeson (Object, Value (..))+import qualified Data.Aeson.Key as AesonKey+import qualified Data.Aeson.KeyMap as KM+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Scientific (toBoundedInteger, toRealFloat)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Text.IO as TIO+import qualified Data.Text.Lazy as TL+import Data.Text.Lazy.Builder (toLazyText)+import Data.Text.Lazy.Builder.Int (decimal)+import Data.Text.Lazy.Builder.RealFloat (realFloat)+import qualified Data.Vector as V+import qualified Data.Yaml as Yaml+import OpenTelemetry.Configuration.Types+import OpenTelemetry.Internal.Logging (otelLogWarning)+import System.Environment (lookupEnv)+++-- | @since 0.1.0.0+data ConfigParseError+ = ConfigFileNotFound !FilePath+ | ConfigYamlError !Text+ | ConfigValidationError !Text+ deriving (Show, Eq)+++instance Exception ConfigParseError+++{- | Parse a configuration file from a file path.+Performs environment variable substitution and validates the result.++@since 0.1.0.0+-}+parseConfigFile :: FilePath -> IO (Either ConfigParseError OTelConfiguration)+parseConfigFile path = do+ contentResult <- try (TIO.readFile path)+ case contentResult of+ Left (_ :: IOError) -> pure $ Left $ ConfigFileNotFound path+ Right content -> parseConfigBytes content+++{- | Parse configuration from YAML text content.++@since 0.1.0.0+-}+parseConfigBytes :: Text -> IO (Either ConfigParseError OTelConfiguration)+parseConfigBytes content = do+ substituted <- substituteEnvVars content+ case parseYamlToValue substituted of+ Left err -> pure $ Left $ ConfigYamlError err+ Right val -> pure $ valueToConfig val+++parseYamlToValue :: Text -> Either Text Value+parseYamlToValue input =+ case Yaml.decodeEither' (TE.encodeUtf8 input) of+ Left err -> Left (T.pack (Yaml.prettyPrintParseException err))+ Right val -> Right val+++{- | Substitute environment variable references in text.+Supports: ${VAR}, ${env:VAR}, ${VAR:-default}, ${env:VAR:-default}+-}+substituteEnvVars :: Text -> IO Text+substituteEnvVars input = go input T.empty+ where+ go remaining acc+ | T.null remaining = pure acc+ | otherwise =+ case T.breakOn "${" remaining of+ (before, "") -> pure (acc <> before)+ (before, withRef) ->+ let afterOpen = T.drop 2 withRef+ in case T.breakOn "}" afterOpen of+ (_, "") -> do+ otelLogWarning $ "Malformed environment variable reference in config (no closing '}'): " <> T.unpack withRef+ pure (acc <> remaining)+ (ref, afterClose) -> do+ val <- resolveRef ref+ go (T.drop 1 afterClose) (acc <> before <> val)++ resolveRef ref =+ let (varSpec, defaultVal) = splitDefault ref+ varName = T.strip $ case T.stripPrefix "env:" varSpec of+ Just name -> name+ Nothing -> varSpec+ in do+ result <- lookupEnv (T.unpack varName)+ pure $ case result of+ Just v -> T.pack v+ Nothing -> defaultVal++ splitDefault ref =+ case T.breakOn ":-" ref of+ (v, "") -> (v, T.empty)+ (v, rest) -> (v, T.drop 2 rest)+++-- | Convert a parsed JSON Value to an OTelConfiguration.+valueToConfig :: Value -> Either ConfigParseError OTelConfiguration+valueToConfig (Object obj) = do+ let fileFormat = getTextOr "file_format" "1.0" obj+ disabled = getBoolMaybe "disabled" obj+ attrLimits = case KM.lookup "attribute_limits" obj of+ Just (Object al) ->+ Just+ AttributeLimitsConfig+ { alAttributeValueLengthLimit = getIntMaybe "attribute_value_length_limit" al+ , alAttributeCountLimit = getIntMaybe "attribute_count_limit" al+ }+ _ -> Nothing+ resource = case KM.lookup "resource" obj of+ Just (Object r) ->+ Just+ ResourceConfig+ { resourceAttributes = case KM.lookup "attributes" r of+ Just (Object attrs) -> Just $ objectToTextMap attrs+ _ -> Nothing+ , resourceDetectors = case KM.lookup "detectors" r of+ Just (Array arr) -> Just $ V.toList $ V.mapMaybe getText arr+ _ -> Nothing+ , resourceSchemaUrl = getTextMaybe "schema_url" r+ }+ _ -> Nothing+ propagator = case KM.lookup "propagator" obj of+ Just (Object p) ->+ Just+ PropagatorConfig+ { propagatorComposite = case KM.lookup "composite" p of+ Just (Array arr) -> Just $ V.toList $ V.mapMaybe getText arr+ _ -> Nothing+ }+ _ -> Nothing+ tracerProvider = case KM.lookup "tracer_provider" obj of+ Just (Object tp) -> Just $ parseTracerProvider tp+ _ -> Nothing+ meterProvider = case KM.lookup "meter_provider" obj of+ Just (Object mp) -> Just $ parseMeterProvider mp+ _ -> Nothing+ loggerProvider = case KM.lookup "logger_provider" obj of+ Just (Object lp) -> Just $ parseLoggerProvider lp+ _ -> Nothing+ Right+ OTelConfiguration+ { configFileFormat = fileFormat+ , configDisabled = disabled+ , configAttributeLimits = attrLimits+ , configResource = resource+ , configPropagator = propagator+ , configTracerProvider = tracerProvider+ , configMeterProvider = meterProvider+ , configLoggerProvider = loggerProvider+ }+valueToConfig _ = Left $ ConfigValidationError "Top-level configuration must be a YAML mapping"+++parseTracerProvider :: Object -> TracerProviderConfig+parseTracerProvider obj =+ TracerProviderConfig+ { tpProcessors = case KM.lookup "processors" obj of+ Just (Array arr) -> Just $ V.toList $ V.map parseSpanProcessor arr+ _ -> Nothing+ , tpSampler = case KM.lookup "sampler" obj of+ Just (Object s) -> parseSamplerConfig s+ _ -> Nothing+ , tpLimits = case KM.lookup "limits" obj of+ Just (Object l) ->+ Just+ SpanLimitsConfig+ { slAttributeValueLengthLimit = getIntMaybe "attribute_value_length_limit" l+ , slAttributeCountLimit = getIntMaybe "attribute_count_limit" l+ , slEventCountLimit = getIntMaybe "event_count_limit" l+ , slLinkCountLimit = getIntMaybe "link_count_limit" l+ , slEventAttributeCountLimit = getIntMaybe "event_attribute_count_limit" l+ , slLinkAttributeCountLimit = getIntMaybe "link_attribute_count_limit" l+ }+ _ -> Nothing+ }+++parseSpanProcessor :: Value -> SpanProcessorConfig+parseSpanProcessor (Object obj) = case KM.lookup "batch" obj of+ Just (Object b) ->+ SpanProcessorBatch+ BatchSpanProcessorConfig+ { bspScheduleDelay = getIntMaybe "schedule_delay" b+ , bspExportTimeout = getIntMaybe "export_timeout" b+ , bspMaxQueueSize = getIntMaybe "max_queue_size" b+ , bspMaxExportBatchSize = getIntMaybe "max_export_batch_size" b+ , bspExporter = parseSpanExporter b+ }+ _ -> case KM.lookup "simple" obj of+ Just (Object s) ->+ SpanProcessorSimple+ SimpleSpanProcessorConfig+ { sspExporter = parseSpanExporter s+ }+ _ -> SpanProcessorUnknown+parseSpanProcessor _ = SpanProcessorUnknown+++parseSpanExporter :: Object -> SpanExporterConfig+parseSpanExporter obj = case KM.lookup "exporter" obj of+ Just (Object e) -> parseExporterChoice e SpanExporterOtlpHttp SpanExporterConsole SpanExporterNone+ _ -> SpanExporterNone+++parseExporterChoice+ :: Object+ -> (OtlpHttpExporterConfig -> a)+ -> (ConsoleExporterConfig -> a)+ -> a+ -> a+parseExporterChoice obj mkOtlp mkConsole fallback+ | Just v <- KM.lookup "otlp_http" obj = mkOtlp (parseOtlpConfig v)+ | Just _ <- KM.lookup "console" obj = mkConsole ConsoleExporterConfig+ | otherwise = fallback+++parseOtlpConfig :: Value -> OtlpHttpExporterConfig+parseOtlpConfig (Object o) =+ OtlpHttpExporterConfig+ { otlpCfgEndpoint = getTextMaybe "endpoint" o+ , otlpSignalEndpoint = Nothing+ , otlpCfgTimeout = getIntMaybe "timeout" o+ , otlpCfgCompression = getTextMaybe "compression" o+ , otlpCfgHeaders = case KM.lookup "headers" o of+ Just (Object h) -> Just $ objectToTextMap h+ _ -> Nothing+ }+parseOtlpConfig Null =+ OtlpHttpExporterConfig Nothing Nothing Nothing Nothing Nothing+parseOtlpConfig _ =+ OtlpHttpExporterConfig Nothing Nothing Nothing Nothing Nothing+++parseSamplerConfig :: Object -> Maybe SamplerConfig+parseSamplerConfig obj+ | Just _ <- KM.lookup "always_on" obj = Just SamplerAlwaysOn+ | Just _ <- KM.lookup "always_off" obj = Just SamplerAlwaysOff+ | Just (Object r) <- KM.lookup "trace_id_ratio_based" obj =+ case getDoubleMaybe "ratio" r of+ Just ratio -> Just $ SamplerTraceIdRatioBased (TraceIdRatioSamplerConfig ratio)+ Nothing -> Nothing+ | Just (Object p) <- KM.lookup "parent_based" obj =+ Just $+ SamplerParentBased+ ParentBasedSamplerConfig+ { pbRoot = case KM.lookup "root" p of+ Just (Object s) -> parseSamplerConfig s+ _ -> Nothing+ , pbRemoteParentSampled = case KM.lookup "remote_parent_sampled" p of+ Just (Object s) -> parseSamplerConfig s+ _ -> Nothing+ , pbRemoteParentNotSampled = case KM.lookup "remote_parent_not_sampled" p of+ Just (Object s) -> parseSamplerConfig s+ _ -> Nothing+ , pbLocalParentSampled = case KM.lookup "local_parent_sampled" p of+ Just (Object s) -> parseSamplerConfig s+ _ -> Nothing+ , pbLocalParentNotSampled = case KM.lookup "local_parent_not_sampled" p of+ Just (Object s) -> parseSamplerConfig s+ _ -> Nothing+ }+ | otherwise = Nothing+++parseMeterProvider :: Object -> MeterProviderConfig+parseMeterProvider obj =+ MeterProviderConfig+ { mpReaders = case KM.lookup "readers" obj of+ Just (Array arr) -> Just $ V.toList $ V.map parseMetricReader arr+ _ -> Nothing+ }+++parseMetricReader :: Value -> MetricReaderConfig+parseMetricReader (Object obj) = case KM.lookup "periodic" obj of+ Just (Object p) ->+ MetricReaderPeriodic+ PeriodicMetricReaderConfig+ { pmrInterval = getIntMaybe "interval" p+ , pmrTimeout = getIntMaybe "timeout" p+ , pmrExporter = parsePushMetricExporter p+ }+ _ -> MetricReaderPeriodic (PeriodicMetricReaderConfig Nothing Nothing PushMetricExporterNone)+parseMetricReader _ = MetricReaderPeriodic (PeriodicMetricReaderConfig Nothing Nothing PushMetricExporterNone)+++parsePushMetricExporter :: Object -> PushMetricExporterConfig+parsePushMetricExporter obj = case KM.lookup "exporter" obj of+ Just (Object e) -> parseExporterChoice e PushMetricExporterOtlpHttp PushMetricExporterConsole PushMetricExporterNone+ _ -> PushMetricExporterNone+++parseLoggerProvider :: Object -> LoggerProviderConfig+parseLoggerProvider obj =+ LoggerProviderConfig+ { lpProcessors = case KM.lookup "processors" obj of+ Just (Array arr) -> Just $ V.toList $ V.map parseLogRecordProcessor arr+ _ -> Nothing+ }+++parseLogRecordProcessor :: Value -> LogRecordProcessorConfig+parseLogRecordProcessor (Object obj) = case KM.lookup "batch" obj of+ Just (Object b) ->+ LogRecordProcessorBatch+ BatchLogRecordProcessorConfig+ { blpScheduleDelay = getIntMaybe "schedule_delay" b+ , blpExportTimeout = getIntMaybe "export_timeout" b+ , blpMaxQueueSize = getIntMaybe "max_queue_size" b+ , blpMaxExportBatchSize = getIntMaybe "max_export_batch_size" b+ , blpExporter = parseLogRecordExporter b+ }+ _ -> case KM.lookup "simple" obj of+ Just (Object s) ->+ LogRecordProcessorSimple+ SimpleLogRecordProcessorConfig+ { slpExporter = parseLogRecordExporter s+ }+ _ -> LogRecordProcessorUnknown+parseLogRecordProcessor _ = LogRecordProcessorUnknown+++parseLogRecordExporter :: Object -> LogRecordExporterConfig+parseLogRecordExporter obj = case KM.lookup "exporter" obj of+ Just (Object e) -> parseExporterChoice e LogRecordExporterOtlpHttp LogRecordExporterConsole LogRecordExporterNone+ _ -> LogRecordExporterNone+++-- Helpers++objectToTextMap :: Object -> Map Text Text+objectToTextMap = KM.foldrWithKey (\k v m -> Map.insert (AesonKey.toText k) (valueToText v) m) Map.empty+++valueToText :: Value -> Text+valueToText (String t) = t+valueToText (Number n) = case toBoundedInteger n :: Maybe Int of+ Just i -> TL.toStrict $ toLazyText $ decimal i+ Nothing -> TL.toStrict $ toLazyText $ realFloat (toRealFloat n :: Double)+valueToText (Bool True) = "true"+valueToText (Bool False) = "false"+valueToText Null = ""+valueToText _ = ""+++getText :: Value -> Maybe Text+getText (String t) = Just t+getText _ = Nothing+++getTextMaybe :: Text -> Object -> Maybe Text+getTextMaybe key obj = KM.lookup (AesonKey.fromText key) obj >>= getText+++getTextOr :: Text -> Text -> Object -> Text+getTextOr key def obj = case getTextMaybe key obj of+ Just v -> v+ Nothing -> def+++getIntMaybe :: Text -> Object -> Maybe Int+getIntMaybe key obj = case KM.lookup (AesonKey.fromText key) obj of+ Just (Number n) -> toBoundedInteger n+ _ -> Nothing+++getDoubleMaybe :: Text -> Object -> Maybe Double+getDoubleMaybe key obj = case KM.lookup (AesonKey.fromText key) obj of+ Just (Number n) -> Just (toRealFloat n)+ _ -> Nothing+++getBoolMaybe :: Text -> Object -> Maybe Bool+getBoolMaybe key obj = case KM.lookup (AesonKey.fromText key) obj of+ Just (Bool b) -> Just b+ _ -> Nothing
+ src/OpenTelemetry/Configuration/Types.hs view
@@ -0,0 +1,261 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++{- | In-memory representation of the OpenTelemetry declarative configuration model.+See: https://opentelemetry.io/docs/specs/otel/configuration/sdk/+-}+module OpenTelemetry.Configuration.Types (+ OTelConfiguration (..),+ AttributeLimitsConfig (..),+ ResourceConfig (..),+ PropagatorConfig (..),+ TracerProviderConfig (..),+ SpanProcessorConfig (..),+ BatchSpanProcessorConfig (..),+ SimpleSpanProcessorConfig (..),+ SpanExporterConfig (..),+ OtlpHttpExporterConfig (..),+ ConsoleExporterConfig (..),+ SamplerConfig (..),+ ParentBasedSamplerConfig (..),+ TraceIdRatioSamplerConfig (..),+ SpanLimitsConfig (..),+ MeterProviderConfig (..),+ MetricReaderConfig (..),+ PeriodicMetricReaderConfig (..),+ PushMetricExporterConfig (..),+ LoggerProviderConfig (..),+ LogRecordProcessorConfig (..),+ BatchLogRecordProcessorConfig (..),+ SimpleLogRecordProcessorConfig (..),+ LogRecordExporterConfig (..),+ emptyConfiguration,+) where++import qualified Data.Map.Strict as Map+import Data.Text (Text)+import GHC.Generics (Generic)+++-- | @since 0.1.0.0+data OTelConfiguration = OTelConfiguration+ { configFileFormat :: !Text+ , configDisabled :: !(Maybe Bool)+ , configAttributeLimits :: !(Maybe AttributeLimitsConfig)+ , configResource :: !(Maybe ResourceConfig)+ , configPropagator :: !(Maybe PropagatorConfig)+ , configTracerProvider :: !(Maybe TracerProviderConfig)+ , configMeterProvider :: !(Maybe MeterProviderConfig)+ , configLoggerProvider :: !(Maybe LoggerProviderConfig)+ }+ deriving (Show, Eq, Generic)+++-- | @since 0.1.0.0+data AttributeLimitsConfig = AttributeLimitsConfig+ { alAttributeValueLengthLimit :: !(Maybe Int)+ , alAttributeCountLimit :: !(Maybe Int)+ }+ deriving (Show, Eq, Generic)+++-- | @since 0.1.0.0+data ResourceConfig = ResourceConfig+ { resourceAttributes :: !(Maybe (Map.Map Text Text))+ , resourceDetectors :: !(Maybe [Text])+ , resourceSchemaUrl :: !(Maybe Text)+ }+ deriving (Show, Eq, Generic)+++-- | @since 0.1.0.0+newtype PropagatorConfig = PropagatorConfig+ { propagatorComposite :: Maybe [Text]+ }+ deriving (Show, Eq, Generic)+++-- | @since 0.1.0.0+data TracerProviderConfig = TracerProviderConfig+ { tpProcessors :: !(Maybe [SpanProcessorConfig])+ , tpSampler :: !(Maybe SamplerConfig)+ , tpLimits :: !(Maybe SpanLimitsConfig)+ }+ deriving (Show, Eq, Generic)+++-- | @since 0.1.0.0+data SpanProcessorConfig+ = SpanProcessorBatch !BatchSpanProcessorConfig+ | SpanProcessorSimple !SimpleSpanProcessorConfig+ | -- | Unrecognized processor type in the config file; will be skipped with a warning.+ SpanProcessorUnknown+ deriving (Show, Eq, Generic)+++-- | @since 0.1.0.0+data BatchSpanProcessorConfig = BatchSpanProcessorConfig+ { bspScheduleDelay :: !(Maybe Int)+ , bspExportTimeout :: !(Maybe Int)+ , bspMaxQueueSize :: !(Maybe Int)+ , bspMaxExportBatchSize :: !(Maybe Int)+ , bspExporter :: !SpanExporterConfig+ }+ deriving (Show, Eq, Generic)+++-- | @since 0.1.0.0+newtype SimpleSpanProcessorConfig = SimpleSpanProcessorConfig+ { sspExporter :: SpanExporterConfig+ }+ deriving (Show, Eq, Generic)+++-- | @since 0.1.0.0+data SpanExporterConfig+ = SpanExporterOtlpHttp !OtlpHttpExporterConfig+ | SpanExporterConsole !ConsoleExporterConfig+ | SpanExporterNone+ deriving (Show, Eq, Generic)+++-- | @since 0.1.0.0+data OtlpHttpExporterConfig = OtlpHttpExporterConfig+ { otlpCfgEndpoint :: !(Maybe Text)+ , otlpSignalEndpoint :: !(Maybe Text)+ , otlpCfgTimeout :: !(Maybe Int)+ , otlpCfgCompression :: !(Maybe Text)+ , otlpCfgHeaders :: !(Maybe (Map.Map Text Text))+ }+ deriving (Show, Eq, Generic)+++-- | @since 0.1.0.0+data ConsoleExporterConfig = ConsoleExporterConfig+ deriving (Show, Eq, Generic)+++-- | @since 0.1.0.0+data SamplerConfig+ = SamplerAlwaysOn+ | SamplerAlwaysOff+ | SamplerTraceIdRatioBased !TraceIdRatioSamplerConfig+ | SamplerParentBased !ParentBasedSamplerConfig+ deriving (Show, Eq, Generic)+++-- | @since 0.1.0.0+data ParentBasedSamplerConfig = ParentBasedSamplerConfig+ { pbRoot :: !(Maybe SamplerConfig)+ , pbRemoteParentSampled :: !(Maybe SamplerConfig)+ , pbRemoteParentNotSampled :: !(Maybe SamplerConfig)+ , pbLocalParentSampled :: !(Maybe SamplerConfig)+ , pbLocalParentNotSampled :: !(Maybe SamplerConfig)+ }+ deriving (Show, Eq, Generic)+++-- | @since 0.1.0.0+newtype TraceIdRatioSamplerConfig = TraceIdRatioSamplerConfig+ { ratioValue :: Double+ }+ deriving (Show, Eq, Generic)+++-- | @since 0.1.0.0+data SpanLimitsConfig = SpanLimitsConfig+ { slAttributeValueLengthLimit :: !(Maybe Int)+ , slAttributeCountLimit :: !(Maybe Int)+ , slEventCountLimit :: !(Maybe Int)+ , slLinkCountLimit :: !(Maybe Int)+ , slEventAttributeCountLimit :: !(Maybe Int)+ , slLinkAttributeCountLimit :: !(Maybe Int)+ }+ deriving (Show, Eq, Generic)+++-- | @since 0.1.0.0+data MeterProviderConfig = MeterProviderConfig+ { mpReaders :: !(Maybe [MetricReaderConfig])+ }+ deriving (Show, Eq, Generic)+++-- | @since 0.1.0.0+newtype MetricReaderConfig+ = MetricReaderPeriodic PeriodicMetricReaderConfig+ deriving (Show, Eq, Generic)+++-- | @since 0.1.0.0+data PeriodicMetricReaderConfig = PeriodicMetricReaderConfig+ { pmrInterval :: !(Maybe Int)+ , pmrTimeout :: !(Maybe Int)+ , pmrExporter :: !PushMetricExporterConfig+ }+ deriving (Show, Eq, Generic)+++-- | @since 0.1.0.0+data PushMetricExporterConfig+ = PushMetricExporterOtlpHttp !OtlpHttpExporterConfig+ | PushMetricExporterConsole !ConsoleExporterConfig+ | PushMetricExporterNone+ deriving (Show, Eq, Generic)+++-- | @since 0.1.0.0+data LoggerProviderConfig = LoggerProviderConfig+ { lpProcessors :: !(Maybe [LogRecordProcessorConfig])+ }+ deriving (Show, Eq, Generic)+++-- | @since 0.1.0.0+data LogRecordProcessorConfig+ = LogRecordProcessorBatch !BatchLogRecordProcessorConfig+ | LogRecordProcessorSimple !SimpleLogRecordProcessorConfig+ | -- | Unrecognized processor type in the config file; will be skipped with a warning.+ LogRecordProcessorUnknown+ deriving (Show, Eq, Generic)+++-- | @since 0.1.0.0+data BatchLogRecordProcessorConfig = BatchLogRecordProcessorConfig+ { blpScheduleDelay :: !(Maybe Int)+ , blpExportTimeout :: !(Maybe Int)+ , blpMaxQueueSize :: !(Maybe Int)+ , blpMaxExportBatchSize :: !(Maybe Int)+ , blpExporter :: !LogRecordExporterConfig+ }+ deriving (Show, Eq, Generic)+++-- | @since 0.1.0.0+newtype SimpleLogRecordProcessorConfig = SimpleLogRecordProcessorConfig+ { slpExporter :: LogRecordExporterConfig+ }+ deriving (Show, Eq, Generic)+++-- | @since 0.1.0.0+data LogRecordExporterConfig+ = LogRecordExporterOtlpHttp !OtlpHttpExporterConfig+ | LogRecordExporterConsole !ConsoleExporterConfig+ | LogRecordExporterNone+ deriving (Show, Eq, Generic)+++-- | @since 0.1.0.0+emptyConfiguration :: OTelConfiguration+emptyConfiguration =+ OTelConfiguration+ { configFileFormat = "1.0"+ , configDisabled = Nothing+ , configAttributeLimits = Nothing+ , configResource = Nothing+ , configPropagator = Nothing+ , configTracerProvider = Nothing+ , configMeterProvider = Nothing+ , configLoggerProvider = Nothing+ }
+ src/OpenTelemetry/Log.hs view
@@ -0,0 +1,301 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- |+Module : OpenTelemetry.Log+Copyright : (c) Ian Duncan, 2026+License : BSD-3+Description : OpenTelemetry Logs SDK — batteries-included setup+Stability : experimental++= Overview++This is the main entry point for connecting logging systems to OpenTelemetry.+It re-exports the Logs Bridge API from "OpenTelemetry.Log.Core" and adds+SDK-level initialization with env-var configuration.++Note: this is the /Logs Bridge API/ — it is intended for logging library+authors who want to route log records through the OpenTelemetry pipeline+(processors, exporters, trace correlation). End users typically interact+with their existing logging framework, which uses this bridge internally.++= Quick example++@+{\-# LANGUAGE OverloadedStrings #-\}+module Main where++import OpenTelemetry.Log++main :: IO ()+main = withLoggerProvider $ \\lp -> do+ let logger = makeLogger lp "my-app"+ emitLogRecord logger $ emptyLogRecordArguments+ { body = Just (toValue ("Application started" :: Text))+ , severityNumber = Just SeverityNumberInfo+ }+ -- ... application code ...+@++'withLoggerProvider' reads configuration from @OTEL_*@ environment variables,+sets up a batch log record processor with an OTLP exporter, and ensures+shutdown on exit.++If you also use 'OpenTelemetry.Trace.withTracerProvider', it already sets up+a 'LoggerProvider' for you — use this module when you need logs without+traces, or want explicit control.++= Configuration++| Variable | Default | Description |+|---|---|---|+| @OTEL_SDK_DISABLED@ | @false@ | Disable all telemetry |+| @OTEL_LOGS_EXPORTER@ | @otlp@ | @otlp@, @console@, @none@ |+| @OTEL_BLRP_MAX_QUEUE_SIZE@ | @2048@ | Batch processor queue size |+| @OTEL_BLRP_SCHEDULE_DELAY_MILLIS@ | @1000@ | Batch export delay (ms). Legacy alias: @OTEL_BLRP_SCHEDULE_DELAY@ |+| @OTEL_BLRP_EXPORT_TIMEOUT_MILLIS@ | @30000@ | Export timeout (ms). Legacy alias: @OTEL_BLRP_EXPORT_TIMEOUT@ |+| @OTEL_BLRP_MAX_EXPORT_BATCH_SIZE@ | @512@ | Max records per batch (clamped to queue size) |+| @OTEL_LOGRECORD_ATTRIBUTE_COUNT_LIMIT@ | @128@ | Max attributes per log record. Falls back to @OTEL_ATTRIBUTE_COUNT_LIMIT@ |+| @OTEL_LOGRECORD_ATTRIBUTE_VALUE_LENGTH_LIMIT@ | no limit | Max attribute value length. Falls back to @OTEL_ATTRIBUTE_VALUE_LENGTH_LIMIT@ |++= Spec reference++<https://opentelemetry.io/docs/specs/otel/logs/sdk/>+-}+module OpenTelemetry.Log (+ -- * Provider lifecycle+ withLoggerProvider,+ initializeGlobalLoggerProvider,++ -- * Logs Bridge API (re-exported from "OpenTelemetry.Log.Core")++ -- ** LoggerProvider+ LoggerProvider (..),+ LoggerProviderOptions (..),+ emptyLoggerProviderOptions,+ createLoggerProvider,+ setGlobalLoggerProvider,+ getGlobalLoggerProvider,+ shutdownLoggerProvider,++ -- ** Logger+ Logger (..),+ makeLogger,+ getLogger,+ loggerIsEnabled,+ loggerIsEnabled',+ setLoggerMinSeverity,+ getLoggerMinSeverity,++ -- ** LogRecord+ ReadableLogRecord,+ ReadWriteLogRecord,+ IsReadableLogRecord (..),+ IsReadWriteLogRecord (..),+ LogRecordArguments (..),+ emptyLogRecordArguments,+ AnyValue (..),+ ToValue (..),+ SeverityNumber (..),+ toShortName,+ emitLogRecord,+ addAttribute,+ addAttributes,+ logRecordGetAttributes,++ -- * Processors++ -- ** Batch processor+ BatchLogRecordProcessorConfig (..),+ defaultBatchLogRecordProcessorConfig,+ batchLogRecordProcessor,++ -- ** Simple processor+ SimpleLogRecordProcessorConfig (..),+ simpleLogRecordProcessor,++ -- * Common types+ InstrumentationLibrary (..),+ instrumentationLibrary,+ withSchemaUrl,+ withLibraryAttributes,+ ShutdownResult (..),+ FlushResult (..),+) where++import Control.Applicative ((<|>))+import Control.Exception (bracket)+import Control.Monad (void, when)+import qualified Data.HashMap.Strict as H+import Data.Maybe (fromMaybe)+import qualified Data.Text as T+import OpenTelemetry.Attributes (AttributeLimits (..), defaultAttributeLimits)+import OpenTelemetry.Environment (LogsExporterSelection (..), lookupBooleanEnv, lookupLogsExporterSelection)+import OpenTelemetry.Exporter.Handle.LogRecord (stdoutLogRecordExporter)+import OpenTelemetry.Exporter.OTLP.LogRecord (otlpLogRecordExporter)+import OpenTelemetry.Exporter.OTLP.Span (loadExporterEnvironmentVariables)+import OpenTelemetry.Internal.Common.Types (FlushResult (..))+import OpenTelemetry.Internal.Log.Types (LogRecordExporter, emptyLogRecordArguments)+import OpenTelemetry.Internal.Logging (otelLogDebug, otelLogWarning)+import OpenTelemetry.Log.Core+import OpenTelemetry.Processor.Batch.LogRecord (BatchLogRecordProcessorConfig (..), batchLogRecordProcessor, defaultBatchLogRecordProcessorConfig)+import OpenTelemetry.Processor.Simple.LogRecord (SimpleLogRecordProcessorConfig (..), simpleLogRecordProcessor)+import qualified OpenTelemetry.Registry as Registry+import OpenTelemetry.Resource (materializeResources, mergeResources, mkResource)+import OpenTelemetry.Resource.Detect (detectBuiltInResources, detectResourceAttributes)+import System.Environment (lookupEnv)+import Text.Read (readMaybe)+++{- | Initialize a 'LoggerProvider' from environment variables, set it as the+global logger provider, and run an action. The provider is shut down on exit+(including exceptions).++@+main :: IO ()+main = withLoggerProvider $ \\lp -> do+ let logger = makeLogger lp "my-service"+ emitLogRecord logger ...+@++@since 0.0.1.0+-}+withLoggerProvider :: (LoggerProvider -> IO a) -> IO a+withLoggerProvider =+ bracket+ initializeGlobalLoggerProvider+ (\lp -> void $ shutdownLoggerProvider lp Nothing)+++{- | Create a 'LoggerProvider' from @OTEL_*@ environment variables and install+it as the global provider via 'setGlobalLoggerProvider'.++Returns the 'LoggerProvider'. The caller must call 'shutdownLoggerProvider'+when the application exits.++Reads:++* @OTEL_SDK_DISABLED@ — if @true@, returns an empty provider+* @OTEL_LOGS_EXPORTER@ — selects the exporter (default: @otlp@)+* @OTEL_BLRP_MAX_QUEUE_SIZE@, @OTEL_BLRP_SCHEDULE_DELAY_MILLIS@,+ @OTEL_BLRP_EXPORT_TIMEOUT_MILLIS@, @OTEL_BLRP_MAX_EXPORT_BATCH_SIZE@ —+ batch processor configuration+* @OTEL_LOGRECORD_ATTRIBUTE_COUNT_LIMIT@, @OTEL_LOGRECORD_ATTRIBUTE_VALUE_LENGTH_LIMIT@ —+ signal-specific attribute limits (fall back to @OTEL_ATTRIBUTE_COUNT_LIMIT@ /+ @OTEL_ATTRIBUTE_VALUE_LENGTH_LIMIT@)++@since 0.0.1.0+-}+initializeGlobalLoggerProvider :: IO LoggerProvider+initializeGlobalLoggerProvider = do+ disabled <- lookupBooleanEnv "OTEL_SDK_DISABLED"+ if disabled+ then do+ otelLogDebug "OTEL_SDK_DISABLED=true, using empty LoggerProvider"+ lp <- createLoggerProvider [] emptyLoggerProviderOptions+ setGlobalLoggerProvider lp+ pure lp+ else do+ lp <- initializeLoggerProvider+ setGlobalLoggerProvider lp+ otelLogDebug "LoggerProvider initialized from environment"+ pure lp+++-- Internal: create provider from env vars+initializeLoggerProvider :: IO LoggerProvider+initializeLoggerProvider = do+ attrLimits <- detectLogRecordAttributeLimits+ builtInRs <- detectBuiltInResources+ envVarRs <- mkResource . map Just <$> detectResourceAttributes+ let rs = materializeResources (mergeResources envVarRs builtInRs)+ opts =+ emptyLoggerProviderOptions+ { loggerProviderOptionsResource = rs+ , loggerProviderOptionsAttributeLimits = attrLimits+ }+ sel <- lookupLogsExporterSelection+ case sel of+ Just LogsExporterNone -> createLoggerProvider [] opts+ _ -> do+ exporter <- detectLogExporter sel+ blrpConf <- detectBatchLogProcessorConfig exporter+ processor <- batchLogRecordProcessor blrpConf+ createLoggerProvider [processor] opts+++detectLogExporter :: Maybe LogsExporterSelection -> IO LogRecordExporter+detectLogExporter sel = do+ registerBuiltinLogExporters+ let lookupByName name = do+ allExporters <- Registry.registeredLogRecordExporterFactories+ case H.lookup name allExporters of+ Just factory -> factory+ Nothing -> do+ otelLogWarning ("No log exporter registered for '" <> T.unpack name <> "', using console")+ stdoutLogRecordExporter+ case sel of+ Just LogsExporterConsole -> stdoutLogRecordExporter+ Just (LogsExporterCustom name) -> lookupByName (T.pack name)+ _ -> lookupByName "otlp"+++registerBuiltinLogExporters :: IO ()+registerBuiltinLogExporters = do+ _ <-+ Registry.registerLogRecordExporterFactoryIfAbsent "otlp" $ do+ otlpConfig <- loadExporterEnvironmentVariables+ otlpLogRecordExporter otlpConfig+ _ <-+ Registry.registerLogRecordExporterFactoryIfAbsent+ "console"+ stdoutLogRecordExporter+ pure ()+++detectBatchLogProcessorConfig :: LogRecordExporter -> IO BatchLogRecordProcessorConfig+detectBatchLogProcessorConfig exporter = do+ queueSize <- readEnvDefault "OTEL_BLRP_MAX_QUEUE_SIZE" 2048+ delay <- readEnvDefaultWithAlias "OTEL_BLRP_SCHEDULE_DELAY_MILLIS" "OTEL_BLRP_SCHEDULE_DELAY" 1000+ exportTimeout <- readEnvDefaultWithAlias "OTEL_BLRP_EXPORT_TIMEOUT_MILLIS" "OTEL_BLRP_EXPORT_TIMEOUT" 30000+ rawBatchSize <- readEnvDefault "OTEL_BLRP_MAX_EXPORT_BATCH_SIZE" 512+ let batchSize = min rawBatchSize queueSize+ when (rawBatchSize > queueSize) $+ otelLogWarning ("OTEL_BLRP_MAX_EXPORT_BATCH_SIZE (" <> show rawBatchSize <> ") exceeds OTEL_BLRP_MAX_QUEUE_SIZE (" <> show queueSize <> "), clamping to " <> show batchSize)+ pure (BatchLogRecordProcessorConfig exporter queueSize delay exportTimeout batchSize)+++{- | Detect attribute limits for log records from environment variables.++Signal-specific vars take precedence over general vars, per the spec:++@OTEL_LOGRECORD_ATTRIBUTE_COUNT_LIMIT@ > @OTEL_ATTRIBUTE_COUNT_LIMIT@ > 128+@OTEL_LOGRECORD_ATTRIBUTE_VALUE_LENGTH_LIMIT@ > @OTEL_ATTRIBUTE_VALUE_LENGTH_LIMIT@ > no limit+-}+detectLogRecordAttributeLimits :: IO AttributeLimits+detectLogRecordAttributeLimits = do+ generalCount <- readEnvMaybe "OTEL_ATTRIBUTE_COUNT_LIMIT"+ logCount <- readEnvMaybe "OTEL_LOGRECORD_ATTRIBUTE_COUNT_LIMIT"+ generalLength <- readEnvMaybe "OTEL_ATTRIBUTE_VALUE_LENGTH_LIMIT"+ logLength <- readEnvMaybe "OTEL_LOGRECORD_ATTRIBUTE_VALUE_LENGTH_LIMIT"+ pure+ AttributeLimits+ { attributeCountLimit = logCount <|> generalCount <|> attributeCountLimit defaultAttributeLimits+ , attributeLengthLimit = logLength <|> generalLength+ }+ where+ readEnvMaybe :: (Read a) => String -> IO (Maybe a)+ readEnvMaybe k = (>>= readMaybe) <$> lookupEnv k+++readEnvDefault :: forall a. (Read a) => String -> a -> IO a+readEnvDefault k defaultValue =+ fromMaybe defaultValue . (>>= readMaybe) <$> lookupEnv k+++readEnvDefaultWithAlias :: forall a. (Read a) => String -> String -> a -> IO a+readEnvDefaultWithAlias primary fallback defaultValue = do+ mv <- lookupEnv primary+ case mv >>= readMaybe of+ Just v -> pure v+ Nothing -> readEnvDefault fallback defaultValue
+ src/OpenTelemetry/MeterProvider.hs view
@@ -0,0 +1,1325 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}++{- | SDK 'OpenTelemetry.Metric.Core.MeterProvider' with in-process aggregation (specification/metrics/sdk.md).++ Synchronous: cumulative or delta sums, explicit or exponential histograms, last-value gauges;+ exemplars (optional trace context); cardinality limits; views (drop, aggregation, attribute keys).+ Observable callbacks run in registration order. Periodic export: "OpenTelemetry.MetricReader".+-}+module OpenTelemetry.MeterProvider (+ SdkMeterProviderOptions (..),+ defaultSdkMeterProviderOptions,+ SdkMeterExemplarOptions (..),+ defaultSdkMeterExemplarOptions,+ SdkMeterEnv (..),+ emptyStorageState,+ createMeterProvider,+ collectResourceMetrics,+ MetricReader (..),+ cumulativeTemporality,+ deltaTemporality,+) where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.ByteString (ByteString)+import Data.Foldable (toList)+import qualified Data.HashMap.Strict as H+import qualified Data.HashSet as HS+import Data.Hashable (Hashable)+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)+import Data.Int (Int32, Int64)+import qualified Data.IntMap.Strict as IM+import Data.Maybe (fromMaybe)+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import Data.Text (Text, pack)+import Data.Vector (Vector)+import qualified Data.Vector as V+import Data.Word (Word64)+import GHC.Generics (Generic)+import OpenTelemetry.Attributes (Attributes, addAttribute, defaultAttributeLimits, emptyAttributes)+import OpenTelemetry.Context (lookupSpan)+import OpenTelemetry.Context.ThreadLocal (getContext)+import OpenTelemetry.Environment (MetricsExemplarFilter (..), lookupMetricsExemplarFilter)+import OpenTelemetry.Exporter.Metric (+ AggregationTemporality (..),+ ExponentialHistogramDataPoint (..),+ GaugeDataPoint (..),+ HistogramDataPoint (..),+ MetricExemplar (..),+ MetricExport (..),+ MetricExporter (..),+ NumberValue (..),+ ResourceMetricsExport (..),+ ScopeMetricsExport (..),+ SumDataPoint (..),+ filterAttributesByKeys,+ )+import OpenTelemetry.Internal.Common.Types (FlushResult (..), InstrumentationLibrary (..), ShutdownResult (..))+import OpenTelemetry.Metric.Core (+ AdvisoryParameters (..),+ Counter (..),+ Gauge (..),+ Histogram (..),+ HistogramAggregation (..),+ InstrumentKind (..),+ Meter (..),+ MeterProvider (..),+ ObservableCallbackHandle (..),+ ObservableCounter (..),+ ObservableGauge (..),+ ObservableResult (..),+ ObservableUpDownCounter (..),+ UpDownCounter (..),+ noopMeter,+ )+import qualified OpenTelemetry.Metric.InstrumentName as VName+import OpenTelemetry.Metric.View (View (..), ViewAggregation (..), findMatchingView, viewOverrideDescription, viewOverrideName)+import OpenTelemetry.Resource (MaterializedResources)+import OpenTelemetry.Trace.Core (SpanContext (..), getSpanContext, isValid)+import OpenTelemetry.Trace.Id (spanIdBytes, traceIdBytes)+import System.Clock (Clock (Realtime), getTime, toNanoSecs)+++data SdkMeterExemplarOptions = SdkMeterExemplarOptions+ { exemplarFilter :: !MetricsExemplarFilter+ -- ^ Spec default is TraceBased. Configured via OTEL_METRICS_EXEMPLAR_FILTER or explicit option.+ , exemplarReservoirLimit :: !Int+ }+++defaultSdkMeterExemplarOptions :: SdkMeterExemplarOptions+defaultSdkMeterExemplarOptions =+ SdkMeterExemplarOptions+ { exemplarFilter = MetricsExemplarFilterTraceBased+ , exemplarReservoirLimit = 1+ }+++data MetricReader = MetricReader+ { metricReaderExporter :: !MetricExporter+ , metricReaderTemporalityFor :: !(InstrumentKind -> AggregationTemporality)+ }+++cumulativeTemporality :: InstrumentKind -> AggregationTemporality+cumulativeTemporality _ = AggregationCumulative+++deltaTemporality :: InstrumentKind -> AggregationTemporality+deltaTemporality _ = AggregationDelta+++data SdkMeterProviderOptions = SdkMeterProviderOptions+ { cardinalityLimit :: !Int+ , aggregationTemporality :: !AggregationTemporality+ , views :: ![View]+ , exemplarOptions :: !SdkMeterExemplarOptions+ , metricExporter :: !(Maybe MetricExporter)+ }+++defaultSdkMeterProviderOptions :: SdkMeterProviderOptions+defaultSdkMeterProviderOptions =+ SdkMeterProviderOptions+ { cardinalityLimit = 2000+ , aggregationTemporality = AggregationCumulative+ , views = []+ , exemplarOptions = defaultSdkMeterExemplarOptions+ , metricExporter = Nothing+ }+++data SdkMeterStorageState = SdkMeterStorageState+ { storageCells :: !(H.HashMap DimKey Cell)+ , seriesCountByDims :: !(H.HashMap InstrumentDims Int)+ }+++emptyStorageState :: SdkMeterStorageState+emptyStorageState =+ SdkMeterStorageState+ { storageCells = H.empty+ , seriesCountByDims = H.empty+ }+++data SdkMeterEnv = SdkMeterEnv+ { sdkMeterStorage :: !(IORef SdkMeterStorageState)+ , sdkMeterCollectCallbacks :: !(IORef (Seq (IO ())))+ , sdkMeterResource :: !MaterializedResources+ , sdkMeterShutdown :: !(IORef Bool)+ , sdkMeterCardinalityLimit :: !Int+ , sdkMeterAggregationTemporality :: !AggregationTemporality+ , sdkMeterViews :: ![View]+ , sdkMeterExemplarOptions :: !SdkMeterExemplarOptions+ , sdkMeterStartTimeNanos :: !Word64+ }+++data InstrumentDims = InstrumentDims+ { dimScope :: !InstrumentationLibrary+ , dimName :: !Text+ , dimKind :: !InstrumentKind+ , dimUnit :: !Text+ , dimDescription :: !Text+ , dimHistogramAggregation :: !(Maybe HistogramAggregation)+ , dimExportAttributeKeys :: !(Maybe (HS.HashSet Text))+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (Hashable)+++type DimKey = (InstrumentDims, Attributes)+++data SumCell = SumCell+ { scValue :: !(Either Int64 Double)+ , scMonotonic :: !Bool+ , scExemplars :: !(Vector MetricExemplar)+ }+++data HistCell = HistCell+ { hcBuckets :: !(Vector Word64)+ , hcBounds :: !(Vector Double)+ , hcSum :: !Double+ , hcCount :: !Word64+ , hcMin :: !(Maybe Double)+ , hcMax :: !(Maybe Double)+ , hcExemplars :: !(Vector MetricExemplar)+ }+++data ExpHistCell = ExpHistCell+ { ehcScale :: !Int32+ , ehcPositive :: !(IM.IntMap Word64)+ , ehcNegative :: !(IM.IntMap Word64)+ , ehcZeroCount :: !Word64+ , ehcSum :: !Double+ , ehcCount :: !Word64+ , ehcMin :: !(Maybe Double)+ , ehcMax :: !(Maybe Double)+ , ehcExemplars :: !(Vector MetricExemplar)+ }+++data GaugeCell = GaugeCell+ { gcValue :: !NumberValue+ , gcTimeUnixNano :: !Word64+ , gcExemplars :: !(Vector MetricExemplar)+ }+++data Cell+ = CsSum !SumCell+ | CsHist !HistCell+ | CsExpHist !ExpHistCell+ | CsGauge !GaugeCell+++nowNanos :: IO Word64+nowNanos = do+ t <- getTime Realtime+ pure $ fromIntegral (toNanoSecs t)+++defaultHistogramBounds :: Vector Double+defaultHistogramBounds =+ V.fromList [0, 5, 10, 25, 50, 75, 100, 250, 500, 750, 1000, 2500, 5000, 7500, 10000]+++canAcceptNewSeries :: Int -> DimKey -> SdkMeterStorageState -> Bool+canAcceptNewSeries lim k@(dims, _) st+ | H.member k (storageCells st) = True+ | lim <= 0 = True+ | otherwise = H.lookupDefault 0 dims (seriesCountByDims st) < lim+++overflowAttributes :: Attributes+overflowAttributes =+ addAttribute defaultAttributeLimits emptyAttributes (pack "otel.metric.overflow") True+++overflowKey :: InstrumentDims -> DimKey+overflowKey dims = (dims, overflowAttributes)+++bumpSeriesCount :: InstrumentDims -> H.HashMap InstrumentDims Int -> H.HashMap InstrumentDims Int+bumpSeriesCount dims sc =+ let n = H.lookupDefault 0 dims sc+ in H.insert dims (n + 1) sc+++bucketIndex :: Vector Double -> Double -> Int+bucketIndex bounds v =+ let n = V.length bounds+ in case V.findIndex (\b -> v <= b) bounds of+ Just i -> i+ Nothing -> n+++emptyHist :: Vector Double -> HistCell+emptyHist bounds =+ HistCell+ { hcBuckets = V.replicate (V.length bounds + 1) 0+ , hcBounds = bounds+ , hcSum = 0+ , hcCount = 0+ , hcMin = Nothing+ , hcMax = Nothing+ , hcExemplars = V.empty+ }+++emptyExpHist :: Int32 -> ExpHistCell+emptyExpHist sc =+ ExpHistCell+ { ehcScale = sc+ , ehcPositive = IM.empty+ , ehcNegative = IM.empty+ , ehcZeroCount = 0+ , ehcSum = 0+ , ehcCount = 0+ , ehcMin = Nothing+ , ehcMax = Nothing+ , ehcExemplars = V.empty+ }+++positiveBucketIndex :: Double -> Int32 -> Int+positiveBucketIndex x sc =+ floor (logBase 2 x * (2 ** (fromIntegral sc :: Double)) :: Double)+++mergeExpHist :: ExpHistCell -> Double -> ExpHistCell+mergeExpHist ehc v =+ let sc = ehcScale ehc+ upd =+ if v == 0+ then ehc {ehcZeroCount = ehcZeroCount ehc + 1}+ else+ if v > 0+ then+ let idx = positiveBucketIndex v sc+ in ehc {ehcPositive = IM.insertWith (+) idx 1 (ehcPositive ehc)}+ else+ let idx = positiveBucketIndex (abs v) sc+ in ehc {ehcNegative = IM.insertWith (+) idx 1 (ehcNegative ehc)}+ sm = ehcSum ehc + v+ ct = ehcCount ehc + 1+ in upd+ { ehcSum = sm+ , ehcCount = ct+ , ehcMin = minMaybe (ehcMin ehc) v+ , ehcMax = maxMaybe (ehcMax ehc) v+ }+++intMapToOffsetCounts :: IM.IntMap Word64 -> (Int32, Vector Word64)+intMapToOffsetCounts mp =+ if IM.null mp+ then (0, V.empty)+ else+ let (minK, _) = IM.findMin mp+ (maxK, _) = IM.findMax mp+ width = maxK - minK + 1+ vec =+ V.generate width $ \i ->+ IM.findWithDefault 0 (minK + i) mp+ in (fromIntegral minK, vec)+++expHistToDataPoint+ :: Word64+ -> Word64+ -> Attributes+ -> ExpHistCell+ -> ExponentialHistogramDataPoint+expHistToDataPoint startT t attrs ehc =+ let (posOff, posVec) = intMapToOffsetCounts (ehcPositive ehc)+ (negOff, negVec) = intMapToOffsetCounts (ehcNegative ehc)+ in ExponentialHistogramDataPoint+ { exponentialHistogramDataPointStartTimeUnixNano = startT+ , exponentialHistogramDataPointTimeUnixNano = t+ , exponentialHistogramDataPointCount = ehcCount ehc+ , exponentialHistogramDataPointSum = Just (ehcSum ehc)+ , exponentialHistogramDataPointScale = ehcScale ehc+ , exponentialHistogramDataPointZeroCount = ehcZeroCount ehc+ , exponentialHistogramDataPointPositiveOffset = posOff+ , exponentialHistogramDataPointPositiveBucketCounts = posVec+ , exponentialHistogramDataPointNegativeOffset = negOff+ , exponentialHistogramDataPointNegativeBucketCounts = negVec+ , exponentialHistogramDataPointAttributes = attrs+ , exponentialHistogramDataPointMin = ehcMin ehc+ , exponentialHistogramDataPointMax = ehcMax ehc+ , exponentialHistogramDataPointExemplars = ehcExemplars ehc+ , exponentialHistogramDataPointZeroThreshold = 0+ }+++minMaybe :: Maybe Double -> Double -> Maybe Double+minMaybe Nothing v = Just v+minMaybe (Just a) v = Just (min a v)+++maxMaybe :: Maybe Double -> Double -> Maybe Double+maxMaybe Nothing v = Just v+maxMaybe (Just a) v = Just (max a v)+++validateOrNoop :: Text -> Maybe Text -> IO Bool+validateOrNoop name mUnit =+ case VName.validateInstrumentName name of+ Just _ -> pure False+ Nothing -> case mUnit of+ Nothing -> pure True+ Just u -> case VName.validateInstrumentUnit u of+ Just _ -> pure False+ Nothing -> pure True+++dimsFrom+ :: InstrumentationLibrary+ -> Text+ -> InstrumentKind+ -> Maybe Text+ -> Maybe Text+ -> Maybe HistogramAggregation+ -> Maybe (HS.HashSet Text)+ -> InstrumentDims+dimsFrom scope name kind mUnit mDesc mh mKeys =+ InstrumentDims+ { dimScope = scope+ , dimName = name+ , dimKind = kind+ , dimUnit = fromMaybe mempty mUnit+ , dimDescription = fromMaybe mempty mDesc+ , dimHistogramAggregation = mh+ , dimExportAttributeKeys = mKeys+ }+++shouldDropInstrument :: [View] -> InstrumentKind -> Text -> Bool+shouldDropInstrument views kind name =+ case findMatchingView views kind name of+ Just v | viewAggregation v == ViewAggregationDrop -> True+ _ -> False+++{- | Resolve attribute key filtering. Spec: view attribute_keys take precedence;+if absent, fall back to advisory Attributes parameter; if absent, keep all.+-}+exportKeysFor :: [View] -> InstrumentKind -> Text -> AdvisoryParameters -> Maybe [Text]+exportKeysFor views kind name adv =+ case findMatchingView views kind name of+ Nothing -> advisoryAttributeKeys adv+ Just v -> case viewAttributeKeys v of+ Just ks -> Just ks+ Nothing -> advisoryAttributeKeys adv+++fromAdvisoryHistogram :: AdvisoryParameters -> HistogramAggregation+fromAdvisoryHistogram a = case advisoryHistogramAggregation a of+ Just h -> h+ Nothing -> case advisoryExplicitBucketBoundaries a of+ Just bs -> HistogramAggregationExplicit (V.fromList bs)+ Nothing -> HistogramAggregationExplicit defaultHistogramBounds+++resolveHistogramAggregation :: [View] -> Text -> AdvisoryParameters -> Either () HistogramAggregation+resolveHistogramAggregation views name adv =+ case findMatchingView views KindHistogram name of+ Just v -> case viewAggregation v of+ ViewAggregationDrop -> Left ()+ ViewAggregationExplicitBucketHistogram bs -> Right (HistogramAggregationExplicit (V.fromList bs))+ ViewAggregationExponentialHistogram sc -> Right (HistogramAggregationExponential sc)+ ViewAggregationDefault -> Right (fromAdvisoryHistogram adv)+ Nothing -> Right (fromAdvisoryHistogram adv)+++pushExemplar :: Int -> MetricExemplar -> Vector MetricExemplar -> Vector MetricExemplar+pushExemplar cap e v+ | cap <= 0 = V.empty+ | V.length v < cap = V.snoc v e+ | otherwise = V.snoc (V.tail v) e+++captureMetricExemplar+ :: SdkMeterExemplarOptions+ -> Maybe NumberValue+ -> IO (Maybe MetricExemplar)+captureMetricExemplar opts mVal =+ case exemplarFilter opts of+ MetricsExemplarFilterAlwaysOff -> pure Nothing+ MetricsExemplarFilterAlwaysOn -> do+ ctx <- getContext+ case lookupSpan ctx of+ Nothing -> makeExemplarNoTrace+ Just sp -> do+ scx <- getSpanContext sp+ makeExemplarWithContext scx+ MetricsExemplarFilterTraceBased -> do+ ctx <- getContext+ case lookupSpan ctx of+ Nothing -> pure Nothing+ Just sp -> do+ scx <- getSpanContext sp+ if not (isValid scx)+ then pure Nothing+ else makeExemplarWithContext scx+ where+ makeExemplarWithContext scx = do+ t <- nowNanos+ let tid :: ByteString+ tid = traceIdBytes (traceId scx)+ sid :: ByteString+ sid = spanIdBytes (spanId scx)+ pure $+ Just $+ MetricExemplar+ { metricExemplarTraceId = tid+ , metricExemplarSpanId = sid+ , metricExemplarTimeUnixNano = t+ , metricExemplarFilteredAttributes = emptyAttributes+ , metricExemplarValue = mVal+ }+ makeExemplarNoTrace = do+ t <- nowNanos+ pure $+ Just $+ MetricExemplar+ { metricExemplarTraceId = mempty+ , metricExemplarSpanId = mempty+ , metricExemplarTimeUnixNano = t+ , metricExemplarFilteredAttributes = emptyAttributes+ , metricExemplarValue = mVal+ }+++addSumInt+ :: Int64+ -> Bool+ -> Maybe NumberValue+ -> DimKey+ -> IORef SdkMeterStorageState+ -> Int+ -> SdkMeterExemplarOptions+ -> IO ()+addSumInt delta isMonotonic mExVal k ref lim exOpts = do+ mex <- captureMetricExemplar exOpts mExVal+ let cap = exemplarReservoirLimit exOpts+ atomicModifyIORef' ref $ \st ->+ let effectiveK = if canAcceptNewSeries lim k st then k else overflowKey (fst k)+ in let m = storageCells st+ scount = seriesCountByDims st+ newCell = case H.lookup effectiveK m of+ Nothing ->+ CsSum $+ SumCell+ { scValue = Left delta+ , scMonotonic = isMonotonic+ , scExemplars = maybe V.empty (\e -> pushExemplar cap e V.empty) mex+ }+ Just (CsSum sc) ->+ CsSum $+ sc+ { scValue = addEither (scValue sc) (Left delta)+ , scExemplars = case mex of+ Nothing -> scExemplars sc+ Just e -> pushExemplar cap e (scExemplars sc)+ }+ Just _ ->+ CsSum $+ SumCell (Left delta) isMonotonic (maybe V.empty (\e -> pushExemplar cap e V.empty) mex)+ isNew = not (H.member effectiveK m)+ m' = H.insert effectiveK newCell m+ sc' = if isNew then bumpSeriesCount (fst effectiveK) scount else scount+ in (SdkMeterStorageState m' sc', ())+++addSumDbl+ :: Double+ -> Bool+ -> Maybe NumberValue+ -> DimKey+ -> IORef SdkMeterStorageState+ -> Int+ -> SdkMeterExemplarOptions+ -> IO ()+addSumDbl delta isMonotonic mExVal k ref lim exOpts = do+ mex <- captureMetricExemplar exOpts mExVal+ let cap = exemplarReservoirLimit exOpts+ atomicModifyIORef' ref $ \st ->+ let effectiveK = if canAcceptNewSeries lim k st then k else overflowKey (fst k)+ in let m = storageCells st+ scount = seriesCountByDims st+ newCell = case H.lookup effectiveK m of+ Nothing ->+ CsSum $+ SumCell+ { scValue = Right delta+ , scMonotonic = isMonotonic+ , scExemplars = maybe V.empty (\e -> pushExemplar cap e V.empty) mex+ }+ Just (CsSum sc) ->+ CsSum $+ sc+ { scValue = addEither (scValue sc) (Right delta)+ , scExemplars = case mex of+ Nothing -> scExemplars sc+ Just e -> pushExemplar cap e (scExemplars sc)+ }+ Just _ ->+ CsSum $+ SumCell (Right delta) isMonotonic (maybe V.empty (\e -> pushExemplar cap e V.empty) mex)+ isNew = not (H.member effectiveK m)+ m' = H.insert effectiveK newCell m+ sc' = if isNew then bumpSeriesCount (fst effectiveK) scount else scount+ in (SdkMeterStorageState m' sc', ())+++addEither :: Either Int64 Double -> Either Int64 Double -> Either Int64 Double+addEither (Left a) (Left b) = Left (a + b)+addEither (Left a) (Right b) = Right (fromIntegral a + b)+addEither (Right a) (Left b) = Right (a + fromIntegral b)+addEither (Right a) (Right b) = Right (a + b)+++mergeHist :: HistCell -> Double -> HistCell+mergeHist hc v =+ let idx = bucketIndex (hcBounds hc) v+ b' = V.accum (+) (hcBuckets hc) [(idx, 1)]+ sm = hcSum hc + v+ ct = hcCount hc + 1+ in hc+ { hcBuckets = b'+ , hcSum = sm+ , hcCount = ct+ , hcMin = minMaybe (hcMin hc) v+ , hcMax = maxMaybe (hcMax hc) v+ }+++recordHist+ :: Vector Double+ -> Double+ -> Maybe Double+ -> DimKey+ -> IORef SdkMeterStorageState+ -> Int+ -> SdkMeterExemplarOptions+ -> IO ()+recordHist bounds v mExVal k ref lim exOpts = do+ if isNaN v || isInfinite v+ then pure ()+ else do+ mex <- captureMetricExemplar exOpts (fmap DoubleNumber mExVal)+ let cap = exemplarReservoirLimit exOpts+ atomicModifyIORef' ref $ \st ->+ let effectiveK = if canAcceptNewSeries lim k st then k else overflowKey (fst k)+ in let m = storageCells st+ scount = seriesCountByDims st+ mergeE hc = case mex of+ Nothing -> hc+ Just e -> hc {hcExemplars = pushExemplar cap e (hcExemplars hc)}+ newCell = case H.lookup effectiveK m of+ Nothing -> CsHist (mergeE (mergeHist (emptyHist bounds) v))+ Just (CsHist hc) -> CsHist (mergeE (mergeHist hc v))+ Just _ -> CsHist (mergeE (mergeHist (emptyHist bounds) v))+ isNew = not (H.member effectiveK m)+ m' = H.insert effectiveK newCell m+ sc' = if isNew then bumpSeriesCount (fst effectiveK) scount else scount+ in (SdkMeterStorageState m' sc', ())+++recordExpHist+ :: Int32+ -> Double+ -> Maybe Double+ -> DimKey+ -> IORef SdkMeterStorageState+ -> Int+ -> SdkMeterExemplarOptions+ -> IO ()+recordExpHist sc v mExVal k ref lim exOpts = do+ if isNaN v || isInfinite v+ then pure ()+ else do+ mex <- captureMetricExemplar exOpts (fmap DoubleNumber mExVal)+ let cap = exemplarReservoirLimit exOpts+ atomicModifyIORef' ref $ \st ->+ let effectiveK = if canAcceptNewSeries lim k st then k else overflowKey (fst k)+ in let m = storageCells st+ scount = seriesCountByDims st+ mergeE ehc = case mex of+ Nothing -> ehc+ Just e -> ehc {ehcExemplars = pushExemplar cap e (ehcExemplars ehc)}+ newCell = case H.lookup effectiveK m of+ Nothing -> CsExpHist (mergeE (mergeExpHist (emptyExpHist sc) v))+ Just (CsExpHist ehc) -> CsExpHist (mergeE (mergeExpHist ehc v))+ Just _ -> CsExpHist (mergeE (mergeExpHist (emptyExpHist sc) v))+ isNew = not (H.member effectiveK m)+ m' = H.insert effectiveK newCell m+ sc' = if isNew then bumpSeriesCount (fst effectiveK) scount else scount+ in (SdkMeterStorageState m' sc', ())+++recordGauge+ :: NumberValue+ -> Word64+ -> Maybe NumberValue+ -> DimKey+ -> IORef SdkMeterStorageState+ -> Int+ -> SdkMeterExemplarOptions+ -> IO ()+recordGauge val t mExVal k ref lim exOpts = do+ mex <- captureMetricExemplar exOpts mExVal+ let cap = exemplarReservoirLimit exOpts+ atomicModifyIORef' ref $ \st ->+ let effectiveK = if canAcceptNewSeries lim k st then k else overflowKey (fst k)+ in let m = storageCells st+ scount = seriesCountByDims st+ newGauge gc =+ case mex of+ Nothing -> gc {gcValue = val, gcTimeUnixNano = t}+ Just e ->+ gc+ { gcValue = val+ , gcTimeUnixNano = t+ , gcExemplars = pushExemplar cap e (gcExemplars gc)+ }+ newCell = case H.lookup effectiveK m of+ Nothing ->+ CsGauge+ GaugeCell+ { gcValue = val+ , gcTimeUnixNano = t+ , gcExemplars = maybe V.empty (\e -> pushExemplar cap e V.empty) mex+ }+ Just (CsGauge gc) -> CsGauge (newGauge gc)+ Just _ ->+ CsGauge+ GaugeCell+ { gcValue = val+ , gcTimeUnixNano = t+ , gcExemplars = maybe V.empty (\e -> pushExemplar cap e V.empty) mex+ }+ isNew = not (H.member effectiveK m)+ m' = H.insert effectiveK newCell m+ sc' = if isNew then bumpSeriesCount (fst effectiveK) scount else scount+ in (SdkMeterStorageState m' sc', ())+++resetCellForDelta :: Cell -> Cell+resetCellForDelta = \case+ CsSum sc ->+ CsSum+ sc+ { scValue = case scValue sc of+ Left {} -> Left 0+ Right {} -> Right 0+ , scExemplars = V.empty+ }+ CsHist hc ->+ CsHist (emptyHist (hcBounds hc))+ CsExpHist ehc ->+ CsExpHist (emptyExpHist (ehcScale ehc))+ CsGauge gc ->+ CsGauge gc+++applyDeltaReset :: SdkMeterStorageState -> SdkMeterStorageState+applyDeltaReset st =+ SdkMeterStorageState+ { storageCells = H.map resetCellForDelta (storageCells st)+ , seriesCountByDims = seriesCountByDims st+ }+++mkMeter :: SdkMeterEnv -> InstrumentationLibrary -> Meter+mkMeter env scope =+ Meter+ { meterInstrumentationScope = scope+ , meterCreateCounterInt64 = mkCounterI64 env scope KindCounter True True+ , meterCreateCounterDouble = mkCounterDbl env scope KindCounter True False+ , meterCreateUpDownCounterInt64 = mkUpDownI64 env scope+ , meterCreateUpDownCounterDouble = mkUpDownDbl env scope+ , meterCreateHistogram = mkHistogram env scope+ , meterCreateGaugeInt64 = mkGaugeI64 env scope+ , meterCreateGaugeDouble = mkGaugeDbl env scope+ , meterCreateObservableCounterInt64 = mkObsCounterI64 env scope+ , meterCreateObservableCounterDouble = mkObsCounterDbl env scope+ , meterCreateObservableUpDownCounterInt64 = mkObsUDCI64 env scope+ , meterCreateObservableUpDownCounterDouble = mkObsUDCDbl env scope+ , meterCreateObservableGaugeInt64 = mkObsGaugeI64 env scope+ , meterCreateObservableGaugeDouble = mkObsGaugeDbl env scope+ }+ where+ views = sdkMeterViews env+ exOpts = sdkMeterExemplarOptions env++ mkCounterI64 :: SdkMeterEnv -> InstrumentationLibrary -> InstrumentKind -> Bool -> Bool -> Text -> Maybe Text -> Maybe Text -> AdvisoryParameters -> IO (Counter Int64)+ mkCounterI64 e sc k mono _isInt name mUnit mDesc adv = do+ if shouldDropInstrument views k name+ then pure $ Counter (\_ _ -> pure ()) (pure False)+ else do+ ok <- validateOrNoop name mUnit+ if ok+ then do+ let vName = viewOverrideName views k name+ vDesc = viewOverrideDescription views k name mDesc+ dims =+ dimsFrom sc vName k mUnit vDesc Nothing (HS.fromList <$> exportKeysFor views k name adv)+ ref = sdkMeterStorage e+ lim = sdkMeterCardinalityLimit e+ pure $+ Counter+ { counterAdd = \n attrs ->+ addSumInt n mono (Just (IntNumber n)) (dims, attrs) ref lim exOpts+ , counterEnabled = pure True+ }+ else pure $ Counter (\_ _ -> pure ()) (pure False)++ mkCounterDbl :: SdkMeterEnv -> InstrumentationLibrary -> InstrumentKind -> Bool -> Bool -> Text -> Maybe Text -> Maybe Text -> AdvisoryParameters -> IO (Counter Double)+ mkCounterDbl e sc k mono _isInt name mUnit mDesc adv = do+ if shouldDropInstrument views k name+ then pure $ Counter (\_ _ -> pure ()) (pure False)+ else do+ ok <- validateOrNoop name mUnit+ if ok+ then do+ let vName = viewOverrideName views k name+ vDesc = viewOverrideDescription views k name mDesc+ dims =+ dimsFrom sc vName k mUnit vDesc Nothing (HS.fromList <$> exportKeysFor views k name adv)+ ref = sdkMeterStorage e+ lim = sdkMeterCardinalityLimit e+ pure $+ Counter+ { counterAdd = \v attrs ->+ addSumDbl v mono (Just (DoubleNumber v)) (dims, attrs) ref lim exOpts+ , counterEnabled = pure True+ }+ else pure $ Counter (\_ _ -> pure ()) (pure False)++ mkUpDownI64 :: SdkMeterEnv -> InstrumentationLibrary -> Text -> Maybe Text -> Maybe Text -> AdvisoryParameters -> IO (UpDownCounter Int64)+ mkUpDownI64 e sc name mUnit mDesc adv = do+ if shouldDropInstrument views KindUpDownCounter name+ then pure $ UpDownCounter (\_ _ -> pure ()) (pure False)+ else do+ ok <- validateOrNoop name mUnit+ if ok+ then do+ let vName = viewOverrideName views KindUpDownCounter name+ vDesc = viewOverrideDescription views KindUpDownCounter name mDesc+ dims =+ dimsFrom sc vName KindUpDownCounter mUnit vDesc Nothing (HS.fromList <$> exportKeysFor views KindUpDownCounter name adv)+ ref = sdkMeterStorage e+ lim = sdkMeterCardinalityLimit e+ pure $+ UpDownCounter+ { upDownCounterAdd = \n attrs ->+ addSumInt n False (Just (IntNumber n)) (dims, attrs) ref lim exOpts+ , upDownCounterEnabled = pure True+ }+ else pure $ UpDownCounter (\_ _ -> pure ()) (pure False)++ mkUpDownDbl :: SdkMeterEnv -> InstrumentationLibrary -> Text -> Maybe Text -> Maybe Text -> AdvisoryParameters -> IO (UpDownCounter Double)+ mkUpDownDbl e sc name mUnit mDesc adv = do+ if shouldDropInstrument views KindUpDownCounter name+ then pure $ UpDownCounter (\_ _ -> pure ()) (pure False)+ else do+ ok <- validateOrNoop name mUnit+ if ok+ then do+ let vName = viewOverrideName views KindUpDownCounter name+ vDesc = viewOverrideDescription views KindUpDownCounter name mDesc+ dims =+ dimsFrom sc vName KindUpDownCounter mUnit vDesc Nothing (HS.fromList <$> exportKeysFor views KindUpDownCounter name adv)+ ref = sdkMeterStorage e+ lim = sdkMeterCardinalityLimit e+ pure $+ UpDownCounter+ { upDownCounterAdd = \v attrs ->+ addSumDbl v False (Just (DoubleNumber v)) (dims, attrs) ref lim exOpts+ , upDownCounterEnabled = pure True+ }+ else pure $ UpDownCounter (\_ _ -> pure ()) (pure False)++ mkHistogram :: SdkMeterEnv -> InstrumentationLibrary -> Text -> Maybe Text -> Maybe Text -> AdvisoryParameters -> IO Histogram+ mkHistogram e sc name mUnit mDesc adv = do+ if shouldDropInstrument views KindHistogram name+ then pure $ Histogram (\_ _ -> pure ()) (pure False)+ else do+ ok <- validateOrNoop name mUnit+ if not ok+ then pure $ Histogram (\_ _ -> pure ()) (pure False)+ else case resolveHistogramAggregation views name adv of+ Left () -> pure $ Histogram (\_ _ -> pure ()) (pure False)+ Right agg -> do+ let vName = viewOverrideName views KindHistogram name+ vDesc = viewOverrideDescription views KindHistogram name mDesc+ dimsBase =+ dimsFrom sc vName KindHistogram mUnit vDesc (Just agg) (HS.fromList <$> exportKeysFor views KindHistogram name adv)+ ref = sdkMeterStorage e+ lim = sdkMeterCardinalityLimit e+ case agg of+ HistogramAggregationExplicit bounds ->+ pure $+ Histogram+ { histogramRecord = \v attrs ->+ recordHist bounds v (Just v) (dimsBase, attrs) ref lim exOpts+ , histogramEnabled = pure True+ }+ HistogramAggregationExponential scale ->+ pure $+ Histogram+ { histogramRecord = \v attrs ->+ recordExpHist scale v (Just v) (dimsBase, attrs) ref lim exOpts+ , histogramEnabled = pure True+ }++ mkGaugeI64 :: SdkMeterEnv -> InstrumentationLibrary -> Text -> Maybe Text -> Maybe Text -> AdvisoryParameters -> IO (Gauge Int64)+ mkGaugeI64 e sc name mUnit mDesc adv = do+ if shouldDropInstrument views KindGauge name+ then pure $ Gauge (\_ _ -> pure ()) (pure False)+ else do+ ok <- validateOrNoop name mUnit+ if ok+ then do+ let vName = viewOverrideName views KindGauge name+ vDesc = viewOverrideDescription views KindGauge name mDesc+ dims =+ dimsFrom sc vName KindGauge mUnit vDesc Nothing (HS.fromList <$> exportKeysFor views KindGauge name adv)+ ref = sdkMeterStorage e+ lim = sdkMeterCardinalityLimit e+ pure $+ Gauge+ { gaugeRecord = \n attrs -> do+ t <- nowNanos+ recordGauge (IntNumber n) t (Just (IntNumber n)) (dims, attrs) ref lim exOpts+ , gaugeEnabled = pure True+ }+ else pure $ Gauge (\_ _ -> pure ()) (pure False)++ mkGaugeDbl :: SdkMeterEnv -> InstrumentationLibrary -> Text -> Maybe Text -> Maybe Text -> AdvisoryParameters -> IO (Gauge Double)+ mkGaugeDbl e sc name mUnit mDesc adv = do+ if shouldDropInstrument views KindGauge name+ then pure $ Gauge (\_ _ -> pure ()) (pure False)+ else do+ ok <- validateOrNoop name mUnit+ if ok+ then do+ let vName = viewOverrideName views KindGauge name+ vDesc = viewOverrideDescription views KindGauge name mDesc+ dims =+ dimsFrom sc vName KindGauge mUnit vDesc Nothing (HS.fromList <$> exportKeysFor views KindGauge name adv)+ ref = sdkMeterStorage e+ lim = sdkMeterCardinalityLimit e+ pure $+ Gauge+ { gaugeRecord = \v attrs -> do+ t <- nowNanos+ recordGauge (DoubleNumber v) t (Just (DoubleNumber v)) (dims, attrs) ref lim exOpts+ , gaugeEnabled = pure True+ }+ else pure $ Gauge (\_ _ -> pure ()) (pure False)++ registerCollect :: IO () -> IO ()+ registerCollect act =+ atomicModifyIORef' (sdkMeterCollectCallbacks env) $ \s -> (s Seq.|> act, ())++ obsEnabled :: InstrumentKind -> Text -> IO Bool+ obsEnabled k name = pure $ not (shouldDropInstrument views k name)++ mkObsCounterI64 :: SdkMeterEnv -> InstrumentationLibrary -> Text -> Maybe Text -> Maybe Text -> AdvisoryParameters -> [ObservableResult Int64 -> IO ()] -> IO (ObservableCounter Int64)+ mkObsCounterI64 e sc name mUnit mDesc adv cbs = do+ ok <- validateOrNoop name mUnit+ if not ok+ then pure $ ObservableCounter (\_ -> pure (ObservableCallbackHandle (pure ()))) sc name (pure False)+ else do+ let vName = viewOverrideName views KindAsyncCounter name+ vDesc = viewOverrideDescription views KindAsyncCounter name mDesc+ dims =+ dimsFrom sc vName KindAsyncCounter mUnit vDesc Nothing (HS.fromList <$> exportKeysFor views KindAsyncCounter name adv)+ ref = sdkMeterStorage e+ lim = sdkMeterCardinalityLimit e+ res = ObservableResult $ \n attrs ->+ addSumInt n True (Just (IntNumber n)) (dims, attrs) ref lim exOpts+ run = mapM_ ($ res) cbs+ registerCollect run+ en <- obsEnabled KindAsyncCounter name+ pure $+ ObservableCounter+ { observableCounterRegisterCallback = \cb -> do+ registerCollect (cb res)+ pure (ObservableCallbackHandle (pure ()))+ , observableCounterInstrumentScope = sc+ , observableCounterInstrumentName = name+ , observableCounterEnabled = pure en+ }++ mkObsCounterDbl :: SdkMeterEnv -> InstrumentationLibrary -> Text -> Maybe Text -> Maybe Text -> AdvisoryParameters -> [ObservableResult Double -> IO ()] -> IO (ObservableCounter Double)+ mkObsCounterDbl e sc name mUnit mDesc adv cbs = do+ ok <- validateOrNoop name mUnit+ if not ok+ then pure $ ObservableCounter (\_ -> pure (ObservableCallbackHandle (pure ()))) sc name (pure False)+ else do+ let vName = viewOverrideName views KindAsyncCounter name+ vDesc = viewOverrideDescription views KindAsyncCounter name mDesc+ dims =+ dimsFrom sc vName KindAsyncCounter mUnit vDesc Nothing (HS.fromList <$> exportKeysFor views KindAsyncCounter name adv)+ ref = sdkMeterStorage e+ lim = sdkMeterCardinalityLimit e+ res = ObservableResult $ \v attrs ->+ addSumDbl v True (Just (DoubleNumber v)) (dims, attrs) ref lim exOpts+ run = mapM_ ($ res) cbs+ registerCollect run+ en <- obsEnabled KindAsyncCounter name+ pure $+ ObservableCounter+ { observableCounterRegisterCallback = \cb -> do+ registerCollect (cb res)+ pure (ObservableCallbackHandle (pure ()))+ , observableCounterInstrumentScope = sc+ , observableCounterInstrumentName = name+ , observableCounterEnabled = pure en+ }++ mkObsUDCI64 :: SdkMeterEnv -> InstrumentationLibrary -> Text -> Maybe Text -> Maybe Text -> AdvisoryParameters -> [ObservableResult Int64 -> IO ()] -> IO (ObservableUpDownCounter Int64)+ mkObsUDCI64 e sc name mUnit mDesc adv cbs = do+ ok <- validateOrNoop name mUnit+ if not ok+ then pure $ ObservableUpDownCounter (\_ -> pure (ObservableCallbackHandle (pure ()))) sc name (pure False)+ else do+ let vName = viewOverrideName views KindAsyncUpDownCounter name+ vDesc = viewOverrideDescription views KindAsyncUpDownCounter name mDesc+ dims =+ dimsFrom sc vName KindAsyncUpDownCounter mUnit vDesc Nothing (HS.fromList <$> exportKeysFor views KindAsyncUpDownCounter name adv)+ ref = sdkMeterStorage e+ lim = sdkMeterCardinalityLimit e+ res = ObservableResult $ \n attrs ->+ addSumInt n False (Just (IntNumber n)) (dims, attrs) ref lim exOpts+ run = mapM_ ($ res) cbs+ registerCollect run+ en <- obsEnabled KindAsyncUpDownCounter name+ pure $+ ObservableUpDownCounter+ { observableUpDownCounterRegisterCallback = \cb -> do+ registerCollect (cb res)+ pure (ObservableCallbackHandle (pure ()))+ , observableUpDownCounterInstrumentScope = sc+ , observableUpDownCounterInstrumentName = name+ , observableUpDownCounterEnabled = pure en+ }++ mkObsUDCDbl :: SdkMeterEnv -> InstrumentationLibrary -> Text -> Maybe Text -> Maybe Text -> AdvisoryParameters -> [ObservableResult Double -> IO ()] -> IO (ObservableUpDownCounter Double)+ mkObsUDCDbl e sc name mUnit mDesc adv cbs = do+ ok <- validateOrNoop name mUnit+ if not ok+ then pure $ ObservableUpDownCounter (\_ -> pure (ObservableCallbackHandle (pure ()))) sc name (pure False)+ else do+ let vName = viewOverrideName views KindAsyncUpDownCounter name+ vDesc = viewOverrideDescription views KindAsyncUpDownCounter name mDesc+ dims =+ dimsFrom sc vName KindAsyncUpDownCounter mUnit vDesc Nothing (HS.fromList <$> exportKeysFor views KindAsyncUpDownCounter name adv)+ ref = sdkMeterStorage e+ lim = sdkMeterCardinalityLimit e+ res = ObservableResult $ \v attrs ->+ addSumDbl v False (Just (DoubleNumber v)) (dims, attrs) ref lim exOpts+ run = mapM_ ($ res) cbs+ registerCollect run+ en <- obsEnabled KindAsyncUpDownCounter name+ pure $+ ObservableUpDownCounter+ { observableUpDownCounterRegisterCallback = \cb -> do+ registerCollect (cb res)+ pure (ObservableCallbackHandle (pure ()))+ , observableUpDownCounterInstrumentScope = sc+ , observableUpDownCounterInstrumentName = name+ , observableUpDownCounterEnabled = pure en+ }++ mkObsGaugeI64 :: SdkMeterEnv -> InstrumentationLibrary -> Text -> Maybe Text -> Maybe Text -> AdvisoryParameters -> [ObservableResult Int64 -> IO ()] -> IO (ObservableGauge Int64)+ mkObsGaugeI64 e sc name mUnit mDesc adv cbs = do+ ok <- validateOrNoop name mUnit+ if not ok+ then pure $ ObservableGauge (\_ -> pure (ObservableCallbackHandle (pure ()))) sc name (pure False)+ else do+ let vName = viewOverrideName views KindAsyncGauge name+ vDesc = viewOverrideDescription views KindAsyncGauge name mDesc+ dims =+ dimsFrom sc vName KindAsyncGauge mUnit vDesc Nothing (HS.fromList <$> exportKeysFor views KindAsyncGauge name adv)+ ref = sdkMeterStorage e+ lim = sdkMeterCardinalityLimit e+ res = ObservableResult $ \n attrs -> do+ t <- nowNanos+ recordGauge (IntNumber n) t (Just (IntNumber n)) (dims, attrs) ref lim exOpts+ run = mapM_ ($ res) cbs+ registerCollect run+ en <- obsEnabled KindAsyncGauge name+ pure $+ ObservableGauge+ { observableGaugeRegisterCallback = \cb -> do+ registerCollect (cb res)+ pure (ObservableCallbackHandle (pure ()))+ , observableGaugeInstrumentScope = sc+ , observableGaugeInstrumentName = name+ , observableGaugeEnabled = pure en+ }++ mkObsGaugeDbl :: SdkMeterEnv -> InstrumentationLibrary -> Text -> Maybe Text -> Maybe Text -> AdvisoryParameters -> [ObservableResult Double -> IO ()] -> IO (ObservableGauge Double)+ mkObsGaugeDbl e sc name mUnit mDesc adv cbs = do+ ok <- validateOrNoop name mUnit+ if not ok+ then pure $ ObservableGauge (\_ -> pure (ObservableCallbackHandle (pure ()))) sc name (pure False)+ else do+ let vName = viewOverrideName views KindAsyncGauge name+ vDesc = viewOverrideDescription views KindAsyncGauge name mDesc+ dims =+ dimsFrom sc vName KindAsyncGauge mUnit vDesc Nothing (HS.fromList <$> exportKeysFor views KindAsyncGauge name adv)+ ref = sdkMeterStorage e+ lim = sdkMeterCardinalityLimit e+ res = ObservableResult $ \v attrs -> do+ t <- nowNanos+ recordGauge (DoubleNumber v) t (Just (DoubleNumber v)) (dims, attrs) ref lim exOpts+ run = mapM_ ($ res) cbs+ registerCollect run+ en <- obsEnabled KindAsyncGauge name+ pure $+ ObservableGauge+ { observableGaugeRegisterCallback = \cb -> do+ registerCollect (cb res)+ pure (ObservableCallbackHandle (pure ()))+ , observableGaugeInstrumentScope = sc+ , observableGaugeInstrumentName = name+ , observableGaugeEnabled = pure en+ }+++{- | Build export batches from current in-memory aggregates (invoke observable callbacks first).++Each batch has exactly the resource given at 'createMeterProvider'. If you run multiple+meter providers, do not merge their exports into one 'ResourceMetricsExport' — keep one+top-level entry per resource when forwarding to an exporter.+-}+collectResourceMetrics :: (MonadIO m) => SdkMeterEnv -> m [ResourceMetricsExport]+collectResourceMetrics env = liftIO $ do+ cbs <- readIORef (sdkMeterCollectCallbacks env)+ mapM_ id (toList cbs)+ t <- nowNanos+ let temp = sdkMeterAggregationTemporality env+ startT = sdkMeterStartTimeNanos env+ -- For delta temporality, snapshot and reset must be atomic so concurrent+ -- record* calls between read and reset cannot be silently dropped.+ st <- case temp of+ AggregationDelta ->+ atomicModifyIORef' (sdkMeterStorage env) $ \s -> (applyDeltaReset s, s)+ AggregationCumulative ->+ readIORef (sdkMeterStorage env)+ let rme = buildResourceExport (sdkMeterResource env) startT t temp (storageCells st)+ pure [rme]+++buildResourceExport+ :: MaterializedResources+ -> Word64+ -> Word64+ -> AggregationTemporality+ -> H.HashMap DimKey Cell+ -> ResourceMetricsExport+buildResourceExport res startT t temp m =+ let groups :: H.HashMap (InstrumentationLibrary, Text, InstrumentKind, Text, Text) [(Attributes, Cell, InstrumentDims)]+ groups =+ H.foldrWithKey+ ( \(dims, attrs) cell acc ->+ let k = (dimScope dims, dimName dims, dimKind dims, dimUnit dims, dimDescription dims)+ in H.insertWith (++) k [(attrs, cell, dims)] acc+ )+ H.empty+ m+ scopes = V.fromList $ fmap (toScope startT t temp) $ H.elems groups+ in ResourceMetricsExport res scopes+++toScope :: Word64 -> Word64 -> AggregationTemporality -> [(Attributes, Cell, InstrumentDims)] -> ScopeMetricsExport+toScope startT t temp series =+ let dims = case series of+ (_, _, d) : _ -> d+ [] -> error "MeterProvider.toScope: empty"+ exports = buildMetricExports startT t temp dims series+ in ScopeMetricsExport (dimScope dims) (V.fromList exports)+++applyDimAttrs :: InstrumentDims -> Attributes -> Attributes+applyDimAttrs dims attrs = filterAttributesByKeys (dimExportAttributeKeys dims) attrs+++buildMetricExports+ :: Word64+ -> Word64+ -> AggregationTemporality+ -> InstrumentDims+ -> [(Attributes, Cell, InstrumentDims)]+ -> [MetricExport]+buildMetricExports startT t temp dims series =+ case dimKind dims of+ KindCounter -> sumExport True+ KindAsyncCounter -> sumExport True+ KindUpDownCounter -> sumExport False+ KindAsyncUpDownCounter -> sumExport False+ KindHistogram -> case dimHistogramAggregation dims of+ Just (HistogramAggregationExplicit _) -> histExport+ Just (HistogramAggregationExponential _) -> expHistExport+ Nothing -> histExport+ KindGauge -> gaugeExport False+ KindAsyncGauge -> gaugeExport True+ where+ collectCells pick =+ V.fromList $ foldr (\triple acc -> maybe acc (: acc) (pick triple)) [] series++ sumExport mon =+ let points =+ collectCells $ \(attrs, cell, d) -> case cell of+ CsSum sc ->+ Just+ SumDataPoint+ { sumDataPointStartTimeUnixNano = startT+ , sumDataPointTimeUnixNano = t+ , sumDataPointValue = case scValue sc of+ Left i -> IntNumber i+ Right d -> DoubleNumber d+ , sumDataPointAttributes = applyDimAttrs d attrs+ , sumDataPointExemplars = scExemplars sc+ }+ _ -> Nothing+ isInt =+ any+ ( \(_, cell, _) ->+ case cell of+ CsSum sc -> case scValue sc of+ Left _ -> True+ Right _ -> False+ _ -> False+ )+ series+ in [ MetricExportSum (dimName dims) (dimDescription dims) (dimUnit dims) (dimScope dims) mon isInt temp points+ ]++ histExport =+ let points =+ collectCells $ \(attrs, cell, d) -> case cell of+ CsHist hc ->+ Just+ HistogramDataPoint+ { histogramDataPointStartTimeUnixNano = startT+ , histogramDataPointTimeUnixNano = t+ , histogramDataPointCount = hcCount hc+ , histogramDataPointSum = hcSum hc+ , histogramDataPointBucketCounts = hcBuckets hc+ , histogramDataPointExplicitBounds = hcBounds hc+ , histogramDataPointAttributes = applyDimAttrs d attrs+ , histogramDataPointMin = hcMin hc+ , histogramDataPointMax = hcMax hc+ , histogramDataPointExemplars = hcExemplars hc+ }+ _ -> Nothing+ in [ MetricExportHistogram (dimName dims) (dimDescription dims) (dimUnit dims) (dimScope dims) temp points+ ]++ expHistExport =+ let points =+ collectCells $ \(attrs, cell, d) -> case cell of+ CsExpHist ehc ->+ Just (expHistToDataPoint startT t (applyDimAttrs d attrs) ehc)+ _ -> Nothing+ in [ MetricExportExponentialHistogram (dimName dims) (dimDescription dims) (dimUnit dims) (dimScope dims) temp points+ ]++ gaugeExport _isAsync =+ let points =+ collectCells $ \(attrs, cell, d) -> case cell of+ CsGauge gc ->+ Just+ GaugeDataPoint+ { gaugeDataPointStartTimeUnixNano = startT+ , gaugeDataPointTimeUnixNano = gcTimeUnixNano gc+ , gaugeDataPointValue = gcValue gc+ , gaugeDataPointAttributes = applyDimAttrs d attrs+ , gaugeDataPointExemplars = gcExemplars gc+ }+ _ -> Nothing+ isInt = case series of+ (_, CsGauge gc, _) : _ -> case gcValue gc of+ IntNumber _ -> True+ DoubleNumber _ -> False+ _ -> False+ in [ MetricExportGauge (dimName dims) (dimDescription dims) (dimUnit dims) (dimScope dims) isInt points+ ]+++-- | Create an SDK-backed 'MeterProvider' and handle for collection.+createMeterProvider+ :: MaterializedResources+ -> SdkMeterProviderOptions+ -> IO (MeterProvider, SdkMeterEnv)+createMeterProvider res opts = do+ st <- newIORef emptyStorageState+ cbs <- newIORef Seq.empty+ sd <- newIORef False+ startT <- nowNanos+ envFilter <- lookupMetricsExemplarFilter+ let lim = cardinalityLimit opts+ temp = aggregationTemporality opts+ viewsList = views opts+ baseExOpts = exemplarOptions opts+ exOpts = case envFilter of+ Just f -> baseExOpts {exemplarFilter = f}+ Nothing -> baseExOpts+ env =+ SdkMeterEnv+ { sdkMeterStorage = st+ , sdkMeterCollectCallbacks = cbs+ , sdkMeterResource = res+ , sdkMeterShutdown = sd+ , sdkMeterCardinalityLimit = lim+ , sdkMeterAggregationTemporality = temp+ , sdkMeterViews = viewsList+ , sdkMeterExemplarOptions = exOpts+ , sdkMeterStartTimeNanos = startT+ }+ mExporter = metricExporter opts+ provider =+ MeterProvider+ { meterProviderGetMeter = \scope -> do+ shut <- readIORef sd+ if shut then pure (noopMeter scope) else pure (mkMeter env scope)+ , meterProviderShutdown = \_timeoutMicros -> do+ writeIORef sd True+ batches <- collectResourceMetrics env+ shutdownRes <- case mExporter of+ Just ex -> do+ _ <- metricExporterExport ex (V.fromList batches)+ metricExporterShutdown ex+ Nothing -> pure ShutdownSuccess+ writeIORef st emptyStorageState+ writeIORef cbs Seq.empty+ pure shutdownRes+ , meterProviderForceFlush = \_timeoutMicros -> do+ batches <- collectResourceMetrics env+ case mExporter of+ Just ex -> do+ _ <- metricExporterExport ex (V.fromList batches)+ metricExporterForceFlush ex+ Nothing -> pure FlushSuccess+ }+ pure (provider, env)
+ src/OpenTelemetry/Metric.hs view
@@ -0,0 +1,252 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++{- |+Module : OpenTelemetry.Metric+Copyright : (c) Ian Duncan, 2026+License : BSD-3+Description : OpenTelemetry Metrics SDK — batteries-included setup+Stability : experimental++= Overview++This is the main entry point for adding metrics to your Haskell application.+It re-exports the Metrics API types from "OpenTelemetry.Metric.Core" and+adds SDK-level initialization, periodic export, and views.++= Quick example++@+{\-# LANGUAGE OverloadedStrings #-\}+module Main where++import OpenTelemetry.Metric++main :: IO ()+main = withMeterProvider $ \\mp -> do+ meter <- getMeter mp "my-service"+ counter <- meterCreateCounterInt64 meter "http.requests" "" Nothing defaultAdvisoryParameters+ counterAdd counter 1 emptyAttributes+@++'withMeterProvider' reads configuration from @OTEL_*@ environment variables,+starts a periodic export thread, and ensures shutdown on exit. If you also+use 'OpenTelemetry.Trace.withTracerProvider', it already sets up a+'MeterProvider' for you via YAML config — use this module when you need+metrics without traces, or want explicit control.++= Configuration++| Variable | Default | Description |+|---|---|---|+| @OTEL_SDK_DISABLED@ | @false@ | Disable all telemetry |+| @OTEL_METRICS_EXPORTER@ | @otlp@ | @otlp@, @console@, @prometheus@, @none@ |+| @OTEL_METRIC_EXPORT_INTERVAL@ | @60000@ | Export interval in ms |+| @OTEL_METRIC_EXPORT_TIMEOUT@ | @30000@ | Export timeout in ms |+| @OTEL_METRICS_EXEMPLAR_FILTER@ | @trace_based@ | Exemplar filter: @always_on@, @always_off@, @trace_based@ |++= Spec reference++<https://opentelemetry.io/docs/specs/otel/metrics/sdk/>+-}+module OpenTelemetry.Metric (+ -- * Provider lifecycle+ withMeterProvider,+ initializeGlobalMeterProvider,++ -- * Metric API types (re-exported from "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 (..),++ -- * SDK configuration++ -- ** Provider options+ SdkMeterProviderOptions (..),+ defaultSdkMeterProviderOptions,+ SdkMeterExemplarOptions (..),+ defaultSdkMeterExemplarOptions,+ createMeterProvider,+ SdkMeterEnv (..),++ -- ** Metric readers+ MetricReader (..),+ cumulativeTemporality,+ deltaTemporality,+ PeriodicMetricReaderOptions (..),+ defaultPeriodicMetricReaderOptions,+ periodicMetricReaderOptionsFromEnv,+ forkPeriodicMetricReader,+ exportMetricsOnce,+ PeriodicMetricReaderHandle (..),++ -- ** Views+ View (..),+ ViewSelector (..),+ ViewAggregation (..),+ MetricsExemplarFilter (..),++ -- ** Exporter selection+ resolveMetricExporter,++ -- * Common types+ InstrumentationLibrary (..),+ ShutdownResult (..),+ FlushResult (..),+ Attributes,+ emptyAttributes,+ ToAttribute (..),+ Attribute (..),+) where++import Control.Exception (bracket)+import Control.Monad (void)+import Data.IORef (newIORef)+import qualified Data.Sequence as Seq+import OpenTelemetry.Attributes (Attributes, emptyAttributes)+import OpenTelemetry.Attributes.Attribute (Attribute (..), ToAttribute (..))+import OpenTelemetry.Environment (MetricsExemplarFilter (..), lookupBooleanEnv)+import OpenTelemetry.Exporter.Metric (AggregationTemporality (..))+import OpenTelemetry.Internal.Common.Types (FlushResult (..), InstrumentationLibrary (..), ShutdownResult (..))+import OpenTelemetry.Internal.Logging (otelLogDebug)+import OpenTelemetry.MeterProvider (+ MetricReader (..),+ SdkMeterEnv (..),+ SdkMeterExemplarOptions (..),+ SdkMeterProviderOptions (..),+ createMeterProvider,+ cumulativeTemporality,+ defaultSdkMeterExemplarOptions,+ defaultSdkMeterProviderOptions,+ deltaTemporality,+ emptyStorageState,+ )+import OpenTelemetry.Metric.Core+import OpenTelemetry.Metric.ExporterSelection (resolveMetricExporter)+import OpenTelemetry.Metric.View (+ View (..),+ ViewAggregation (..),+ ViewSelector (..),+ )+import OpenTelemetry.MetricReader (+ PeriodicMetricReaderHandle (..),+ PeriodicMetricReaderOptions (..),+ defaultPeriodicMetricReaderOptions,+ exportMetricsOnce,+ forkPeriodicMetricReader,+ periodicMetricReaderOptionsFromEnv,+ )+import OpenTelemetry.Resource (emptyMaterializedResources, materializeResources, mergeResources, mkResource)+import OpenTelemetry.Resource.Detect (detectBuiltInResources, detectResourceAttributes)+++{- | Build an inert 'SdkMeterEnv' for the disabled-SDK case. All mutable+fields are properly allocated (not bottom) so shutdown and flush never crash.+-}+noopSdkMeterEnv :: IO SdkMeterEnv+noopSdkMeterEnv = do+ storageRef <- newIORef emptyStorageState+ cbRef <- newIORef Seq.empty+ sdRef <- newIORef True+ pure+ SdkMeterEnv+ { sdkMeterStorage = storageRef+ , sdkMeterCollectCallbacks = cbRef+ , sdkMeterResource = emptyMaterializedResources+ , sdkMeterShutdown = sdRef+ , sdkMeterCardinalityLimit = 0+ , sdkMeterAggregationTemporality = AggregationCumulative+ , sdkMeterViews = []+ , sdkMeterExemplarOptions = defaultSdkMeterExemplarOptions+ , sdkMeterStartTimeNanos = 0+ }+++{- | Initialize a 'MeterProvider' from environment variables, set it as the+global meter provider, and run an action. The provider is shut down on exit+(including exceptions).++@+main :: IO ()+main = withMeterProvider $ \\mp -> do+ meter <- getMeter mp "my-service"+ counter <- meterCreateCounterInt64 meter "requests" "" Nothing defaultAdvisoryParameters+ counterAdd counter 1 emptyAttributes+ -- ... application code ...+@++@since 0.0.1.0+-}+withMeterProvider :: (MeterProvider -> IO a) -> IO a+withMeterProvider body =+ bracket+ initializeGlobalMeterProvider+ (\mp -> void $ shutdownMeterProvider mp Nothing)+ body+++{- | Create a 'MeterProvider' from @OTEL_*@ environment variables and install+it as the global provider via 'setGlobalMeterProvider'.++The returned 'MeterProvider' has the periodic reader lifecycle baked into+its shutdown — call 'shutdownMeterProvider' when the application exits.++Reads:++* @OTEL_SDK_DISABLED@ — if @true@, returns the no-op provider+* @OTEL_METRICS_EXPORTER@ — selects the exporter (default: @otlp@)+* @OTEL_METRIC_EXPORT_INTERVAL@, @OTEL_METRIC_EXPORT_TIMEOUT@ — periodic reader timing+* @OTEL_METRICS_EXEMPLAR_FILTER@ — exemplar filter strategy (default: @trace_based@)++@since 0.0.1.0+-}+initializeGlobalMeterProvider :: IO MeterProvider+initializeGlobalMeterProvider = do+ disabled <- lookupBooleanEnv "OTEL_SDK_DISABLED"+ if disabled+ then do+ otelLogDebug "OTEL_SDK_DISABLED=true, using no-op MeterProvider"+ setGlobalMeterProvider noopMeterProvider+ pure noopMeterProvider+ else do+ exporter <- resolveMetricExporter+ readerOpts <- periodicMetricReaderOptionsFromEnv+ builtInRs <- detectBuiltInResources+ envVarRs <- mkResource . map Just <$> detectResourceAttributes+ let rs = materializeResources (mergeResources envVarRs builtInRs)+ (provider, env) <- createMeterProvider rs defaultSdkMeterProviderOptions+ readerHandle <- forkPeriodicMetricReader env exporter readerOpts+ let provider' =+ provider+ { meterProviderShutdown = \timeout -> do+ stopPeriodicMetricReader readerHandle+ meterProviderShutdown provider timeout+ }+ setGlobalMeterProvider provider'+ otelLogDebug "MeterProvider initialized from environment"+ pure provider'
+ src/OpenTelemetry/Metric/ExporterSelection.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++{- | Wire @OTEL_METRICS_EXPORTER@ to a concrete 'MetricExporter' (and optional periodic reader).++When the environment variable is unset the default is @otlp@.+-}+module OpenTelemetry.Metric.ExporterSelection (+ resolveMetricExporter,+) where++import OpenTelemetry.Environment (MetricsExporterSelection (..), lookupMetricsExporterSelection)+import OpenTelemetry.Exporter.Handle.Metric (stdoutMetricExporter)+import OpenTelemetry.Exporter.Metric (MetricExporter (..))+import OpenTelemetry.Exporter.OTLP.Metric (otlpMetricExporter)+import OpenTelemetry.Exporter.OTLP.Span (loadExporterEnvironmentVariables)+import OpenTelemetry.Internal.Common.Types (ExportResult (..), FlushResult (..), ShutdownResult (..))+++{- | Select a 'MetricExporter' based on @OTEL_METRICS_EXPORTER@.++* @otlp@ (default) — OTLP HTTP\/Protobuf+* @console@ — human-readable text to stdout+* @prometheus@ — returns a no-op push exporter; Prometheus is pull-based,+ so the caller should expose an HTTP endpoint using 'OpenTelemetry.Exporter.Prometheus.renderPrometheusText'.+* @none@ — disabled (export calls succeed but discard data)+-}+resolveMetricExporter :: IO MetricExporter+resolveMetricExporter = do+ sel <- lookupMetricsExporterSelection+ case sel of+ Just MetricsExporterNone -> pure noopExporter+ Just MetricsExporterConsole -> stdoutMetricExporter+ Just MetricsExporterPrometheus -> pure noopExporter+ Just MetricsExporterOtlp -> mkOtlp+ Nothing -> mkOtlp+ where+ mkOtlp = do+ conf <- loadExporterEnvironmentVariables+ otlpMetricExporter conf+++noopExporter :: MetricExporter+noopExporter =+ MetricExporter+ { metricExporterExport = \_ -> pure Success+ , metricExporterShutdown = pure ShutdownSuccess+ , metricExporterForceFlush = pure FlushSuccess+ }
+ src/OpenTelemetry/Metric/View.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings #-}++{- | Metric views (spec: @specification/metrics/sdk.md@): instrument selection and aggregation overrides.++Selector criteria are additive (AND): an instrument must match /all/ provided criteria.+-}+module OpenTelemetry.Metric.View (+ View (..),+ ViewSelector (..),+ ViewAggregation (..),+ findMatchingView,+ findAllMatchingViews,+ viewOverrideName,+ viewOverrideDescription,+) where++import Data.Int (Int32)+import Data.List (filter, find)+import Data.Text (Text)+import qualified Data.Text as T+import OpenTelemetry.Metric.Core (InstrumentKind (..))+++{- | Select instruments by name pattern, kind, unit, and meter scope.++All provided criteria are ANDed (spec: "criteria SHOULD be treated as additive").+-}+data ViewSelector = ViewSelector+ { viewInstrumentNamePattern :: !Text+ -- ^ Exact name, @*@ for all, or @prefix*@ suffix-wildcard.+ , viewInstrumentKind :: !(Maybe InstrumentKind)+ , viewInstrumentUnit :: !(Maybe Text)+ , viewMeterName :: !(Maybe Text)+ , viewMeterVersion :: !(Maybe Text)+ , viewMeterSchemaUrl :: !(Maybe Text)+ }+++-- | Aggregation override or drop.+data ViewAggregation+ = ViewAggregationDefault+ | ViewAggregationExplicitBucketHistogram ![Double]+ | ViewAggregationExponentialHistogram !Int32+ | ViewAggregationDrop+ deriving stock (Eq)+++-- | One view (first matching view in the provider list wins for single-match queries).+data View = View+ { viewSelector :: !ViewSelector+ , viewAggregation :: !ViewAggregation+ , viewAttributeKeys :: !(Maybe [Text])+ , viewName :: !(Maybe Text)+ , viewDescription :: !(Maybe Text)+ }+++-- | Scope info passed during matching (avoids importing InstrumentationLibrary into this module).+type MeterScope = (Text, Text, Text)+++matchesName :: Text -> Text -> Bool+matchesName pat n+ | pat == "*" = True+ | "*" `T.isSuffixOf` pat = T.isPrefixOf (T.init pat) n+ | otherwise = T.toLower pat == T.toLower n+++matchesSelector :: ViewSelector -> InstrumentKind -> Text -> Maybe Text -> MeterScope -> Bool+matchesSelector sel kind name mUnit (scopeName, scopeVer, scopeSchema) =+ matchesName (viewInstrumentNamePattern sel) name+ && maybe True (== kind) (viewInstrumentKind sel)+ && maybe True (\u -> mUnit == Just u) (viewInstrumentUnit sel)+ && maybe True (== scopeName) (viewMeterName sel)+ && maybe True (== scopeVer) (viewMeterVersion sel)+ && maybe True (== scopeSchema) (viewMeterSchemaUrl sel)+++-- | First matching view (legacy single-match for backward compat).+findMatchingView :: [View] -> InstrumentKind -> Text -> Maybe View+findMatchingView views kind name =+ find (\v -> matchesSelector (viewSelector v) kind name Nothing ("", "", "")) views+++-- | All matching views (spec: each produces a separate metric stream).+findAllMatchingViews :: [View] -> InstrumentKind -> Text -> Maybe Text -> MeterScope -> [View]+findAllMatchingViews views kind name mUnit scope =+ Data.List.filter (\v -> matchesSelector (viewSelector v) kind name mUnit scope) views+++viewOverrideName :: [View] -> InstrumentKind -> Text -> Text+viewOverrideName views kind name =+ case findMatchingView views kind name of+ Just v -> case viewName v of+ Just n -> n+ Nothing -> name+ Nothing -> name+++viewOverrideDescription :: [View] -> InstrumentKind -> Text -> Maybe Text -> Maybe Text+viewOverrideDescription views kind name mDesc =+ case findMatchingView views kind name of+ Just v -> case viewDescription v of+ Just d -> Just d+ Nothing -> mDesc+ Nothing -> mDesc
+ src/OpenTelemetry/MetricReader.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE NumericUnderscores #-}++{- | Periodic metric export (spec-style periodic reader) built on 'collectResourceMetrics'.++Stop the reader before 'meterProviderShutdown' on the associated 'MeterProvider'.++Applications that scrape metrics on demand (\"pull\") can skip a periodic reader and instead+call 'exportMetricsOnce' (or 'collectResourceMetrics' plus a text\/OTLP encoder) from their HTTP handler.+-}+module OpenTelemetry.MetricReader (+ PeriodicMetricReaderOptions (..),+ defaultPeriodicMetricReaderOptions,+ periodicMetricReaderOptionsFromEnv,+ PeriodicMetricReaderHandle (..),+ forkPeriodicMetricReader,+ exportMetricsOnce,+) where++import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (Async, async, cancel, waitCatch)+import Control.Monad (forever)+import qualified Data.Vector as V+import OpenTelemetry.Environment (lookupMetricExportIntervalMillis)+import OpenTelemetry.Exporter.Metric (MetricExporter (..))+import OpenTelemetry.Internal.Common.Types (ExportResult)+import OpenTelemetry.MeterProvider (SdkMeterEnv, collectResourceMetrics)+++-- | Interval between automatic export cycles (microseconds).+newtype PeriodicMetricReaderOptions = PeriodicMetricReaderOptions+ { periodicIntervalMicros :: Int+ }+++-- | Default: 60 seconds between exports (overridden by 'periodicMetricReaderOptionsFromEnv' when @OTEL_METRIC_EXPORT_INTERVAL@ is set).+defaultPeriodicMetricReaderOptions :: PeriodicMetricReaderOptions+defaultPeriodicMetricReaderOptions =+ PeriodicMetricReaderOptions+ { periodicIntervalMicros = 60_000_000+ }+++-- | Use @OTEL_METRIC_EXPORT_INTERVAL@ (milliseconds) when set and positive; otherwise same as 'defaultPeriodicMetricReaderOptions'.+periodicMetricReaderOptionsFromEnv :: IO PeriodicMetricReaderOptions+periodicMetricReaderOptionsFromEnv = do+ mi <- lookupMetricExportIntervalMillis+ pure $+ PeriodicMetricReaderOptions+ { periodicIntervalMicros = case mi of+ Just ms | ms > 0 -> ms * 1000+ _ -> periodicIntervalMicros defaultPeriodicMetricReaderOptions+ }+++-- | Handle for a background thread that exports on an interval.+data PeriodicMetricReaderHandle = PeriodicMetricReaderHandle+ { periodicMetricReaderAsync :: !(Async ())+ , stopPeriodicMetricReader :: !(IO ())+ }+++-- | One collect + export (for tests and custom schedulers).+exportMetricsOnce :: SdkMeterEnv -> MetricExporter -> IO ExportResult+exportMetricsOnce env ex = do+ batches <- collectResourceMetrics env+ metricExporterExport ex (V.fromList batches)+++-- | Spawn an async loop: export on each interval until stopped.+forkPeriodicMetricReader+ :: SdkMeterEnv+ -> MetricExporter+ -> PeriodicMetricReaderOptions+ -> IO PeriodicMetricReaderHandle+forkPeriodicMetricReader env ex opts = do+ a <-+ async $+ forever $ do+ _ <- exportMetricsOnce env ex+ threadDelay (periodicIntervalMicros opts)+ let stop = do+ cancel a+ _ <- waitCatch a+ _ <- exportMetricsOnce env ex+ _ <- metricExporterShutdown ex+ pure ()+ pure $+ PeriodicMetricReaderHandle+ { periodicMetricReaderAsync = a+ , stopPeriodicMetricReader = stop+ }
src/OpenTelemetry/Processor/Batch.hs view
@@ -1,372 +1,11 @@-{-# LANGUAGE RecordWildCards #-}--------------------------------------------------------------------------------------------------------------------------------------------------------------- {- |- Module : OpenTelemetry.Processor.Batch- Copyright : (c) Ian Duncan, 2021- License : BSD-3- Description : Performant exporting of spans in time & space-bounded batches.- Maintainer : Ian Duncan- Stability : experimental- Portability : non-portable (GHC extensions)-- This is an implementation of the Span Processor which create batches of finished spans and passes the export-friendly span data representations to the configured Exporter.+Module : OpenTelemetry.Processor.Batch+Description : Re-exports for batch processors (both span and log record).+Stability : experimental -} module OpenTelemetry.Processor.Batch (- BatchTimeoutConfig (..),- batchTimeoutConfig,- batchProcessor,- -- , BatchProcessorOperations+ module OpenTelemetry.Processor.Batch.Span, ) where -import Control.Concurrent (rtsSupportsBoundThreads)-import Control.Concurrent.Async-import Control.Concurrent.STM-import Control.Exception-import Control.Monad-import Control.Monad.IO.Class-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HashMap-import Data.IORef (atomicModifyIORef', newIORef, readIORef)-import Data.Vector (Vector)-import OpenTelemetry.Exporter (Exporter)-import qualified OpenTelemetry.Exporter as Exporter-import OpenTelemetry.Processor-import OpenTelemetry.Trace.Core-import VectorBuilder.Builder as Builder-import VectorBuilder.Vector as Builder----- | Configurable options for batch exporting frequence and size-data BatchTimeoutConfig = BatchTimeoutConfig- { maxQueueSize :: Int- -- ^ The maximum queue size. After the size is reached, spans are dropped.- , scheduledDelayMillis :: Int- -- ^ The delay interval in milliseconds between two consective exports.- -- The default value is 5000.- , exportTimeoutMillis :: Int- -- ^ How long the export can run before it is cancelled.- -- The default value is 30000.- , maxExportBatchSize :: Int- -- ^ The maximum batch size of every export. It must be- -- smaller or equal to 'maxQueueSize'. The default value is 512.- }- deriving (Show)----- | Default configuration values-batchTimeoutConfig :: BatchTimeoutConfig-batchTimeoutConfig =- BatchTimeoutConfig- { maxQueueSize = 1024- , scheduledDelayMillis = 5000- , exportTimeoutMillis = 30000- , maxExportBatchSize = 512- }----- type BatchProcessorOperations = ()---- A multi-producer single-consumer green/blue buffer.--- Write requests that cannot fit in the live chunk will be dropped------ TODO, would be cool to use AtomicCounters for this if possible--- data GreenBlueBuffer a = GreenBlueBuffer--- { gbReadSection :: !(TVar Word)--- , gbWriteGreenOrBlue :: !(TVar Word)--- , gbPendingWrites :: !(TVar Word)--- , gbSectionSize :: !Int--- , gbVector :: !(M.IOVector a)--- }--{- brainstorm: Single Word64 state sketch-- 63 (high bit): green or blue- 32-62: read section- 0-32: write count--}--{---Green- 512 512 512 512-\|---------|---------|---------|---------|- 0 1 2 3--Blue- 512 512 512 512-\|---------|---------|---------|---------|- 0 1 2 3--The current read section denotes one chunk of length gbSize, which gets flushed-to the span exporter. Once the vector has been copied for export, gbReadSection-will be incremented.---}---- newGreenBlueBuffer--- :: Int -- Max queue size (2048)--- -> Int -- Export batch size (512)--- -> IO (GreenBlueBuffer a)--- newGreenBlueBuffer maxQueueSize batchSize = do--- let logBase2 = finiteBitSize maxQueueSize - 1 - countLeadingZeros maxQueueSize---- let closestFittingPowerOfTwo = 2 * if (1 `shiftL` logBase2) == maxQueueSize--- then maxQueueSize--- else 1 `shiftL` (logBase2 + 1)---- readSection <- newTVarIO 0--- writeSection <- newTVarIO 0--- writeCount <- newTVarIO 0--- buf <- M.new closestFittingPowerOfTwo--- pure $ GreenBlueBuffer--- { gbSize = maxQueueSize--- , gbVector = buf--- , gbReadSection = readSection--- , gbPendingWrites = writeCount--- }---- isEmpty :: GreenBlueBuffer a -> STM Bool--- isEmpty = do--- c <- readTVar gbPendingWrites--- pure (c == 0)---- data InsertResult = ValueDropped | ValueInserted---- tryInsert :: GreenBlueBuffer a -> a -> IO InsertResult--- tryInsert GreenBlueBuffer{..} x = atomically $ do--- c <- readTVar gbPendingWrites--- if c == gbMaxLength--- then pure ValueDropped--- else do--- greenOrBlue <- readTVar gbWriteGreenOrBlue--- let i = c + ((M.length gbVector `shiftR` 1) `shiftL` (greenOrBlue `mod` 2))--- M.write gbVector i x--- writeTVar gbPendingWrites (c + 1)--- pure ValueInserted---- Caution, single writer means that this can't be called concurrently--- consumeChunk :: GreenBlueBuffer a -> IO (V.Vector a)--- consumeChunk GreenBlueBuffer{..} = atomically $ do--- r <- readTVar gbReadSection--- w <- readTVar gbWriteSection--- c <- readTVar gbPendingWrites--- when (r == w) $ do--- modifyTVar gbWriteSection (+ 1)--- setTVar gbPendingWrites 0--- -- TODO slice and freeze appropriate section--- M.slice (gbSectionSize * (r .&. gbSectionMask)---- TODO, counters for dropped spans, exported spans--data BoundedMap a = BoundedMap- { itemBounds :: !Int- , itemMaxExportBounds :: !Int- , itemCount :: !Int- , itemMap :: HashMap InstrumentationLibrary (Builder.Builder a)- }---boundedMap :: Int -> Int -> BoundedMap a-boundedMap bounds exportBounds = BoundedMap bounds exportBounds 0 mempty---push :: ImmutableSpan -> BoundedMap ImmutableSpan -> Maybe (BoundedMap ImmutableSpan)-push s m =- if itemCount m + 1 >= itemBounds m- then Nothing- else- Just $!- m- { itemCount = itemCount m + 1- , itemMap =- HashMap.insertWith- (<>)- (tracerName $ spanTracer s)- (Builder.singleton s)- $ itemMap m- }---buildExport :: BoundedMap a -> (BoundedMap a, HashMap InstrumentationLibrary (Vector a))-buildExport m =- ( m {itemCount = 0, itemMap = mempty}- , Builder.build <$> itemMap m- )---data ProcessorMessage = ScheduledFlush | MaxExportFlush | Shutdown----- note: [Unmasking Asyncs]------ It is possible to create unkillable asyncs. Behold:------ ```--- a <- uninterruptibleMask_ $ do--- async $ do--- forever $ do--- threadDelay 10_000--- putStrLn "still alive"--- cancel a--- ```------ The prior code block will never successfully cancel `a` and will be--- blocked forever. The reason is that `cancel` sends an async exception to--- the thread performing the action, but the `uninterruptibleMask` state is--- inherited by the forked thread. This means that *no async exceptions*--- can reach it, and `cancel` will therefore run forever.------ This also affects `timeout`, which uses an async exception to kill the--- running job. If the action is done in an uninterruptible masked state,--- then the timeout will not successfully kill the running action.--{- |- The batch processor accepts spans and places them into batches. Batching helps better compress the data and reduce the number of outgoing connections- required to transmit the data. This processor supports both size and time based batching.-- NOTE: this function requires the program be compiled with the @-threaded@ GHC- option and will throw an error if this is not the case.--}-batchProcessor :: (MonadIO m) => BatchTimeoutConfig -> Exporter ImmutableSpan -> m Processor-batchProcessor BatchTimeoutConfig {..} exporter = liftIO $ do- unless rtsSupportsBoundThreads $ error "The hs-opentelemetry batch processor does not work without the -threaded GHC flag!"- batch <- newIORef $ boundedMap maxQueueSize maxExportBatchSize- workSignal <- newEmptyTMVarIO- shutdownSignal <- newEmptyTMVarIO- let publish batchToProcess = mask_ $ do- -- we mask async exceptions in this, so that a buggy exporter that- -- catches async exceptions won't swallow them. since we use- -- an interruptible mask, blocking calls can still be killed, like- -- `threadDelay` or `putMVar` or most file I/O operations.- --- -- if we've received a shutdown, then we should be expecting- -- a `cancel` anytime now.- Exporter.exporterExport exporter batchToProcess-- let flushQueueImmediately ret = do- batchToProcess <- atomicModifyIORef' batch buildExport- if null batchToProcess- then do- pure ret- else do- ret' <- publish batchToProcess- flushQueueImmediately ret'-- let waiting = do- delay <- registerDelay (millisToMicros scheduledDelayMillis)- atomically $ do- msum- -- Flush every scheduled delay time, when we've reached the max export size, or when the shutdown signal is received.- [ ScheduledFlush <$ do- continue <- readTVar delay- check continue- , MaxExportFlush <$ takeTMVar workSignal- , Shutdown <$ takeTMVar shutdownSignal- ]-- let workerAction = do- req <- waiting- batchToProcess <- atomicModifyIORef' batch buildExport- res <- publish batchToProcess-- -- if we were asked to shutdown, stop waiting and flush it all out- case req of- Shutdown ->- flushQueueImmediately res- _ ->- workerAction- -- see note [Unmasking Asyncs]- worker <- asyncWithUnmask $ \unmask -> unmask workerAction-- pure $- Processor- { processorOnStart = \_ _ -> pure ()- , processorOnEnd = \s -> do- span_ <- readIORef s- appendFailedOrExportNeeded <- atomicModifyIORef' batch $ \builder ->- case push span_ builder of- Nothing -> (builder, True)- Just b' ->- if itemCount b' >= itemMaxExportBounds b'- then -- If the batch has grown to the maximum export size, prompt the worker to export it.- (b', True)- else (b', False)- when appendFailedOrExportNeeded $ void $ atomically $ tryPutTMVar workSignal ()- , processorForceFlush = void $ atomically $ tryPutTMVar workSignal ()- , -- TODO where to call restore, if anywhere?- processorShutdown =- asyncWithUnmask $ \unmask -> unmask $ do- -- we call asyncWithUnmask here because the shutdown action is- -- likely to happen inside of a `finally` or `bracket`. the- -- @safe-exceptions@ pattern (followed by unliftio as well)- -- will use uninterruptibleMask in an exception cleanup. the- -- uninterruptibleMask state means that the `timeout` call- -- below will never exit, because `wait worker` will be in the- -- `uninterruptibleMasked` state, and the timeout async- -- exception will not be delivered.- --- -- see note [Unmasking Asyncs]- mask $ \_restore -> do- -- is it a little silly that we unmask and remask? seems- -- silly! but the `mask` here is doing an interruptible mask.- -- which means that async exceptions can still be delivered- -- if a process is blocking.-- -- flush remaining messages and signal the worker to shutdown- void $ atomically $ putTMVar shutdownSignal ()-- -- gracefully wait for the worker to stop. we may be in- -- a `bracket` or responding to an async exception, so we- -- must be very careful not to wait too long. the following- -- STM action will block, so we'll be susceptible to an async- -- exception.- delay <- registerDelay (millisToMicros exportTimeoutMillis)- shutdownResult <-- atomically $- msum- [ Just <$> waitCatchSTM worker- , Nothing <$ do- shouldStop <- readTVar delay- check shouldStop- ]-- -- make sure the worker comes down if we timed out.- cancel worker- -- TODO, not convinced we should shut down processor here-- pure $ case shutdownResult of- Nothing ->- ShutdownTimeout- Just er ->- case er of- Left _ ->- ShutdownFailure- Right _ ->- ShutdownSuccess- }- where- millisToMicros = (* 1000)--{--buffer <- newGreenBlueBuffer _ _-batchProcessorAction <- async $ forever $ do- -- It would be nice to do an immediate send when possible- chunk <- if (sendDelay == 0)- else consumeChunk- then threadDelay sendDelay >> consumeChunk- timeout _ $ export exporter chunk-pure $ Processor- { onStart = \_ _ -> pure ()- , onEnd = \s -> void $ tryInsert buffer s- , shutdown = do- gracefullyShutdownBatchProcessor+import OpenTelemetry.Processor.Batch.Span - , forceFlush = pure ()- }-where- sendDelay = scheduledDelayMilis * 1_000--}
+ src/OpenTelemetry/Processor/Batch/LogRecord.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE RecordWildCards #-}++module OpenTelemetry.Processor.Batch.LogRecord (+ BatchLogRecordProcessorConfig (..),+ defaultBatchLogRecordProcessorConfig,+ batchLogRecordProcessor,+) where++import Control.Concurrent (rtsSupportsBoundThreads)+import Control.Concurrent.Async+import Control.Concurrent.STM+import Control.Exception+import Control.Monad+import Control.Monad.IO.Class+import Data.IORef (IORef, atomicModifyIORef', newIORef)+import Data.Vector (Vector)+import qualified Data.Vector as V+import OpenTelemetry.Internal.Common.Types (ExportResult (..), ShutdownResult (..))+import OpenTelemetry.Internal.Log.Types+import OpenTelemetry.Internal.Logging (otelLogWarning)+import System.Timeout (timeout)+import VectorBuilder.Builder as Builder+import VectorBuilder.Vector as Builder+++data BatchLogRecordProcessorConfig = BatchLogRecordProcessorConfig+ { batchLogExporter :: !LogRecordExporter+ , batchLogMaxQueueSize :: !Int+ , batchLogScheduledDelayMillis :: !Int+ , batchLogExportTimeoutMillis :: !Int+ , batchLogMaxExportBatchSize :: !Int+ }+++defaultBatchLogRecordProcessorConfig :: LogRecordExporter -> BatchLogRecordProcessorConfig+defaultBatchLogRecordProcessorConfig e =+ BatchLogRecordProcessorConfig+ { batchLogExporter = e+ , batchLogMaxQueueSize = 2048+ , batchLogScheduledDelayMillis = 1000+ , batchLogExportTimeoutMillis = 30000+ , batchLogMaxExportBatchSize = 512+ }+++data BoundedBuffer = BoundedBuffer+ { bufBounds :: !Int+ , bufExportBounds :: !Int+ , bufCount :: !Int+ , bufItems :: !(Builder.Builder ReadableLogRecord)+ }+++emptyBuffer :: Int -> Int -> BoundedBuffer+emptyBuffer bounds exportBounds = BoundedBuffer bounds exportBounds 0 mempty+++pushBuffer :: ReadableLogRecord -> BoundedBuffer -> Maybe BoundedBuffer+pushBuffer lr buf+ | bufCount buf >= bufBounds buf = Nothing+ | otherwise =+ Just $!+ buf+ { bufCount = bufCount buf + 1+ , bufItems = bufItems buf <> Builder.singleton lr+ }+++buildExportBatch :: BoundedBuffer -> (BoundedBuffer, Vector ReadableLogRecord)+buildExportBatch buf =+ ( buf {bufCount = 0, bufItems = mempty}+ , Builder.build (bufItems buf)+ )+++data ProcessorMessage = ScheduledFlush | MaxExportFlush | FlushRequested | Shutdown+++batchLogRecordProcessor :: (MonadIO m) => BatchLogRecordProcessorConfig -> m LogRecordProcessor+batchLogRecordProcessor BatchLogRecordProcessorConfig {..} = liftIO $ do+ unless rtsSupportsBoundThreads $+ throwIO (userError "The threaded runtime is required for the batch log record processor")+ batch <- newIORef $ emptyBuffer batchLogMaxQueueSize batchLogMaxExportBatchSize+ droppedRef <- newIORef (0 :: Int)+ warnedRef <- newIORef False+ workSignal <- newEmptyTMVarIO+ shutdownSignal <- newEmptyTMVarIO+ flushRequestSignal <- newEmptyTMVarIO+ flushDoneSignal <- newEmptyTMVarIO++ let timeoutMicros = millisToMicros batchLogExportTimeoutMillis++ let publish batchToExport = do+ mResult <-+ timeout timeoutMicros $+ mask_ $+ logRecordExporterExport batchLogExporter batchToExport+ pure $ case mResult of+ Nothing -> Failure Nothing+ Just r -> r++ let publishBounded batchToExport+ | V.null batchToExport = pure Success+ | V.length batchToExport <= batchLogMaxExportBatchSize =+ publish batchToExport+ | otherwise = do+ let (chunk, rest) = V.splitAt batchLogMaxExportBatchSize batchToExport+ res <- publish chunk+ case res of+ Failure _ -> pure res+ Success -> publishBounded rest++ let flushQueueImmediately ret = do+ batchToExport <- atomicModifyIORef' batch buildExportBatch+ if V.null batchToExport+ then pure ret+ else do+ ret' <- publishBounded batchToExport+ flushQueueImmediately ret'++ -- Shutdown and FlushRequested are tried before work signals so they+ -- cannot be starved under sustained high throughput.+ let waiting = do+ delay <- registerDelay (millisToMicros batchLogScheduledDelayMillis)+ atomically $+ msum+ [ Shutdown <$ takeTMVar shutdownSignal+ , FlushRequested <$ takeTMVar flushRequestSignal+ , MaxExportFlush <$ takeTMVar workSignal+ , ScheduledFlush <$ do+ continue <- readTVar delay+ check continue+ ]++ let workerAction = do+ req <- waiting+ batchToExport <- atomicModifyIORef' batch buildExportBatch+ res <- publishBounded batchToExport+ case req of+ Shutdown -> flushQueueImmediately res+ FlushRequested -> do+ _ <- flushQueueImmediately res+ atomically $ putTMVar flushDoneSignal ()+ workerAction+ _ -> workerAction++ worker <- asyncWithUnmask $ \unmask -> unmask workerAction++ pure+ LogRecordProcessor+ { logRecordProcessorOnEmit = \lr _ctxt -> do+ readable <- mkReadableLogRecord lr+ (dropped, exportNeeded) <- atomicModifyIORef' batch $ \buf ->+ case pushBuffer readable buf of+ Nothing -> (buf, (True, True))+ Just b' ->+ if bufCount b' >= bufExportBounds b'+ then (b', (False, True))+ else (b', (False, False))+ when dropped $ warnOnDrop droppedRef warnedRef batchLogMaxQueueSize "BatchLogRecordProcessor"+ when exportNeeded $ void $ atomically $ tryPutTMVar workSignal ()+ , logRecordProcessorForceFlush = do+ atomically $ putTMVar flushRequestSignal ()+ atomically $ takeTMVar flushDoneSignal+ logRecordExporterForceFlush batchLogExporter+ , logRecordProcessorShutdown =+ mask $ \_restore -> do+ void $ atomically $ putTMVar shutdownSignal ()+ delay <- registerDelay (millisToMicros batchLogExportTimeoutMillis)+ shutdownResult <-+ atomically $+ msum+ [ Just <$> waitCatchSTM worker+ , Nothing <$ do+ shouldStop <- readTVar delay+ check shouldStop+ ]+ cancel worker+ logRecordExporterShutdown batchLogExporter+ pure $ case shutdownResult of+ Nothing -> ShutdownTimeout+ Just (Left _) -> ShutdownFailure+ Just (Right _) -> ShutdownSuccess+ }+ where+ millisToMicros = (* 1000)+++warnOnDrop :: IORef Int -> IORef Bool -> Int -> String -> IO ()+warnOnDrop droppedRef warnedRef capacity processorName = do+ n <- atomicModifyIORef' droppedRef (\c -> let c' = c + 1 in (c', c'))+ alreadyWarned <- atomicModifyIORef' warnedRef (\w -> (True, w))+ unless alreadyWarned $+ otelLogWarning $+ processorName+ <> ": queue full (capacity "+ <> show capacity+ <> "), dropping log record. Total dropped so far: "+ <> show n
+ src/OpenTelemetry/Processor/Batch/Span.hs view
@@ -0,0 +1,419 @@+{-# LANGUAGE RecordWildCards #-}++-----------------------------------------------------------------------------++-----------------------------------------------------------------------------++{- |+ Module : OpenTelemetry.Processor.Batch.Span+ Copyright : (c) Ian Duncan, 2021+ License : BSD-3+ Description : Performant exporting of spans in time & space-bounded batches.+ Maintainer : Ian Duncan+ Stability : experimental+ Portability : non-portable (GHC extensions)++ This is an implementation of the Span Processor which create batches of finished spans and passes the export-friendly span data representations to the configured Exporter.+-}+module OpenTelemetry.Processor.Batch.Span (+ BatchTimeoutConfig (..),+ batchTimeoutConfig,+ batchProcessor,+ -- , BatchProcessorOperations+) where++import Control.Concurrent (rtsSupportsBoundThreads)+import Control.Concurrent.Async+import Control.Concurrent.STM+import Control.Exception+import Control.Monad+import Control.Monad.IO.Class+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.IORef (IORef, atomicModifyIORef', newIORef)+import Data.Vector (Vector)+import qualified Data.Vector as V+import OpenTelemetry.Exporter.Span (SpanExporter)+import qualified OpenTelemetry.Exporter.Span as SpanExporter+import OpenTelemetry.Internal.Logging (otelLogWarning)+import OpenTelemetry.Processor.Span+import OpenTelemetry.Trace.Core+import System.Timeout (timeout)+import VectorBuilder.Builder as Builder+import VectorBuilder.Vector as Builder+++-- | Configurable options for batch exporting frequence and size+data BatchTimeoutConfig = BatchTimeoutConfig+ { maxQueueSize :: Int+ -- ^ The maximum queue size. After the size is reached, spans are dropped.+ , scheduledDelayMillis :: Int+ {- ^ The delay interval in milliseconds between two consective exports.+ The default value is 5000.+ -}+ , exportTimeoutMillis :: Int+ {- ^ How long the export can run before it is cancelled.+ The default value is 30000.+ -}+ , maxExportBatchSize :: Int+ {- ^ The maximum batch size of every export. It must be+ smaller or equal to 'maxQueueSize'. The default value is 512.+ -}+ }+ deriving (Show)+++-- | Default configuration values+batchTimeoutConfig :: BatchTimeoutConfig+batchTimeoutConfig =+ BatchTimeoutConfig+ { maxQueueSize = 2048+ , scheduledDelayMillis = 5000+ , exportTimeoutMillis = 30000+ , maxExportBatchSize = 512+ }+++-- type BatchProcessorOperations = ()++-- A multi-producer single-consumer green/blue buffer.+-- Write requests that cannot fit in the live chunk will be dropped+--+-- TODO, would be cool to use AtomicCounters for this if possible+-- data GreenBlueBuffer a = GreenBlueBuffer+-- { gbReadSection :: !(TVar Word)+-- , gbWriteGreenOrBlue :: !(TVar Word)+-- , gbPendingWrites :: !(TVar Word)+-- , gbSectionSize :: !Int+-- , gbVector :: !(M.IOVector a)+-- }++{- brainstorm: Single Word64 state sketch++ 63 (high bit): green or blue+ 32-62: read section+ 0-32: write count+-}++{-++Green+ 512 512 512 512+\|---------|---------|---------|---------|+ 0 1 2 3++Blue+ 512 512 512 512+\|---------|---------|---------|---------|+ 0 1 2 3++The current read section denotes one chunk of length gbSize, which gets flushed+to the span exporter. Once the vector has been copied for export, gbReadSection+will be incremented.++-}++-- newGreenBlueBuffer+-- :: Int -- Max queue size (2048)+-- -> Int -- Export batch size (512)+-- -> IO (GreenBlueBuffer a)+-- newGreenBlueBuffer maxQueueSize batchSize = do+-- let logBase2 = finiteBitSize maxQueueSize - 1 - countLeadingZeros maxQueueSize++-- let closestFittingPowerOfTwo = 2 * if (1 `shiftL` logBase2) == maxQueueSize+-- then maxQueueSize+-- else 1 `shiftL` (logBase2 + 1)++-- readSection <- newTVarIO 0+-- writeSection <- newTVarIO 0+-- writeCount <- newTVarIO 0+-- buf <- M.new closestFittingPowerOfTwo+-- pure $ GreenBlueBuffer+-- { gbSize = maxQueueSize+-- , gbVector = buf+-- , gbReadSection = readSection+-- , gbPendingWrites = writeCount+-- }++-- isEmpty :: GreenBlueBuffer a -> STM Bool+-- isEmpty = do+-- c <- readTVar gbPendingWrites+-- pure (c == 0)++-- data InsertResult = ValueDropped | ValueInserted++-- tryInsert :: GreenBlueBuffer a -> a -> IO InsertResult+-- tryInsert GreenBlueBuffer{..} x = atomically $ do+-- c <- readTVar gbPendingWrites+-- if c == gbMaxLength+-- then pure ValueDropped+-- else do+-- greenOrBlue <- readTVar gbWriteGreenOrBlue+-- let i = c + ((M.length gbVector `shiftR` 1) `shiftL` (greenOrBlue `mod` 2))+-- M.write gbVector i x+-- writeTVar gbPendingWrites (c + 1)+-- pure ValueInserted++-- Caution, single writer means that this can't be called concurrently+-- consumeChunk :: GreenBlueBuffer a -> IO (V.Vector a)+-- consumeChunk GreenBlueBuffer{..} = atomically $ do+-- r <- readTVar gbReadSection+-- w <- readTVar gbWriteSection+-- c <- readTVar gbPendingWrites+-- when (r == w) $ do+-- modifyTVar gbWriteSection (+ 1)+-- setTVar gbPendingWrites 0+-- -- TODO slice and freeze appropriate section+-- M.slice (gbSectionSize * (r .&. gbSectionMask)++data BoundedMap a = BoundedMap+ { itemBounds :: !Int+ , itemMaxExportBounds :: !Int+ , itemCount :: !Int+ , itemMap :: HashMap InstrumentationLibrary (Builder.Builder a)+ }+++boundedMap :: Int -> Int -> BoundedMap a+boundedMap bounds exportBounds = BoundedMap bounds exportBounds 0 mempty+++push :: ImmutableSpan -> BoundedMap ImmutableSpan -> Maybe (BoundedMap ImmutableSpan)+push s m =+ if itemCount m >= itemBounds m+ then Nothing+ else+ Just $!+ m+ { itemCount = itemCount m + 1+ , itemMap =+ HashMap.insertWith+ (<>)+ (tracerName $ spanTracer s)+ (Builder.singleton s)+ $ itemMap m+ }+++buildExport :: BoundedMap a -> (BoundedMap a, HashMap InstrumentationLibrary (Vector a))+buildExport m =+ ( m {itemCount = 0, itemMap = mempty}+ , Builder.build <$> itemMap m+ )+++data ProcessorMessage = ScheduledFlush | MaxExportFlush | FlushRequested | Shutdown+++-- note: [Unmasking Asyncs]+--+-- It is possible to create unkillable asyncs. Behold:+--+-- ```+-- a <- uninterruptibleMask_ $ do+-- async $ do+-- forever $ do+-- threadDelay 10_000+-- putStrLn "still alive"+-- cancel a+-- ```+--+-- The prior code block will never successfully cancel `a` and will be+-- blocked forever. The reason is that `cancel` sends an async exception to+-- the thread performing the action, but the `uninterruptibleMask` state is+-- inherited by the forked thread. This means that *no async exceptions*+-- can reach it, and `cancel` will therefore run forever.+--+-- This also affects `timeout`, which uses an async exception to kill the+-- running job. If the action is done in an uninterruptible masked state,+-- then the timeout will not successfully kill the running action.++{- |+ The batch processor accepts spans and places them into batches. Batching helps better compress the data and reduce the number of outgoing connections+ required to transmit the data. This processor supports both size and time based batching.++ NOTE: this function requires the program be compiled with the @-threaded@ GHC+ option and will throw an error if this is not the case.+-}+batchProcessor :: (MonadIO m) => BatchTimeoutConfig -> SpanExporter -> m SpanProcessor+batchProcessor BatchTimeoutConfig {..} exporter = liftIO $ do+ unless rtsSupportsBoundThreads $ error "The hs-opentelemetry batch processor does not work without the -threaded GHC flag!"+ batch <- newIORef $ boundedMap maxQueueSize maxExportBatchSize+ droppedRef <- newIORef (0 :: Int)+ warnedRef <- newIORef False+ workSignal <- newEmptyTMVarIO+ shutdownSignal <- newEmptyTMVarIO+ flushRequestSignal <- newEmptyTMVarIO+ flushDoneSignal <- newEmptyTMVarIO+ let timeoutMicros = millisToMicros exportTimeoutMillis++ let publish batchToProcess = do+ mResult <-+ timeout timeoutMicros $+ mask_ $+ SpanExporter.spanExporterExport exporter batchToProcess+ pure $ case mResult of+ Nothing -> SpanExporter.Failure Nothing+ Just r -> r++ -- Split a batch map into a chunk of at most n items and a remainder.+ let splitBatch n m = go n (HashMap.toList m) [] []+ where+ go _ [] chunkAcc restAcc = (HashMap.fromList chunkAcc, HashMap.fromList restAcc)+ go 0 remaining chunkAcc restAcc = (HashMap.fromList chunkAcc, HashMap.fromList (restAcc ++ remaining))+ go remaining ((lib, vec) : rest) chunkAcc restAcc+ | V.length vec <= remaining =+ go (remaining - V.length vec) rest ((lib, vec) : chunkAcc) restAcc+ | otherwise =+ let (front, back) = V.splitAt remaining vec+ in go 0 rest ((lib, front) : chunkAcc) ((lib, back) : restAcc)++ let publishBounded batchMap+ | HashMap.null batchMap = pure SpanExporter.Success+ | sum (V.length <$> HashMap.elems batchMap) <= maxExportBatchSize =+ publish batchMap+ | otherwise = do+ let (chunk, rest) = splitBatch maxExportBatchSize batchMap+ res <- publish chunk+ case res of+ SpanExporter.Failure _ -> pure res+ SpanExporter.Success -> publishBounded rest++ let flushQueueImmediately ret = do+ batchToProcess <- atomicModifyIORef' batch buildExport+ if null batchToProcess+ then pure ret+ else do+ ret' <- publishBounded batchToProcess+ flushQueueImmediately ret'++ -- Shutdown and FlushRequested are tried before work signals so they+ -- cannot be starved under sustained high throughput.+ let waiting = do+ delay <- registerDelay (millisToMicros scheduledDelayMillis)+ atomically $+ msum+ [ Shutdown <$ takeTMVar shutdownSignal+ , FlushRequested <$ takeTMVar flushRequestSignal+ , MaxExportFlush <$ takeTMVar workSignal+ , ScheduledFlush <$ do+ continue <- readTVar delay+ check continue+ ]++ let workerAction = do+ req <- waiting+ batchToProcess <- atomicModifyIORef' batch buildExport+ res <- publishBounded batchToProcess++ case req of+ Shutdown ->+ flushQueueImmediately res+ FlushRequested -> do+ _ <- flushQueueImmediately res+ atomically $ putTMVar flushDoneSignal ()+ workerAction+ _ ->+ workerAction+ -- see note [Unmasking Asyncs]+ worker <- asyncWithUnmask $ \unmask -> unmask workerAction++ pure $+ SpanProcessor+ { spanProcessorOnStart = \_ _ -> pure ()+ , spanProcessorOnEnd = \s -> do+ (dropped, exportNeeded) <- atomicModifyIORef' batch $ \builder ->+ case push s builder of+ Nothing -> (builder, (True, True))+ Just b' ->+ if itemCount b' >= itemMaxExportBounds b'+ then (b', (False, True))+ else (b', (False, False))+ when dropped $ warnOnDrop droppedRef warnedRef maxQueueSize "BatchSpanProcessor"+ when exportNeeded $ void $ atomically $ tryPutTMVar workSignal ()+ , spanProcessorForceFlush = do+ atomically $ putTMVar flushRequestSignal ()+ atomically $ takeTMVar flushDoneSignal+ SpanExporter.spanExporterForceFlush exporter+ , -- TODO where to call restore, if anywhere?+ spanProcessorShutdown =+ mask $ \_restore -> do+ -- we use interruptible `mask` because the shutdown action is+ -- likely to happen inside of a `finally` or `bracket`. the+ -- @safe-exceptions@ pattern (followed by unliftio as well)+ -- will use uninterruptibleMask in an exception cleanup. the+ -- uninterruptibleMask state means that the `timeout` call+ -- below will never exit, because `wait worker` will be in the+ -- `uninterruptibleMasked` state, and the timeout async+ -- exception will not be delivered.+ --+ -- see note [Unmasking Asyncs]++ -- flush remaining messages and signal the worker to shutdown+ void $ atomically $ putTMVar shutdownSignal ()++ -- gracefully wait for the worker to stop. we may be in+ -- a `bracket` or responding to an async exception, so we+ -- must be very careful not to wait too long. the following+ -- STM action will block, so we'll be susceptible to an async+ -- exception.+ delay <- registerDelay (millisToMicros exportTimeoutMillis)+ shutdownResult <-+ atomically $+ msum+ [ Just <$> waitCatchSTM worker+ , Nothing <$ do+ shouldStop <- readTVar delay+ check shouldStop+ ]++ -- make sure the worker comes down if we timed out.+ cancel worker+ -- OTel spec: Processor.Shutdown MUST shut down the exporter+ _ <- SpanExporter.spanExporterShutdown exporter++ pure $ case shutdownResult of+ Nothing ->+ ShutdownTimeout+ Just er ->+ case er of+ Left _ ->+ ShutdownFailure+ Right _ ->+ ShutdownSuccess+ }+ where+ millisToMicros = (* 1000)+++{-+buffer <- newGreenBlueBuffer _ _+batchProcessorAction <- async $ forever $ do+ -- It would be nice to do an immediate send when possible+ chunk <- if (sendDelay == 0)+ else consumeChunk+ then threadDelay sendDelay >> consumeChunk+ timeout _ $ export exporter chunk+pure $ Processor+ { onStart = \_ _ -> pure ()+ , onEnd = \s -> void $ tryInsert buffer s+ , shutdown = do+ gracefullyShutdownBatchProcessor++ , forceFlush = pure ()+ }+where+ sendDelay = scheduledDelayMilis * 1_000+-}++warnOnDrop :: IORef Int -> IORef Bool -> Int -> String -> IO ()+warnOnDrop droppedRef warnedRef capacity processorName = do+ n <- atomicModifyIORef' droppedRef (\c -> let c' = c + 1 in (c', c'))+ alreadyWarned <- atomicModifyIORef' warnedRef (\w -> (True, w))+ unless alreadyWarned $+ otelLogWarning $+ processorName+ <> ": queue full (capacity "+ <> show capacity+ <> "), dropping span. Total dropped so far: "+ <> show n
src/OpenTelemetry/Processor/Simple.hs view
@@ -1,64 +1,11 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-+{- |+Module : OpenTelemetry.Processor.Simple+Description : Re-exports for simple (synchronous) processors.+Stability : experimental+-} module OpenTelemetry.Processor.Simple (- SimpleProcessorConfig (..),- simpleProcessor,+ module OpenTelemetry.Processor.Simple.Span, ) where -import Control.Concurrent.Async-import Control.Concurrent.Chan.Unagi-import Control.Exception-import Control.Monad-import qualified Data.HashMap.Strict as HashMap-import Data.IORef-import qualified OpenTelemetry.Exporter as Exporter-import OpenTelemetry.Processor-import OpenTelemetry.Trace.Core (ImmutableSpan, spanTracer, tracerName)---newtype SimpleProcessorConfig = SimpleProcessorConfig- { exporter :: Exporter.Exporter ImmutableSpan- -- ^ The exporter where the spans are pushed.- }---{- | This is an implementation of SpanProcessor which passes finished spans- and passes the export-friendly span data representation to the configured SpanExporter,- as soon as they are finished.-- @since 0.0.1.0--}-simpleProcessor :: SimpleProcessorConfig -> IO Processor-simpleProcessor SimpleProcessorConfig {..} = do- (inChan :: InChan (IORef ImmutableSpan), outChan :: OutChan (IORef ImmutableSpan)) <- newChan- exportWorker <- async $ forever $ do- -- TODO, masking vs bracket here, not sure what's the right choice- spanRef <- readChanOnException outChan (>>= writeChan inChan)- span_ <- readIORef spanRef- mask_ (exporter `Exporter.exporterExport` HashMap.singleton (tracerName $ spanTracer span_) (pure span_))+import OpenTelemetry.Processor.Simple.Span - pure $- Processor- { processorOnStart = \_ _ -> pure ()- , processorOnEnd = writeChan inChan- , processorShutdown = async $ mask $ \restore -> do- cancel exportWorker- -- TODO handle timeouts- restore $ do- -- TODO, not convinced we should shut down processor here- shutdownProcessor outChan `finally` Exporter.exporterShutdown exporter- pure ShutdownSuccess- , processorForceFlush = pure ()- }- where- shutdownProcessor :: OutChan (IORef ImmutableSpan) -> IO ()- shutdownProcessor outChan = do- (Element m, _) <- tryReadChan outChan- mSpan <- m- case mSpan of- Nothing -> pure ()- Just spanRef -> do- span_ <- readIORef spanRef- _ <- exporter `Exporter.exporterExport` HashMap.singleton (tracerName $ spanTracer span_) (pure span_)- shutdownProcessor outChan
+ src/OpenTelemetry/Processor/Simple/LogRecord.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module OpenTelemetry.Processor.Simple.LogRecord (+ SimpleLogRecordProcessorConfig (..),+ simpleLogRecordProcessor,+) where++import Control.Concurrent.Async+import Control.Concurrent.STM+import Control.Exception (mask_)+import Control.Monad+import Data.IORef+import qualified Data.Vector as V+import OpenTelemetry.Internal.Common.Types (ShutdownResult (..))+import OpenTelemetry.Internal.Log.Types+import OpenTelemetry.Internal.Logging (otelLogWarning)+++data SimpleLogRecordProcessorConfig = SimpleLogRecordProcessorConfig+ { simpleLogRecordExporter :: LogRecordExporter+ , simpleLogRecordExportTimeoutMicros :: !Int+ -- ^ Timeout for individual export calls in microseconds. Default: 30s.+ }+++defaultSimpleQueueBound :: Int+defaultSimpleQueueBound = 2048+++simpleLogRecordProcessor :: SimpleLogRecordProcessorConfig -> IO LogRecordProcessor+simpleLogRecordProcessor SimpleLogRecordProcessorConfig {..} = do+ queue <- newTBQueueIO (fromIntegral defaultSimpleQueueBound)+ droppedRef <- newIORef (0 :: Int)+ warnedRef <- newIORef False+ shutdownVar <- newTVarIO False+ flushReq <- newEmptyTMVarIO+ flushDone <- newEmptyTMVarIO++ let exportOne rw = do+ readable <- mkReadableLogRecord rw+ mask_ (logRecordExporterExport simpleLogRecordExporter (V.singleton readable))++ let drainQueue = do+ mRw <- atomically $ tryReadTBQueue queue+ case mRw of+ Nothing -> pure ()+ Just rw -> do+ _ <- exportOne rw+ drainQueue++ let workerLoop = do+ cmd <-+ atomically $+ msum+ [ Nothing <$ (readTVar shutdownVar >>= check)+ , Just Nothing <$ takeTMVar flushReq+ , Just . Just <$> readTBQueue queue+ ]+ case cmd of+ Nothing -> do+ drainQueue+ void $ atomically $ tryPutTMVar flushDone ()+ Just Nothing -> do+ drainQueue+ atomically $ putTMVar flushDone ()+ workerLoop+ Just (Just rw) -> do+ _ <- exportOne rw+ workerLoop++ exportWorker <- async workerLoop++ pure+ LogRecordProcessor+ { logRecordProcessorOnEmit = \lr _ctxt -> do+ written <- atomically $ do+ full <- isFullTBQueue queue+ if full then pure False else writeTBQueue queue lr >> pure True+ unless written $ do+ n <- atomicModifyIORef' droppedRef (\c -> let c' = c + 1 in (c', c'))+ alreadyWarned <- atomicModifyIORef' warnedRef (\w -> (True, w))+ unless alreadyWarned $+ otelLogWarning $+ "SimpleLogRecordProcessor: queue full (capacity "+ <> show defaultSimpleQueueBound+ <> "), dropping log record. Total dropped so far: "+ <> show n+ , logRecordProcessorShutdown = do+ atomically $ writeTVar shutdownVar True+ wait exportWorker+ logRecordExporterShutdown simpleLogRecordExporter+ pure ShutdownSuccess+ , logRecordProcessorForceFlush = do+ isShut <- readTVarIO shutdownVar+ unless isShut $ do+ atomically $ putTMVar flushReq ()+ atomically $ takeTMVar flushDone+ logRecordExporterForceFlush simpleLogRecordExporter+ }
+ src/OpenTelemetry/Processor/Simple/Span.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module OpenTelemetry.Processor.Simple.Span (+ SimpleProcessorConfig (..),+ simpleProcessor,+) where++import Control.Concurrent.Async+import Control.Concurrent.STM+import Control.Exception (mask_)+import Control.Monad+import qualified Data.HashMap.Strict as HashMap+import Data.IORef+import qualified OpenTelemetry.Exporter.Span as SpanExporter+import OpenTelemetry.Internal.Logging (otelLogWarning)+import OpenTelemetry.Processor.Span+import OpenTelemetry.Trace.Core (spanTracer, tracerName)+++data SimpleProcessorConfig = SimpleProcessorConfig+ { spanExporter :: SpanExporter.SpanExporter+ -- ^ The exporter where the spans are pushed.+ , simpleSpanExportTimeoutMicros :: !Int+ -- ^ Timeout for individual export calls in microseconds. Default: 30s.+ }+++defaultSimpleQueueBound :: Int+defaultSimpleQueueBound = 2048+++{- | This is an implementation of SpanProcessor which passes finished spans+ and passes the export-friendly span data representation to the configured SpanExporter,+ as soon as they are finished.++ Uses a bounded queue internally. Spans that arrive while the queue is full+ are dropped and counted per @otel.sdk.processor.span.processed@ with+ @error.type=queue_full@ (OTel SDK semconv).++ @since 0.0.1.0+-}+simpleProcessor :: SimpleProcessorConfig -> IO SpanProcessor+simpleProcessor SimpleProcessorConfig {..} = do+ queue <- newTBQueueIO (fromIntegral defaultSimpleQueueBound)+ droppedRef <- newIORef (0 :: Int)+ warnedRef <- newIORef False+ shutdownVar <- newTVarIO False+ flushReq <- newEmptyTMVarIO+ flushDone <- newEmptyTMVarIO++ let exportOne span_ =+ mask_ (spanExporter `SpanExporter.spanExporterExport` HashMap.singleton (tracerName $ spanTracer span_) (pure span_))++ let drainQueue = do+ mSpan <- atomically $ tryReadTBQueue queue+ case mSpan of+ Nothing -> pure ()+ Just span_ -> do+ _ <- exportOne span_+ drainQueue++ -- Cooperative worker: checks shutdown and flush signals via STM rather+ -- than relying on async exceptions, avoiding the race where cancel+ -- arrives between readTBQueue and mask_ and drops an in-flight span.+ let workerLoop = do+ cmd <-+ atomically $+ msum+ [ Nothing <$ (readTVar shutdownVar >>= check)+ , Just Nothing <$ takeTMVar flushReq+ , Just . Just <$> readTBQueue queue+ ]+ case cmd of+ Nothing -> do+ drainQueue+ void $ atomically $ tryPutTMVar flushDone ()+ Just Nothing -> do+ drainQueue+ atomically $ putTMVar flushDone ()+ workerLoop+ Just (Just span_) -> do+ _ <- exportOne span_+ workerLoop++ exportWorker <- async workerLoop++ pure $+ SpanProcessor+ { spanProcessorOnStart = \_ _ -> pure ()+ , spanProcessorOnEnd = \s -> do+ written <- atomically $ do+ full <- isFullTBQueue queue+ if full then pure False else writeTBQueue queue s >> pure True+ unless written $ do+ n <- atomicModifyIORef' droppedRef (\c -> let c' = c + 1 in (c', c'))+ alreadyWarned <- atomicModifyIORef' warnedRef (\w -> (True, w))+ unless alreadyWarned $+ otelLogWarning $+ "SimpleSpanProcessor: queue full (capacity "+ <> show defaultSimpleQueueBound+ <> "), dropping span. Total dropped so far: "+ <> show n+ , spanProcessorShutdown = do+ atomically $ writeTVar shutdownVar True+ wait exportWorker+ _ <- SpanExporter.spanExporterShutdown spanExporter+ pure ShutdownSuccess+ , spanProcessorForceFlush = do+ isShut <- readTVarIO shutdownVar+ unless isShut $ do+ atomically $ putTMVar flushReq ()+ atomically $ takeTMVar flushDone+ SpanExporter.spanExporterForceFlush spanExporter+ }
+ src/OpenTelemetry/Resource/Cloud/Detector.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : OpenTelemetry.Resource.Cloud.Detector+Copyright : (c) Ian Duncan, 2024+License : BSD-3+Description : Auto-detect cloud provider resource attributes from environment variables+Maintainer : Ian Duncan+Stability : experimental+Portability : non-portable (GHC extensions)++Detects cloud provider, region, and platform from well-known environment+variables set by AWS, GCP, and Azure runtimes. This covers the common case+where services run on managed compute (ECS, Lambda, Cloud Run, App Service,+etc.) and the runtime injects env vars.++For full instance metadata (account ID, instance ID, availability zone),+use IMDS-based detection. That requires an HTTP client and is left to+a future @hs-opentelemetry-resource-detector-aws@ (or similar) package.++@since 0.1.0.2+-}+module OpenTelemetry.Resource.Cloud.Detector (+ detectCloud,+) where++import Data.Maybe (fromMaybe)+import OpenTelemetry.Resource.Cloud (Cloud (..))+import OpenTelemetry.Resource.Detector.Internal (firstEnv, lookupEnvText)+++-- | @since 0.0.1.0+detectCloud :: IO Cloud+detectCloud =+ fmap (fromMaybe emptyCloud) $+ detectAWS `orElse` detectGCP `orElse` detectAzure+ where+ orElse a b =+ a >>= \case+ Just r -> pure (Just r)+ Nothing -> b+++emptyCloud :: Cloud+emptyCloud =+ Cloud+ { cloudProvider = Nothing+ , cloudAccountId = Nothing+ , cloudRegion = Nothing+ , cloudAvailabilityZone = Nothing+ , cloudPlatform = Nothing+ , cloudResourceId = Nothing+ }+++-- AWS detection via environment variables injected by ECS, Lambda, Beanstalk, etc.+-- When KUBERNETES_SERVICE_HOST is present and no more specific platform matches,+-- falls back to aws_eks as a heuristic.+detectAWS :: IO (Maybe Cloud)+detectAWS = do+ mRegion <- firstEnv ["AWS_REGION", "AWS_DEFAULT_REGION"]+ mLambda <- lookupEnvText "AWS_LAMBDA_FUNCTION_NAME"+ mEcs <- lookupEnvText "ECS_CONTAINER_METADATA_URI_V4"+ mEcsLegacy <- lookupEnvText "ECS_CONTAINER_METADATA_URI"+ mBeanstalk <- lookupEnvText "ELASTIC_BEANSTALK_ENVIRONMENT_NAME"+ mAppRunner <- lookupEnvText "AWS_APP_RUNNER_SERVICE_ID"+ mExecEnv <- lookupEnvText "AWS_EXECUTION_ENV"++ let isAws =+ any+ (/= Nothing)+ [mRegion, mLambda, mEcs, mEcsLegacy, mBeanstalk, mAppRunner, mExecEnv]++ if not isAws+ then pure Nothing+ else do+ mAz <- lookupEnvText "AWS_AVAILABILITY_ZONE"+ mAcct <- lookupEnvText "AWS_ACCOUNT_ID"+ mK8sHost <- lookupEnvText "KUBERNETES_SERVICE_HOST"+ let platform = case () of+ _+ | mLambda /= Nothing -> Just "aws_lambda"+ | mEcs /= Nothing || mEcsLegacy /= Nothing -> Just "aws_ecs"+ | mBeanstalk /= Nothing -> Just "aws_elastic_beanstalk"+ | mAppRunner /= Nothing -> Just "aws_app_runner"+ | mExecEnv == Just "AWS_ECS_EC2" -> Just "aws_ecs"+ | mExecEnv == Just "AWS_ECS_FARGATE" -> Just "aws_ecs"+ | mK8sHost /= Nothing -> Just "aws_eks"+ | otherwise -> Nothing+ pure $+ Just+ Cloud+ { cloudProvider = Just "aws"+ , cloudAccountId = mAcct+ , cloudRegion = mRegion+ , cloudAvailabilityZone = mAz+ , cloudPlatform = platform+ , cloudResourceId = Nothing+ }+++-- GCP detection via environment variables set by Cloud Run, Cloud Functions,+-- App Engine, and Compute Engine.+detectGCP :: IO (Maybe Cloud)+detectGCP = do+ mProject <- firstEnv ["GOOGLE_CLOUD_PROJECT", "GCLOUD_PROJECT", "GCP_PROJECT"]+ mCloudRun <- lookupEnvText "K_SERVICE"+ mCloudFn <- lookupEnvText "FUNCTION_TARGET"+ mAppEngine <- lookupEnvText "GAE_SERVICE"+ mGaeEnv <- lookupEnvText "GAE_ENV"++ let isGcp =+ any+ (/= Nothing)+ [mProject, mCloudRun, mCloudFn, mAppEngine, mGaeEnv]++ if not isGcp+ then pure Nothing+ else do+ mRegion <- firstEnv ["GOOGLE_CLOUD_REGION", "FUNCTION_REGION"]+ let platform = case () of+ _+ | mCloudRun /= Nothing -> Just "gcp_cloud_run"+ | mCloudFn /= Nothing -> Just "gcp_cloud_functions"+ | mAppEngine /= Nothing || mGaeEnv /= Nothing -> Just "gcp_app_engine"+ | otherwise -> Nothing+ pure $+ Just+ Cloud+ { cloudProvider = Just "gcp"+ , cloudAccountId = mProject+ , cloudRegion = mRegion+ , cloudAvailabilityZone = Nothing+ , cloudPlatform = platform+ , cloudResourceId = Nothing+ }+++-- Azure detection via environment variables set by App Service, Functions, etc.+detectAzure :: IO (Maybe Cloud)+detectAzure = do+ mWebsite <- lookupEnvText "WEBSITE_SITE_NAME"+ mFunctions <- lookupEnvText "FUNCTIONS_WORKER_RUNTIME"+ mContainerApp <- lookupEnvText "CONTAINER_APP_NAME"+ mAzureEnv <- lookupEnvText "AZURE_FUNCTIONS_ENVIRONMENT"++ let isAzure =+ any+ (/= Nothing)+ [mWebsite, mFunctions, mContainerApp, mAzureEnv]++ if not isAzure+ then pure Nothing+ else do+ mRegion <- lookupEnvText "REGION_NAME"+ mSub <- lookupEnvText "AZURE_SUBSCRIPTION_ID"+ let platform+ | mFunctions /= Nothing || mAzureEnv /= Nothing = Just "azure.functions"+ | mContainerApp /= Nothing = Just "azure.container_apps"+ | mWebsite /= Nothing = Just "azure.app_service"+ | otherwise = Nothing+ pure $+ Just+ Cloud+ { cloudProvider = Just "azure"+ , cloudAccountId = mSub+ , cloudRegion = mRegion+ , cloudAvailabilityZone = Nothing+ , cloudPlatform = platform+ , cloudResourceId = Nothing+ }
+ src/OpenTelemetry/Resource/Container/Detector.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : OpenTelemetry.Resource.Container.Detector+Copyright : (c) Ian Duncan, 2024+License : BSD-3+Description : Auto-detect container resource attributes+Maintainer : Ian Duncan+Stability : experimental+Portability : non-portable (GHC extensions)++Detects whether the process is running inside a container and extracts+the container ID and runtime. Works on Linux via the @\/proc@ filesystem;+returns an empty 'Container' on other platforms.++Container ID extraction supports both cgroup v1 and cgroup v2.++@since 0.1.0.2+-}+module OpenTelemetry.Resource.Container.Detector (+ detectContainer,+) where++import Data.Maybe (listToMaybe, mapMaybe)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import OpenTelemetry.Resource.Container (Container (..))+import System.IO.Error (tryIOError)+++-- | @since 0.0.1.0+detectContainer :: IO Container+detectContainer = do+ cid <- detectContainerId+ rt <- detectRuntime+ pure+ Container+ { containerName = Nothing+ , containerId = cid+ , containerRuntime = rt+ , containerImageName = Nothing+ , containerImageTag = Nothing+ , containerImageId = Nothing+ , ociManifestDigest = Nothing+ , containerImageRepoDigests = Nothing+ }+++detectContainerId :: IO (Maybe T.Text)+detectContainerId = do+ v1 <- tryReadFile "/proc/self/cgroup"+ case v1 >>= parseCgroupV1Id of+ Just cid -> pure (Just cid)+ Nothing -> do+ mi <- tryReadFile "/proc/self/mountinfo"+ pure (mi >>= parseMountInfoId)+++parseCgroupV1Id :: T.Text -> Maybe T.Text+parseCgroupV1Id contents =+ listToMaybe $ mapMaybe extractFromLine (T.lines contents)+ where+ extractFromLine line =+ case T.splitOn ":" line of+ [_, _, path] -> extractIdFromPath path+ _ -> Nothing++ extractIdFromPath path+ | T.null path = Nothing+ | path == "/" = Nothing+ | otherwise =+ let seg = T.takeWhileEnd (/= '/') path+ in if isHexId seg then Just seg else Nothing+++parseMountInfoId :: T.Text -> Maybe T.Text+parseMountInfoId contents =+ listToMaybe $ mapMaybe extractFromLine (T.lines contents)+ where+ extractFromLine line =+ let parts = T.words line+ in case filter containsContainerId parts of+ (p : _) -> extractLastHexSegment p+ [] -> Nothing++ containsContainerId part =+ T.isInfixOf "/docker/containers/" part+ || T.isInfixOf "/containerd/" part+ || T.isInfixOf "/cri-o/" part+ || T.isInfixOf "/pods/" part++ extractLastHexSegment path =+ let seg = T.takeWhileEnd (/= '/') path+ in if isHexId seg then Just seg else Nothing+++isHexId :: T.Text -> Bool+isHexId t =+ T.length t >= 12 && T.all isHexChar t+ where+ isHexChar c = (c >= '0' && c <= '9') || (c >= 'a' && c <= 'f') || (c >= 'A' && c <= 'F')+++detectRuntime :: IO (Maybe T.Text)+detectRuntime = do+ dockerEnv <- tryReadFile "/.dockerenv"+ containerEnv <- tryReadFile "/run/.containerenv"+ cgroupContent <- tryReadFile "/proc/self/cgroup"+ pure $ case (dockerEnv, containerEnv, cgroupContent) of+ (Just _, _, _) -> Just "docker"+ (_, Just _, _) -> Just "podman"+ (_, _, Just cg)+ | T.isInfixOf "containerd" cg -> Just "containerd"+ | T.isInfixOf "cri-o" cg -> Just "cri-o"+ | T.isInfixOf "/docker/" cg -> Just "docker"+ | T.isInfixOf "/lxc/" cg -> Just "lxc"+ _ -> Nothing+++tryReadFile :: FilePath -> IO (Maybe T.Text)+tryReadFile path = do+ result <- tryIOError (T.readFile path)+ pure $ case result of+ Right content | not (T.null content) -> Just content+ _ -> Nothing
+ src/OpenTelemetry/Resource/Detect.hs view
@@ -0,0 +1,193 @@+{- FOURMOLU_DISABLE -}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- |+Module : OpenTelemetry.Resource.Detect+Copyright : (c) Ian Duncan, 2024-2026+License : BSD-3+Description : Shared resource detection orchestration for trace and metrics SDK initialization.+Stability : experimental++Shared resource detection orchestration used by both the trace and+metrics SDK initialization paths. Separated to avoid circular module+dependencies between @OpenTelemetry.Trace@ and @OpenTelemetry.Metric@.+-}+module OpenTelemetry.Resource.Detect (+ detectBuiltInResources,+ registerBuiltinResourceDetectors,+ detectResourceAttributes,+) where++import Control.Exception (SomeException, catch)+import Control.Monad (foldM)+import qualified Data.ByteString.Char8 as B+import qualified Data.HashMap.Strict as H+{- FOURMOLU_DISABLE -}+#if !MIN_VERSION_base(4,20,0)+import Data.List (foldl')+#endif+{- FOURMOLU_ENABLE -}+import Data.Maybe (mapMaybe)+import qualified Data.Set as Set+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8)+import OpenTelemetry.Attributes.Attribute (Attribute, ToAttribute (..))+import OpenTelemetry.Baggage (decodeBaggageHeader)+import qualified OpenTelemetry.Baggage as Baggage+import OpenTelemetry.Internal.Logging (otelLogError, otelLogWarning)+import qualified OpenTelemetry.Registry as Registry+import OpenTelemetry.Resource+import OpenTelemetry.Resource.Cloud ()+import OpenTelemetry.Resource.Cloud.Detector (detectCloud)+import OpenTelemetry.Resource.Container ()+import OpenTelemetry.Resource.Container.Detector (detectContainer)+import OpenTelemetry.Resource.Detector.AWS.EC2 (detectEC2Self)+import OpenTelemetry.Resource.Detector.AWS.ECS (detectECSSelf)+import OpenTelemetry.Resource.Detector.AWS.EKS (detectEKSSelf)+import OpenTelemetry.Resource.Detector.Azure (detectAzureVMSelf)+import OpenTelemetry.Resource.Detector.GCP (detectGCPComputeSelf)+import OpenTelemetry.Resource.Detector.Heroku (detectHeroku)+import OpenTelemetry.Resource.FaaS (FaaS)+import OpenTelemetry.Resource.FaaS.Detector (detectFaaS)+import OpenTelemetry.Resource.Host ()+import OpenTelemetry.Resource.Host.Detector (detectHost)+import OpenTelemetry.Resource.Kubernetes (Cluster, Namespace, Node, Pod)+import OpenTelemetry.Resource.Kubernetes.Detector (KubernetesResources (..), detectKubernetes)+import OpenTelemetry.Resource.OperatingSystem ()+import OpenTelemetry.Resource.OperatingSystem.Detector (detectOperatingSystem)+import OpenTelemetry.Resource.Process ()+import OpenTelemetry.Resource.Process.Detector (detectProcess, detectProcessRuntime)+import OpenTelemetry.Resource.Service ()+import OpenTelemetry.Resource.Service.Detector (detectService)+import OpenTelemetry.Resource.Telemetry ()+import OpenTelemetry.Resource.Telemetry.Detector (detectTelemetry)+import System.Environment (lookupEnv)+++{- | Register all built-in resource detectors in the global registry.+Idempotent: uses 'Registry.registerResourceDetectorIfAbsent'.++@since 0.1.0.2+-}+registerBuiltinResourceDetectors :: IO ()+registerBuiltinResourceDetectors = do+ _ <- Registry.registerResourceDetectorIfAbsent "service" (toResource <$> detectService)+ _ <- Registry.registerResourceDetectorIfAbsent "telemetry" (pure $ toResource detectTelemetry)+ _ <- Registry.registerResourceDetectorIfAbsent "process_runtime" (pure $ toResource detectProcessRuntime)+ _ <- Registry.registerResourceDetectorIfAbsent "process" (toResource <$> detectProcess)+ _ <- Registry.registerResourceDetectorIfAbsent "os" (toResource <$> detectOperatingSystem)+ _ <- Registry.registerResourceDetectorIfAbsent "host" (toResource <$> detectHost)+ _ <- Registry.registerResourceDetectorIfAbsent "container" (toResource <$> detectContainer)+ _ <- Registry.registerResourceDetectorIfAbsent "cloud" (toResource <$> detectCloud)+ _ <- Registry.registerResourceDetectorIfAbsent "faas" (mergeOptionalFaaS <$> detectFaaS)+ _ <- Registry.registerResourceDetectorIfAbsent "kubernetes" (mergeOptionalK8s <$> detectKubernetes)+ _ <- Registry.registerResourceDetectorIfAbsent "aws_ecs" detectECSSelf+ _ <- Registry.registerResourceDetectorIfAbsent "aws_ec2" detectEC2Self+ _ <- Registry.registerResourceDetectorIfAbsent "aws_eks" detectEKSSelf+ _ <- Registry.registerResourceDetectorIfAbsent "gcp" detectGCPComputeSelf+ _ <- Registry.registerResourceDetectorIfAbsent "azure_vm" detectAzureVMSelf+ _ <- Registry.registerResourceDetectorIfAbsent "heroku" detectHeroku+ pure ()+++builtinDetectorOrder :: [T.Text]+builtinDetectorOrder =+ [ "telemetry"+ , "service"+ , "process_runtime"+ , "process"+ , "os"+ , "host"+ , "container"+ , "cloud"+ , "faas"+ , "kubernetes"+ , "aws_ec2"+ , "aws_ecs"+ , "aws_eks"+ , "gcp"+ , "azure_vm"+ , "heroku"+ ]+++allDetectorsInDefaultOrder :: H.HashMap T.Text (IO Resource) -> [IO Resource]+allDetectorsInDefaultOrder allDetectors =+ let orderedBuiltins = mapMaybe (`H.lookup` allDetectors) builtinDetectorOrder+ builtinNames = Set.fromList builtinDetectorOrder+ extraDetectors =+ H.elems $+ H.filterWithKey (\k _ -> not (k `Set.member` builtinNames)) allDetectors+ in orderedBuiltins ++ extraDetectors+++{- | Use all registered resource detectors to populate resource information.++Reads @OTEL_RESOURCE_DETECTORS@ (comma-separated) to control which detectors+run. The special value @all@ (the default) runs every registered detector.++@since 0.0.1.0+-}+detectBuiltInResources :: IO Resource+detectBuiltInResources = do+ mFilter <- lookupEnv "OTEL_RESOURCE_DETECTORS"+ registerBuiltinResourceDetectors+ allDetectors <- Registry.registeredResourceDetectors+ activeDetectors <- case mFilter of+ Nothing -> pure $ allDetectorsInDefaultOrder allDetectors+ Just filterStr ->+ let names = fmap T.strip $ T.splitOn "," $ T.pack filterStr+ in if names == ["all"]+ then pure $ allDetectorsInDefaultOrder allDetectors+ else+ foldM+ ( \acc name -> case H.lookup name allDetectors of+ Just d -> pure (acc <> [d])+ Nothing -> do+ otelLogWarning ("Unknown resource detector '" <> T.unpack name <> "' in OTEL_RESOURCE_DETECTORS, ignoring")+ pure acc+ )+ []+ names+ resources <- mapM runDetectorSafely activeDetectors+ pure $ foldl' mergeResources (mkResource []) resources+ where+ runDetectorSafely :: IO Resource -> IO Resource+ runDetectorSafely detector =+ detector `catch` \(ex :: SomeException) -> do+ otelLogWarning $ "Resource detector failed, skipping: " <> show ex+ pure (mkResource [])+++-- | Parse @OTEL_RESOURCE_ATTRIBUTES@ into key-value pairs.+detectResourceAttributes :: IO [(T.Text, Attribute)]+detectResourceAttributes = do+ mEnv <- lookupEnv "OTEL_RESOURCE_ATTRIBUTES"+ case mEnv of+ Nothing -> pure []+ Just envVar -> case decodeBaggageHeader $ B.pack envVar of+ Left err -> do+ otelLogError $ "Failed to parse OTEL_RESOURCE_ATTRIBUTES: " <> err+ pure []+ Right ok ->+ pure $+ map (\(k, v) -> (decodeUtf8 $ Baggage.tokenValue k, toAttribute $ Baggage.value v)) $+ H.toList $+ Baggage.values ok+++mergeOptionalFaaS :: Maybe FaaS -> Resource+mergeOptionalFaaS Nothing = mkResource []+mergeOptionalFaaS (Just faas) = toResource faas+++mergeOptionalK8s :: Maybe KubernetesResources -> Resource+mergeOptionalK8s Nothing = mkResource []+mergeOptionalK8s (Just KubernetesResources {..}) =+ toResource (k8sCluster :: Cluster)+ `mergeResources` toResource (k8sNamespace :: Namespace)+ `mergeResources` toResource (k8sNode :: Node)+ `mergeResources` toResource (k8sPod :: Pod)
+ src/OpenTelemetry/Resource/Detector/AWS/EC2.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : OpenTelemetry.Resource.Detector.AWS.EC2+Copyright : (c) Ian Duncan, 2024+License : BSD-3+Description : Detect EC2 instance resource attributes via IMDS+Maintainer : Ian Duncan+Stability : experimental++Queries the EC2 Instance Metadata Service (IMDS) to populate rich resource+attributes for services running on EC2 instances.++Uses IMDSv2 (session-oriented, token-based) with a 2-second timeout.+Falls back to IMDSv1 if token acquisition fails. Returns an empty+'Resource' if not running on EC2.++Populates: @cloud.provider@, @cloud.platform@, @cloud.region@,+@cloud.availability_zone@, @cloud.account_id@, @host.id@, @host.type@,+@host.name@, @host.image.id@.++@since 0.1.0.2+-}+module OpenTelemetry.Resource.Detector.AWS.EC2 (+ detectEC2,+ detectEC2Self,+) where++import Data.Aeson (FromJSON (..), withObject, (.:?))+import Data.Text (Text)+import OpenTelemetry.Attributes.Key (unkey)+import OpenTelemetry.Resource (Resource, mkResource, (.=), (.=?))+import OpenTelemetry.Resource.Detector.Metadata+import qualified OpenTelemetry.SemanticConventions as SC+import System.Environment (lookupEnv)+++imdsBase :: String+imdsBase = "http://169.254.169.254/latest"+++tokenEndpoint :: String+tokenEndpoint = imdsBase ++ "/api/token"+++metadataPath :: String -> String+metadataPath p = imdsBase ++ "/meta-data/" ++ p+++{- | Self-contained EC2 detector suitable for the resource detector registry.+Checks for AWS env vars first, creates its own 'MetadataClient', then+queries IMDS. Returns an empty resource if not on AWS or IMDS is unreachable.+-}+detectEC2Self :: IO Resource+detectEC2Self = do+ mRegion <- lookupEnv "AWS_REGION"+ mDefault <- lookupEnv "AWS_DEFAULT_REGION"+ mExecEnv <- lookupEnv "AWS_EXECUTION_ENV"+ -- Also check for ECS. If on ECS, the ECS detector is more specific+ mEcs <- lookupEnv "ECS_CONTAINER_METADATA_URI_V4"+ let isNonEcsAws = any (/= Nothing) [mRegion, mDefault, mExecEnv] && mEcs == Nothing+ if isNonEcsAws+ then do+ client <- newMetadataClient+ detectEC2 client+ else pure $ mkResource []+++{- | Detect EC2 instance attributes via IMDS with an existing client.+Returns an empty resource if IMDS is unreachable.+-}+detectEC2 :: MetadataClient -> IO Resource+detectEC2 client = do+ mToken <- acquireIMDSv2Token client+ let fetch path = fetchWithToken client mToken (metadataPath path)+ mInstanceId <- fetch "instance-id"+ case mInstanceId of+ Nothing -> pure $ mkResource []+ Just instanceId -> do+ mInstanceType <- fetch "instance-type"+ mAmiId <- fetch "ami-id"+ mHostname <- fetch "hostname"+ mAz <- fetch "placement/availability-zone"+ mRegion <- fetch "placement/region"+ mAcctId <- fetchAccountId client mToken+ pure $+ mkResource+ [ unkey SC.cloud_provider .= ("aws" :: Text)+ , unkey SC.cloud_platform .= ("aws_ec2" :: Text)+ , unkey SC.cloud_region .=? mRegion+ , unkey SC.cloud_availabilityZone .=? mAz+ , unkey SC.cloud_account_id .=? mAcctId+ , unkey SC.host_id .= instanceId+ , unkey SC.host_type .=? mInstanceType+ , unkey SC.host_name .=? mHostname+ , unkey SC.host_image_id .=? mAmiId+ ]+++acquireIMDSv2Token :: MetadataClient -> IO (Maybe Text)+acquireIMDSv2Token client =+ putForText+ client+ tokenEndpoint+ [("X-aws-ec2-metadata-token-ttl-seconds", "21600")]+++fetchWithToken :: MetadataClient -> Maybe Text -> String -> IO (Maybe Text)+fetchWithToken client mToken url = case mToken of+ Just token -> fetchTextWithHeaders client url [("X-aws-ec2-metadata-token", token)]+ Nothing -> fetchText client url+++data IdentityDocument = IdentityDocument+ { idAccountId :: Maybe Text+ }+++instance FromJSON IdentityDocument where+ parseJSON = withObject "IdentityDocument" $ \o ->+ IdentityDocument <$> o .:? "accountId"+++fetchAccountId :: MetadataClient -> Maybe Text -> IO (Maybe Text)+fetchAccountId client mToken = do+ let url = imdsBase ++ "/dynamic/instance-identity/document"+ mDoc <- case mToken of+ Just token ->+ fetchJSONWithHeaders client url [("X-aws-ec2-metadata-token", token)]+ Nothing ->+ fetchJSON client url+ pure $ mDoc >>= idAccountId
+ src/OpenTelemetry/Resource/Detector/AWS/ECS.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : OpenTelemetry.Resource.Detector.AWS.ECS+Copyright : (c) Ian Duncan, 2024+License : BSD-3+Description : Detect ECS task and container resource attributes+Maintainer : Ian Duncan+Stability : experimental++Queries the ECS container metadata endpoint (v4) to populate resource+attributes for services running on Amazon ECS (both EC2 and Fargate+launch types).++Returns an empty 'Resource' if @ECS_CONTAINER_METADATA_URI_V4@ is not set.++Populates: @cloud.provider@, @cloud.platform@, @cloud.region@,+@cloud.account_id@, @cloud.availability_zone@, @aws.ecs.task.arn@,+@aws.ecs.task.family@, @aws.ecs.task.revision@, @aws.ecs.cluster.arn@,+@aws.ecs.launchtype@, @container.id@, @container.name@,+@aws.ecs.container.arn@, @aws.log.group.names@, @aws.log.stream.names@.++@since 0.1.0.2+-}+module OpenTelemetry.Resource.Detector.AWS.ECS (+ detectECS,+ detectECSSelf,+) where++import Data.Aeson (FromJSON (..), withObject, (.:), (.:?))+import Data.Maybe (listToMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import OpenTelemetry.Attributes (Attribute)+import OpenTelemetry.Attributes.Key (unkey)+import OpenTelemetry.Resource (Resource, mkResource, (.=), (.=?))+import OpenTelemetry.Resource.Detector.Metadata+import qualified OpenTelemetry.SemanticConventions as SC+import System.Environment (lookupEnv)+++{- | Self-contained ECS detector suitable for the resource detector registry.+Creates its own 'MetadataClient'. Returns an empty resource if+@ECS_CONTAINER_METADATA_URI_V4@ is not set.+-}+detectECSSelf :: IO Resource+detectECSSelf = do+ client <- newMetadataClient+ detectECS client+++{- | Detect ECS task metadata from the container metadata endpoint.+Returns an empty resource if not running on ECS.+-}+detectECS :: MetadataClient -> IO Resource+detectECS client = do+ mUri <- lookupEnv "ECS_CONTAINER_METADATA_URI_V4"+ case mUri of+ Nothing -> pure $ mkResource []+ Just uri -> do+ mTask <- fetchJSON client (uri ++ "/task") :: IO (Maybe TaskMetadata)+ mContainer <- fetchJSON client uri :: IO (Maybe ContainerMetadata)+ case mTask of+ Nothing -> pure $ mkResource []+ Just task -> do+ let arnParts = T.splitOn ":" (taskArn task)+ mRegion = safeIndex arnParts 3+ mAcctId = safeIndex arnParts 4+ cluster = normalizeArn (taskCluster task) arnParts "cluster"+ mAz = taskAvailabilityZone task+ launchType = T.toLower <$> taskLaunchType task++ containerAttrs :: [Maybe (Text, Attribute)]+ containerAttrs = case mContainer of+ Nothing -> []+ Just c ->+ [ unkey SC.container_name .= containerName c+ , unkey SC.container_id .=? containerDockerId c+ , unkey SC.aws_ecs_container_arn .=? containerArn c+ ]+ ++ logAttrs c++ pure $+ mkResource $+ [ unkey SC.cloud_provider .= ("aws" :: Text)+ , unkey SC.cloud_platform .= ("aws_ecs" :: Text)+ , unkey SC.cloud_region .=? mRegion+ , unkey SC.cloud_account_id .=? mAcctId+ , unkey SC.cloud_availabilityZone .=? mAz+ , unkey SC.aws_ecs_task_arn .= taskArn task+ , unkey SC.aws_ecs_task_family .= taskFamily task+ , unkey SC.aws_ecs_task_revision .= taskRevision task+ , unkey SC.aws_ecs_cluster_arn .= cluster+ , unkey SC.aws_ecs_launchtype .=? launchType+ ]+ ++ containerAttrs+++logAttrs :: ContainerMetadata -> [Maybe (Text, Attribute)]+logAttrs c = case containerLogDriver c of+ Just "awslogs" -> case containerLogOptions c of+ Just opts ->+ [ unkey SC.aws_log_group_names .=? logGroup opts+ , unkey SC.aws_log_stream_names .=? logStream opts+ ]+ Nothing -> []+ _ -> []+++-- JSON types for ECS metadata endpoint responses++data TaskMetadata = TaskMetadata+ { taskArn :: !Text+ , taskFamily :: !Text+ , taskRevision :: !Text+ , taskCluster :: !Text+ , taskAvailabilityZone :: !(Maybe Text)+ , taskLaunchType :: !(Maybe Text)+ }+++instance FromJSON TaskMetadata where+ parseJSON = withObject "TaskMetadata" $ \o ->+ TaskMetadata+ <$> o .: "TaskARN"+ <*> o .: "Family"+ <*> o .: "Revision"+ <*> o .: "Cluster"+ <*> o .:? "AvailabilityZone"+ <*> o .:? "LaunchType"+++data ContainerMetadata = ContainerMetadata+ { containerDockerId :: !(Maybe Text)+ , containerName :: !Text+ , containerArn :: !(Maybe Text)+ , containerLogDriver :: !(Maybe Text)+ , containerLogOptions :: !(Maybe LogOptions)+ }+++instance FromJSON ContainerMetadata where+ parseJSON = withObject "ContainerMetadata" $ \o ->+ ContainerMetadata+ <$> o .:? "DockerId"+ <*> o .: "Name"+ <*> o .:? "ContainerARN"+ <*> o .:? "LogDriver"+ <*> o .:? "LogOptions"+++data LogOptions = LogOptions+ { logGroup :: !(Maybe Text)+ , logStream :: !(Maybe Text)+ , _logRegion :: !(Maybe Text)+ }+++instance FromJSON LogOptions where+ parseJSON = withObject "LogOptions" $ \o ->+ LogOptions+ <$> o .:? "awslogs-group"+ <*> o .:? "awslogs-stream"+ <*> o .:? "awslogs-region"+++normalizeArn :: Text -> [Text] -> Text -> Text+normalizeArn val arnParts suffix+ | "arn:" `T.isPrefixOf` val = val+ | length arnParts >= 5 =+ let base = T.intercalate ":" (take 5 arnParts)+ in base <> ":" <> suffix <> "/" <> val+ | otherwise = val+++safeIndex :: [a] -> Int -> Maybe a+safeIndex xs i = listToMaybe (drop i xs)
+ src/OpenTelemetry/Resource/Detector/AWS/EKS.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : OpenTelemetry.Resource.Detector.AWS.EKS+Copyright : (c) Ian Duncan, 2024+License : BSD-3+Description : Detect AWS EKS resource attributes via the Kubernetes API+Maintainer : Ian Duncan+Stability : experimental++Detects whether the process is running on Amazon EKS by querying the+in-cluster Kubernetes API for the @aws-auth@ ConfigMap in the+@kube-system@ namespace. If present, sets @cloud.provider=aws@ and+@cloud.platform=aws_eks@.++Also attempts to read the cluster name from the @cluster-info@+ConfigMap in the @amazon-cloudwatch@ namespace (populated by the+CloudWatch agent or Fluentd DaemonSet).++TLS validation uses the in-cluster CA certificate at+@\/var\/run\/secrets\/kubernetes.io\/serviceaccount\/ca.crt@.+Authentication uses the service account bearer token at+@\/var\/run\/secrets\/kubernetes.io\/serviceaccount\/token@.++Returns an empty 'Resource' if not running on EKS or if the+Kubernetes API is unreachable.++Populates: @cloud.provider@, @cloud.platform@, @k8s.cluster.name@.++@since 0.1.0.2+-}+module OpenTelemetry.Resource.Detector.AWS.EKS (+ detectEKS,+ detectEKSSelf,+) where++import Data.Aeson (FromJSON (..), withObject, (.:?))+import qualified Data.HashMap.Strict as H+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import OpenTelemetry.Attributes.Key (unkey)+import OpenTelemetry.Resource (Resource, mkResource, (.=), (.=?))+import OpenTelemetry.Resource.Detector.Metadata+import qualified OpenTelemetry.SemanticConventions as SC+import System.Environment (lookupEnv)+import System.IO.Error (tryIOError)+++k8sTokenPath :: FilePath+k8sTokenPath = "/var/run/secrets/kubernetes.io/serviceaccount/token"+++k8sCertPath :: FilePath+k8sCertPath = "/var/run/secrets/kubernetes.io/serviceaccount/ca.crt"+++mkK8sApiUrl :: String -> String -> String -> String+mkK8sApiUrl host port path+ | ':' `elem` host = "https://[" ++ host ++ "]:" ++ port ++ path+ | otherwise = "https://" ++ host ++ ":" ++ port ++ path+++authConfigmapPath :: String+authConfigmapPath = "/api/v1/namespaces/kube-system/configmaps/aws-auth"+++clusterInfoPath :: String+clusterInfoPath = "/api/v1/namespaces/amazon-cloudwatch/configmaps/cluster-info"+++{- | Self-contained EKS detector suitable for the resource detector registry.++Checks for Kubernetes service account files and environment, then queries+the k8s API to confirm EKS. Skips if ECS or Lambda are detected (those+have more specific detectors). Returns an empty resource if not on EKS.+-}+detectEKSSelf :: IO Resource+detectEKSSelf = do+ mHost <- lookupEnv "KUBERNETES_SERVICE_HOST"+ case mHost of+ Nothing -> pure $ mkResource []+ Just host -> do+ mEcs <- lookupEnv "ECS_CONTAINER_METADATA_URI_V4"+ mLambda <- lookupEnv "AWS_LAMBDA_FUNCTION_NAME"+ if mEcs /= Nothing || mLambda /= Nothing+ then pure $ mkResource []+ else do+ mToken <- readFileStripped k8sTokenPath+ case mToken of+ Nothing -> pure $ mkResource []+ Just token -> do+ port <- fromMaybe "443" <$> lookupEnv "KUBERNETES_SERVICE_PORT"+ mClient <- newTlsMetadataClient k8sCertPath host+ case mClient of+ Nothing -> pure $ mkResource []+ Just client -> detectEKS client host port token+++{- | Detect EKS attributes by querying the in-cluster Kubernetes API.++Checks for the @aws-auth@ ConfigMap (EKS-specific) and reads the cluster+name from @cluster-info@ if available. Returns an empty resource if the+API is unreachable or the @aws-auth@ ConfigMap is absent.+-}+detectEKS :: MetadataClient -> String -> String -> Text -> IO Resource+detectEKS client host port token = do+ let bearerHeaders = [("Authorization", "Bearer " <> token)]+ authUrl = mkK8sApiUrl host port authConfigmapPath+ mAuthCm <- fetchJSONWithHeaders client authUrl bearerHeaders+ case (mAuthCm :: Maybe ConfigMapResponse) of+ Nothing -> pure $ mkResource []+ Just _ -> do+ let infoUrl = mkK8sApiUrl host port clusterInfoPath+ mClusterInfo <- fetchJSONWithHeaders client infoUrl bearerHeaders+ let mClusterName = mClusterInfo >>= cmLookupData "cluster.name"+ pure $+ mkResource+ [ unkey SC.cloud_provider .= ("aws" :: Text)+ , unkey SC.cloud_platform .= ("aws_eks" :: Text)+ , unkey SC.k8s_cluster_name .=? mClusterName+ ]+++readFileStripped :: FilePath -> IO (Maybe Text)+readFileStripped path = do+ result <- tryIOError (T.readFile path)+ pure $ case result of+ Right content+ | not (T.null (T.strip content)) -> Just (T.strip content)+ _ -> Nothing+++data ConfigMapResponse = ConfigMapResponse+ { cmData :: !(Maybe (H.HashMap Text Text))+ }+++instance FromJSON ConfigMapResponse where+ parseJSON = withObject "ConfigMapResponse" $ \o ->+ ConfigMapResponse <$> o .:? "data"+++cmLookupData :: Text -> ConfigMapResponse -> Maybe Text+cmLookupData key cm = cmData cm >>= H.lookup key
+ src/OpenTelemetry/Resource/Detector/Azure.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : OpenTelemetry.Resource.Detector.Azure+Copyright : (c) Ian Duncan, 2024+License : BSD-3+Description : Detect Azure VM resource attributes via IMDS+Maintainer : Ian Duncan+Stability : experimental++Queries the Azure Instance Metadata Service (IMDS) to populate resource+attributes for services running on Azure VMs.++Uses the non-routable endpoint @169.254.169.254@ with @Metadata: true@+header. Returns an empty 'Resource' if not running on Azure.++Populates: @cloud.provider@, @cloud.platform@, @cloud.region@,+@cloud.resource_id@, @host.id@, @host.name@, @host.type@,+@os.type@, @os.version@.++@since 0.1.0.2+-}+module OpenTelemetry.Resource.Detector.Azure (+ detectAzureVM,+ detectAzureVMSelf,+) where++import Data.Aeson (FromJSON (..), withObject, (.:?))+import Data.Text (Text)+import OpenTelemetry.Attributes.Key (unkey)+import OpenTelemetry.Resource (Resource, mkResource, (.=), (.=?))+import OpenTelemetry.Resource.Detector.Metadata+import qualified OpenTelemetry.SemanticConventions as SC+import System.Environment (lookupEnv)+++azureImdsEndpoint :: String+azureImdsEndpoint =+ "http://169.254.169.254/metadata/instance/compute?api-version=2021-12-13&format=json"+++azureHeaders :: [(Text, Text)]+azureHeaders = [("Metadata", "True")]+++{- | Self-contained Azure VM detector suitable for the resource detector+registry. Creates its own 'MetadataClient' and queries the Azure IMDS.+Returns an empty resource if not on Azure or IMDS is unreachable.+-}+detectAzureVMSelf :: IO Resource+detectAzureVMSelf = do+ client <- newMetadataClient+ detectAzureVM client+++{- | Detect Azure VM attributes via IMDS with an existing client.+Returns an empty resource if IMDS is unreachable.++When @KUBERNETES_SERVICE_HOST@ is set, the platform is reported as+@azure_aks@ instead of @azure_vm@.+-}+detectAzureVM :: MetadataClient -> IO Resource+detectAzureVM client = do+ mMeta <- fetchJSONWithHeaders client azureImdsEndpoint azureHeaders+ case mMeta of+ Nothing -> pure $ mkResource []+ Just meta -> do+ mK8sHost <- lookupEnv "KUBERNETES_SERVICE_HOST"+ let platform :: Text+ platform = case mK8sHost of+ Just _ -> "azure.aks"+ Nothing -> "azure.vm"+ pure $+ mkResource+ [ unkey SC.cloud_provider .= ("azure" :: Text)+ , unkey SC.cloud_platform .= platform+ , unkey SC.cloud_region .=? vmLocation meta+ , unkey SC.cloud_resourceId .=? vmResourceId meta+ , unkey SC.host_id .=? vmId meta+ , unkey SC.host_name .=? vmName meta+ , unkey SC.host_type .=? vmSize meta+ , unkey SC.os_type .=? vmOsType meta+ , unkey SC.os_version .=? vmOsVersion meta+ ]+++data AzureVMMetadata = AzureVMMetadata+ { vmId :: !(Maybe Text)+ , vmLocation :: !(Maybe Text)+ , vmResourceId :: !(Maybe Text)+ , vmName :: !(Maybe Text)+ , vmSize :: !(Maybe Text)+ , vmOsType :: !(Maybe Text)+ , vmOsVersion :: !(Maybe Text)+ }+++instance FromJSON AzureVMMetadata where+ parseJSON = withObject "AzureVMMetadata" $ \o ->+ AzureVMMetadata+ <$> o .:? "vmId"+ <*> o .:? "location"+ <*> o .:? "resourceId"+ <*> o .:? "name"+ <*> o .:? "vmSize"+ <*> o .:? "osType"+ <*> o .:? "version"
+ src/OpenTelemetry/Resource/Detector/GCP.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : OpenTelemetry.Resource.Detector.GCP+Copyright : (c) Ian Duncan, 2024+License : BSD-3+Description : Detect GCP Compute Engine resource attributes via the metadata server+Maintainer : Ian Duncan+Stability : experimental++Queries the GCP metadata server (@metadata.google.internal@) to populate+resource attributes for services running on GCP Compute Engine, GKE,+Cloud Run, etc.++All requests include the required @Metadata-Flavor: Google@ header.+Returns an empty 'Resource' if the metadata server is not reachable.++Populates: @cloud.provider@, @cloud.platform@, @cloud.region@,+@cloud.availability_zone@, @cloud.account_id@, @host.id@, @host.name@,+@host.type@.++@since 0.1.0.2+-}+module OpenTelemetry.Resource.Detector.GCP (+ detectGCPCompute,+ detectGCPComputeSelf,+) where++import Data.Text (Text)+import qualified Data.Text as T+import OpenTelemetry.Attributes.Key (unkey)+import OpenTelemetry.Resource (Resource, mkResource, (.=), (.=?))+import OpenTelemetry.Resource.Detector.Metadata+import qualified OpenTelemetry.SemanticConventions as SC+import System.Environment (lookupEnv)+++metadataBase :: String+metadataBase = "http://metadata.google.internal/computeMetadata/v1/"+++gcpHeaders :: [(Text, Text)]+gcpHeaders = [("Metadata-Flavor", "Google")]+++fetchGCP :: MetadataClient -> String -> IO (Maybe Text)+fetchGCP client path =+ fetchTextWithHeaders client (metadataBase ++ path) gcpHeaders+++{- | Self-contained GCP detector suitable for the resource detector registry.+Checks for GCP env vars first, creates its own 'MetadataClient', then+queries the metadata server. Returns an empty resource if not on GCP or+the metadata server is unreachable.+-}+detectGCPComputeSelf :: IO Resource+detectGCPComputeSelf = do+ mProject <- lookupEnv "GOOGLE_CLOUD_PROJECT"+ mGcloud <- lookupEnv "GCLOUD_PROJECT"+ mGcp <- lookupEnv "GCP_PROJECT"+ mKService <- lookupEnv "K_SERVICE"+ let isGcp = any (/= Nothing) [mProject, mGcloud, mGcp, mKService]+ if isGcp+ then do+ client <- newMetadataClient+ detectGCPCompute client+ else pure $ mkResource []+++{- | Detect GCP Compute Engine attributes via the metadata server.+Returns an empty resource if not running on GCP.++Also detects GKE by checking for @instance\/attributes\/cluster-name@+on the metadata server. If present, sets @cloud.platform@ to+@gcp_kubernetes_engine@ and populates @k8s.cluster.name@.+-}+detectGCPCompute :: MetadataClient -> IO Resource+detectGCPCompute client = do+ mProjectId <- fetchGCP client "project/project-id"+ case mProjectId of+ Nothing -> pure $ mkResource []+ Just projectId -> do+ mInstanceId <- fetchGCP client "instance/id"+ mInstanceName <- fetchGCP client "instance/name"+ mZone <- fetchGCP client "instance/zone"+ mMachineType <- fetchGCP client "instance/machine-type"+ mClusterName <- fetchGCP client "instance/attributes/cluster-name"++ let mAz = extractLastSegment <$> mZone+ mRegion = extractRegionFromZone =<< mAz+ mHostType = extractLastSegment <$> mMachineType+ platform :: Text+ platform = case mClusterName of+ Just _ -> "gcp_kubernetes_engine"+ Nothing -> "gcp_compute_engine"++ pure $+ mkResource+ [ unkey SC.cloud_provider .= ("gcp" :: Text)+ , unkey SC.cloud_platform .= platform+ , unkey SC.cloud_region .=? mRegion+ , unkey SC.cloud_availabilityZone .=? mAz+ , unkey SC.cloud_account_id .= projectId+ , unkey SC.host_id .=? mInstanceId+ , unkey SC.host_name .=? mInstanceName+ , unkey SC.host_type .=? mHostType+ , unkey SC.k8s_cluster_name .=? mClusterName+ ]+++-- Metadata server returns zone as "projects/{num}/zones/{zone}"+-- and machine-type as "projects/{num}/machineTypes/{type}".+extractLastSegment :: Text -> Text+extractLastSegment t = case T.splitOn "/" t of+ [] -> t+ parts -> last parts+++-- "us-central1-a" -> "us-central1"+extractRegionFromZone :: Text -> Maybe Text+extractRegionFromZone az =+ let parts = T.splitOn "-" az+ in if length parts >= 3+ then Just $ T.intercalate "-" (take (length parts - 1) parts)+ else Nothing
+ src/OpenTelemetry/Resource/Detector/Heroku.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : OpenTelemetry.Resource.Detector.Heroku+Copyright : (c) Ian Duncan, 2024+License : BSD-3+Description : Detect Heroku dyno resource attributes from environment+Maintainer : Ian Duncan+Stability : experimental++Reads Heroku dyno metadata from environment variables to populate+resource attributes per the+<https://opentelemetry.io/docs/specs/semconv/resource/cloud-provider/heroku/ Heroku semantic conventions>.++Returns an empty 'Resource' if not running on Heroku (i.e.+@HEROKU_APP_ID@ is not set).++Populates: @cloud.provider@, @heroku.app.id@, @heroku.release.commit@,+@heroku.release.creation_timestamp@, @service.name@,+@service.version@, @service.instance.id@.++@since 0.1.0.2+-}+module OpenTelemetry.Resource.Detector.Heroku (+ detectHeroku,+) where++import Data.Text (Text)+import OpenTelemetry.Attributes.Key (unkey)+import OpenTelemetry.Resource (Resource, mkResource, (.=), (.=?))+import OpenTelemetry.Resource.Detector.Internal (lookupEnvText)+import qualified OpenTelemetry.SemanticConventions as SC+++{- | Detect Heroku dyno attributes from environment variables.+Returns an empty resource if @HEROKU_APP_ID@ is not set.+-}+detectHeroku :: IO Resource+detectHeroku = do+ mAppId <- lookupEnvText "HEROKU_APP_ID"+ case mAppId of+ Nothing -> pure $ mkResource []+ Just appId -> do+ mAppName <- lookupEnvText "HEROKU_APP_NAME"+ mDynoId <- lookupEnvText "HEROKU_DYNO_ID"+ mReleaseVersion <- lookupEnvText "HEROKU_RELEASE_VERSION"+ mSlugCommit <- lookupEnvText "HEROKU_SLUG_COMMIT"+ mReleaseCreated <- lookupEnvText "HEROKU_RELEASE_CREATED_AT"+ pure $+ mkResource+ [ unkey SC.cloud_provider .= ("heroku" :: Text)+ , unkey SC.heroku_app_id .= appId+ , unkey SC.heroku_release_commit .=? mSlugCommit+ , unkey SC.heroku_release_creationTimestamp .=? mReleaseCreated+ , unkey SC.service_name .=? mAppName+ , unkey SC.service_version .=? mReleaseVersion+ , unkey SC.service_instance_id .=? mDynoId+ ]
+ src/OpenTelemetry/Resource/Detector/Internal.hs view
@@ -0,0 +1,22 @@+module OpenTelemetry.Resource.Detector.Internal (+ lookupEnvText,+ firstEnv,+) where++import qualified Data.Text as T+import System.Environment (lookupEnv)+++-- | Like 'lookupEnv' but returns 'T.Text' instead of 'String'.+lookupEnvText :: String -> IO (Maybe T.Text)+lookupEnvText key = fmap (T.pack <$>) (lookupEnv key)+++-- | Return the value of the first environment variable that is set.+firstEnv :: [String] -> IO (Maybe T.Text)+firstEnv [] = pure Nothing+firstEnv (k : ks) = do+ mVal <- lookupEnvText k+ case mVal of+ Just v -> pure (Just v)+ Nothing -> firstEnv ks
+ src/OpenTelemetry/Resource/Detector/Metadata.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++{- |+Module : OpenTelemetry.Resource.Detector.Metadata+Copyright : (c) Ian Duncan, 2024+License : BSD-3+Description : Shared HTTP utilities for metadata-based resource detectors+Maintainer : Ian Duncan+Stability : experimental++Low-level helpers for querying instance metadata services (AWS IMDS, GCP+metadata server, ECS task metadata, etc.).++All HTTP requests use a 2-second response timeout. On any failure+(timeout, connection refused, non-200 status, parse error), functions+return 'Nothing' rather than throwing.++@since 0.1.0.2+-}+module OpenTelemetry.Resource.Detector.Metadata (+ MetadataClient,+ newMetadataClient,+ newTlsMetadataClient,+ fetchText,+ fetchJSON,+ fetchTextWithHeaders,+ fetchJSONWithHeaders,+ putForText,+) where++import Control.Exception (SomeException, try)+import Data.Aeson (FromJSON, eitherDecode)+import qualified Data.ByteString.Lazy as BL+import qualified Data.CaseInsensitive as CI+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Network.HTTP.Client (+ Manager,+ Request (..),+ Response (..),+ defaultManagerSettings,+ httpLbs,+ managerResponseTimeout,+ newManager,+ parseRequest,+ responseTimeoutMicro,+ )+import Network.HTTP.Types.Status (statusCode)+++#ifdef TLS_METADATA+import Data.X509.CertificateStore (makeCertificateStore)+import Data.X509.File (readSignedObject)+import Network.Connection (TLSSettings (..))+import Network.HTTP.Client.TLS (mkManagerSettings)+import qualified Network.TLS as TLS+#endif+++{- | Opaque handle holding an HTTP 'Manager' configured with short timeouts+suitable for metadata service queries.+-}+newtype MetadataClient = MetadataClient Manager+++{- | Create a 'MetadataClient' with a 2-second response timeout.+Safe to share across multiple detector calls within a single+detection run.+-}+newMetadataClient :: IO MetadataClient+newMetadataClient =+ MetadataClient+ <$> newManager+ defaultManagerSettings+ { managerResponseTimeout = responseTimeoutMicro 2000000+ }+++{- | Create a 'MetadataClient' that validates TLS using a specific CA+certificate file (PEM or DER). Returns 'Nothing' if the CA cert cannot+be loaded, or if TLS support was disabled at build time.++Used by the EKS detector to make HTTPS calls to the in-cluster+Kubernetes API server using the service account CA at+@\/var\/run\/secrets\/kubernetes.io\/serviceaccount\/ca.crt@.++@since 0.1.0.2+-}+newTlsMetadataClient :: FilePath -> String -> IO (Maybe MetadataClient)+#ifdef TLS_METADATA+newTlsMetadataClient caCertPath hostname = do+ result <- try @SomeException $ do+ certs <- readSignedObject caCertPath+ let caStore = makeCertificateStore certs+ base = TLS.defaultParamsClient hostname ""+ shared = TLS.clientShared base+ params = base {TLS.clientShared = shared {TLS.sharedCAStore = caStore}}+ tlsSettings = TLSSettings params+ settings =+ (mkManagerSettings tlsSettings Nothing)+ { managerResponseTimeout = responseTimeoutMicro 2000000+ }+ mgr <- newManager settings+ pure (MetadataClient mgr)+ pure $ case result of+ Left _ -> Nothing+ Right v -> Just v+#else+newTlsMetadataClient _ _ = pure Nothing+#endif+++{- | Fetch a URL via GET and return the response body as 'Text',+or 'Nothing' on any failure.+-}+fetchText :: MetadataClient -> String -> IO (Maybe Text)+fetchText client url = fetchTextWithHeaders client url []+++-- | Fetch via GET with extra request headers.+fetchTextWithHeaders+ :: MetadataClient+ -> String+ -> [(Text, Text)]+ -> IO (Maybe Text)+fetchTextWithHeaders (MetadataClient mgr) url extraHeaders = do+ result <- try @SomeException $ do+ req0 <- parseRequest url+ let req =+ req0+ { requestHeaders =+ requestHeaders req0+ ++ fmap (\(k, v) -> (CI.mk (TE.encodeUtf8 k), TE.encodeUtf8 v)) extraHeaders+ }+ resp <- httpLbs req mgr+ if statusCode (responseStatus resp) == 200+ then pure $ Just $ T.strip $ TE.decodeUtf8 $ BL.toStrict $ responseBody resp+ else pure Nothing+ pure $ case result of+ Left _ -> Nothing+ Right v -> v+++{- | Issue a PUT request with extra headers and return the response body+as 'Text'. Used by IMDSv2 token acquisition.+-}+putForText+ :: MetadataClient+ -> String+ -> [(Text, Text)]+ -> IO (Maybe Text)+putForText (MetadataClient mgr) url extraHeaders = do+ result <- try @SomeException $ do+ req0 <- parseRequest url+ let req =+ req0+ { method = "PUT"+ , requestHeaders =+ requestHeaders req0+ ++ fmap (\(k, v) -> (CI.mk (TE.encodeUtf8 k), TE.encodeUtf8 v)) extraHeaders+ }+ resp <- httpLbs req mgr+ if statusCode (responseStatus resp) == 200+ then pure $ Just $ T.strip $ TE.decodeUtf8 $ BL.toStrict $ responseBody resp+ else pure Nothing+ pure $ case result of+ Left _ -> Nothing+ Right v -> v+++-- | Fetch a URL via GET, parse the response as JSON, or return 'Nothing'.+fetchJSON :: (FromJSON a) => MetadataClient -> String -> IO (Maybe a)+fetchJSON client url = fetchJSONWithHeaders client url []+++-- | Fetch via GET with extra headers, parse the response as JSON.+fetchJSONWithHeaders+ :: (FromJSON a)+ => MetadataClient+ -> String+ -> [(Text, Text)]+ -> IO (Maybe a)+fetchJSONWithHeaders (MetadataClient mgr) url extraHeaders = do+ result <- try @SomeException $ do+ req0 <- parseRequest url+ let req =+ req0+ { requestHeaders =+ requestHeaders req0+ ++ fmap (\(k, v) -> (CI.mk (TE.encodeUtf8 k), TE.encodeUtf8 v)) extraHeaders+ }+ resp <- httpLbs req mgr+ if statusCode (responseStatus resp) == 200+ then pure $ case eitherDecode (responseBody resp) of+ Left _ -> Nothing+ Right v -> Just v+ else pure Nothing+ pure $ case result of+ Left _ -> Nothing+ Right v -> v
+ src/OpenTelemetry/Resource/FaaS/Detector.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : OpenTelemetry.Resource.FaaS.Detector+Copyright : (c) Ian Duncan, 2024+License : BSD-3+Description : Auto-detect FaaS (serverless function) resource attributes+Maintainer : Ian Duncan+Stability : experimental+Portability : non-portable (GHC extensions)++Detects FaaS resource attributes from environment variables set by+serverless platforms:++* __AWS Lambda__: @AWS_LAMBDA_FUNCTION_NAME@, @AWS_LAMBDA_FUNCTION_VERSION@,+ @AWS_LAMBDA_LOG_STREAM_NAME@, @AWS_LAMBDA_FUNCTION_MEMORY_SIZE@+* __GCP Cloud Functions__: @FUNCTION_TARGET@, @K_REVISION@, @FUNCTION_MEMORY_MB@+* __Azure Functions__: @FUNCTIONS_WORKER_RUNTIME@, @WEBSITE_SITE_NAME@++Returns 'Nothing' when not running in a recognized FaaS environment.++@since 0.1.0.2+-}+module OpenTelemetry.Resource.FaaS.Detector (+ detectFaaS,+) where++import OpenTelemetry.Resource.Detector.Internal (lookupEnvText)+import OpenTelemetry.Resource.FaaS (FaaS (..))+import System.Environment (lookupEnv)+import Text.Read (readMaybe)+++-- | @since 0.0.1.0+detectFaaS :: IO (Maybe FaaS)+detectFaaS = do+ mLambda <- detectLambda+ case mLambda of+ Just faas -> pure (Just faas)+ Nothing -> do+ mGcf <- detectGCF+ case mGcf of+ Just faas -> pure (Just faas)+ Nothing -> detectAzureFunctions+++detectLambda :: IO (Maybe FaaS)+detectLambda = do+ mName <- lookupEnvText "AWS_LAMBDA_FUNCTION_NAME"+ case mName of+ Nothing -> pure Nothing+ Just name -> do+ mVersion <- lookupEnvText "AWS_LAMBDA_FUNCTION_VERSION"+ mLogStream <- lookupEnvText "AWS_LAMBDA_LOG_STREAM_NAME"+ mMemStr <- lookupEnv "AWS_LAMBDA_FUNCTION_MEMORY_SIZE"+ let mMem = fmap (* 1048576) (mMemStr >>= readMaybe)+ mRegion <- lookupEnvText "AWS_REGION"+ mAcctAndFn <- buildLambdaArn name mRegion+ pure $+ Just+ FaaS+ { faasName = name+ , faasCloudResourceId = mAcctAndFn+ , faasVersion = mVersion+ , faasInstance = mLogStream+ , faasMaxMemory = mMem+ }+ where+ buildLambdaArn name mRegion = do+ mAcct <- lookupEnvText "AWS_ACCOUNT_ID"+ pure $ do+ region <- mRegion+ acct <- mAcct+ Just $ "arn:aws:lambda:" <> region <> ":" <> acct <> ":function:" <> name+++-- Google Cloud Functions+detectGCF :: IO (Maybe FaaS)+detectGCF = do+ mTarget <- lookupEnvText "FUNCTION_TARGET"+ case mTarget of+ Nothing -> pure Nothing+ Just target -> do+ mRevision <- lookupEnvText "K_REVISION"+ mMemStr <- lookupEnv "FUNCTION_MEMORY_MB"+ let mMem = fmap (* 1048576) (mMemStr >>= readMaybe)+ pure $+ Just+ FaaS+ { faasName = target+ , faasCloudResourceId = Nothing+ , faasVersion = mRevision+ , faasInstance = Nothing+ , faasMaxMemory = mMem+ }+++detectAzureFunctions :: IO (Maybe FaaS)+detectAzureFunctions = do+ mRuntime <- lookupEnvText "FUNCTIONS_WORKER_RUNTIME"+ case mRuntime of+ Nothing -> pure Nothing+ Just _ -> do+ mSiteName <- lookupEnvText "WEBSITE_SITE_NAME"+ case mSiteName of+ Nothing -> pure Nothing+ Just siteName -> do+ -- Spec: Azure faas.name = "<WEBSITE_SITE_NAME>/<FUNCTION_NAME>"+ mFuncName <- lookupEnvText "FUNCTION_NAME"+ let name = case mFuncName of+ Just funcName -> siteName <> "/" <> funcName+ Nothing -> siteName+ pure $+ Just+ FaaS+ { faasName = name+ , faasCloudResourceId = Nothing+ , faasVersion = Nothing+ , faasInstance = Nothing+ , faasMaxMemory = Nothing+ }
src/OpenTelemetry/Resource/Host/Detector.hs view
@@ -1,12 +1,20 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-} +{- |+Module : OpenTelemetry.Resource.Host.Detector+Description : Resource detector for host attributes. Auto-detects hostname and architecture from the runtime environment.+Stability : experimental+-} module OpenTelemetry.Resource.Host.Detector ( detectHost, builtInHostDetectors, HostDetector, ) where +import Control.Exception (SomeException, try) import Control.Monad import qualified Data.Text as T import Network.BSD@@ -14,6 +22,13 @@ import System.Info (arch) +#if defined(linux_HOST_OS)+import qualified Data.Text.IO as TIO+#elif defined(darwin_HOST_OS)+import System.Process (readProcess)+#endif++ adaptedArch :: T.Text adaptedArch = case arch of "aarch64" -> "arm64"@@ -26,32 +41,79 @@ "powerpc64le" -> "ppc64" other -> T.pack other +#if defined(darwin_HOST_OS)+-- | Parse @\"IOPlatformUUID\" = \"…\"@ from @ioreg@ output (see OpenTelemetry host.id for macOS).+parseIOPlatformUUID :: T.Text -> Maybe T.Text+parseIOPlatformUUID txt = do+ line <- findIOPlatformUUIDLine txt+ parseUUIDFromLine line +findIOPlatformUUIDLine :: T.Text -> Maybe T.Text+findIOPlatformUUIDLine t = go (T.lines t)+ where+ go [] = Nothing+ go (l : ls) =+ if "IOPlatformUUID" `T.isInfixOf` l+ then Just l+ else go ls++parseUUIDFromLine :: T.Text -> Maybe T.Text+parseUUIDFromLine line = do+ let (_, rest) = T.breakOn "\" = \"" line+ guard $ not (T.null rest)+ let afterEq = T.drop (T.length "\" = \"") rest+ let (uuid, _) = T.breakOn "\"" afterEq+ guard $ not (T.null uuid)+ Just uuid+#endif+++-- | Best-effort @host.id@: @\/etc\/machine-id@ on Linux, @ioreg@ @IOPlatformUUID@ on Darwin; @Nothing@ elsewhere or on failure.+detectHostId :: IO (Maybe T.Text)+#if defined(linux_HOST_OS)+detectHostId = do+ er <-+ try @SomeException $+ do+ content <- TIO.readFile "/etc/machine-id"+ let tid = T.strip content+ pure $ if T.null tid then Nothing else Just tid+ pure $ either (const Nothing) id er+#elif defined(darwin_HOST_OS)+detectHostId = do+ er <-+ try @SomeException $+ do+ out <- readProcess "ioreg" ["-rd1", "-c", "IOPlatformExpertDevice"] ""+ pure $ parseIOPlatformUUID (T.pack out)+ pure $ either (const Nothing) id er+#else+detectHostId = pure Nothing+#endif++ -- | Detect as much host information as possible detectHost :: IO Host detectHost = do mhost <- foldM go Nothing builtInHostDetectors pure $ case mhost of- Nothing -> Host Nothing Nothing Nothing Nothing Nothing Nothing Nothing+ Nothing -> Host Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Just host -> host where go Nothing hostDetector = hostDetector go mhost@(Just _host) _ = pure mhost -{- | A set of detectors for e.g. AWS, GCP, and other cloud providers.+{- | Built-in host detectors. - Currently only emits hostName and hostArch. Additional detectors are- welcome via PR.+Cloud-specific host attributes (@host.type@, @host.image.id@, etc.) may be+refined by IMDS resource detectors (AWS EC2, GCP Compute, Azure VM). This+detector supplies @host.name@, @host.arch@, and on Linux\/macOS a non-cloud+@host.id@ when available. -} builtInHostDetectors :: [HostDetector] builtInHostDetectors =- [ -- TODO- -- AWS support- -- GCP support- -- any other user contributed- fallbackHostDetector- ]+ [fallbackHostDetector] type HostDetector = IO (Maybe Host)@@ -60,11 +122,13 @@ fallbackHostDetector :: HostDetector fallbackHostDetector = Just <$> do- let hostId = Nothing- hostType = Nothing+ hostId <- detectHostId+ let hostType = Nothing hostArch = Just adaptedArch hostImageName = Nothing hostImageId = Nothing hostImageVersion = Nothing+ hostIp = Nothing+ hostMac = Nothing hostName <- Just . T.pack <$> getHostName pure Host {..}
+ src/OpenTelemetry/Resource/Kubernetes/Detector.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : OpenTelemetry.Resource.Kubernetes.Detector+Copyright : (c) Ian Duncan, 2024+License : BSD-3+Description : Auto-detect Kubernetes resource attributes+Maintainer : Ian Duncan+Stability : experimental+Portability : non-portable (GHC extensions)++Detects Kubernetes resource attributes from the downward API, environment+variables, and mounted service account tokens. Returns empty resources+when not running in a Kubernetes cluster.++Detection sources:++* @KUBERNETES_SERVICE_HOST@: presence indicates k8s+* @HOSTNAME@: typically the pod name+* @\/var\/run\/secrets\/kubernetes.io\/serviceaccount\/namespace@: pod namespace+* @OTEL_RESOURCE_ATTRIBUTES@: may contain @k8s.cluster.name@, @k8s.node.name@, etc.++@since 0.1.0.2+-}+module OpenTelemetry.Resource.Kubernetes.Detector (+ detectKubernetes,+ isRunningInKubernetes,+ KubernetesResources (..),+) where++import qualified Data.Text as T+import qualified Data.Text.IO as T+import OpenTelemetry.Resource.Detector.Internal (lookupEnvText)+import OpenTelemetry.Resource.Kubernetes (Cluster (..), Namespace (..), Node (..), Pod)+import qualified OpenTelemetry.Resource.Kubernetes as K8s+import System.Environment (lookupEnv)+import System.IO.Error (tryIOError)+++-- | @since 0.0.1.0+isRunningInKubernetes :: IO Bool+isRunningInKubernetes = do+ mHost <- lookupEnv "KUBERNETES_SERVICE_HOST"+ pure $ case mHost of+ Just _ -> True+ Nothing -> False+++-- | @since 0.0.1.0+data KubernetesResources = KubernetesResources+ { k8sCluster :: Cluster+ , k8sNamespace :: Namespace+ , k8sNode :: Node+ , k8sPod :: Pod+ }+ deriving (Show)+++-- | @since 0.0.1.0+detectKubernetes :: IO (Maybe KubernetesResources)+detectKubernetes = do+ inK8s <- isRunningInKubernetes+ if not inK8s+ then pure Nothing+ else do+ cluster <- detectCluster+ ns <- detectNamespace+ node <- detectNode+ pod <- detectPod+ pure $+ Just+ KubernetesResources+ { k8sCluster = cluster+ , k8sNamespace = ns+ , k8sNode = node+ , k8sPod = pod+ }+++detectCluster :: IO Cluster+detectCluster = do+ mName <- lookupEnvText "K8S_CLUSTER_NAME"+ pure Cluster {clusterName = mName, clusterUid = Nothing}+++detectNamespace :: IO Namespace+detectNamespace = do+ mNs <- readNamespaceFile+ ns <- case mNs of+ Just n -> pure (Just n)+ Nothing -> lookupEnvText "K8S_NAMESPACE"+ pure Namespace {namespaceName = ns}+ where+ readNamespaceFile = do+ result <- tryIOError (T.readFile saNamespacePath)+ pure $ case result of+ Right content+ | not (T.null (T.strip content)) -> Just (T.strip content)+ _ -> Nothing+ saNamespacePath = "/var/run/secrets/kubernetes.io/serviceaccount/namespace"+++detectNode :: IO Node+detectNode = do+ mName <- lookupEnvText "K8S_NODE_NAME"+ pure Node {nodeName = mName, nodeUid = Nothing}+++detectPod :: IO Pod+detectPod = do+ mName <- lookupEnvText "K8S_POD_NAME"+ pName <- case mName of+ Just n -> pure (Just n)+ Nothing -> lookupEnvText "HOSTNAME"+ mUid <- lookupEnvText "K8S_POD_UID"+ pure K8s.Pod {K8s.podName = pName, K8s.podUid = mUid}
src/OpenTelemetry/Resource/OperatingSystem/Detector.hs view
@@ -18,27 +18,93 @@ detectOperatingSystem, ) where +import Control.Exception (try)+import Data.Maybe (mapMaybe) import qualified Data.Text as T+import qualified Data.Text.IO as T import OpenTelemetry.Resource.OperatingSystem+import System.IO.Error (tryIOError) import System.Info (os)+import System.Process (readProcess) -{- | Retrieve any infomration able to be detected about the current operation system.+{- | Retrieve any information able to be detected about the current operating system. - Currently only supports 'osType' detection, but PRs are welcome to support additional- details.+ Detects 'osType', 'osName', 'osVersion', and 'osDescription' on macOS and Linux.+ On other platforms, only 'osType' is populated. @since 0.0.1.0 -} detectOperatingSystem :: IO OperatingSystem-detectOperatingSystem =- pure $+detectOperatingSystem = do+ let osTypeVal =+ if os == "mingw32"+ then "windows"+ else T.pack os+ (name, ver, desc) <- detectOsDetails osTypeVal+ pure OperatingSystem- { osType =- if os == "mingw32"- then "windows"- else T.pack os- , osDescription = Nothing- , osName = Nothing- , osVersion = Nothing+ { osType = osTypeVal+ , osDescription = desc+ , osName = name+ , osVersion = ver+ , osBuildId = Nothing }+++detectOsDetails :: T.Text -> IO (Maybe T.Text, Maybe T.Text, Maybe T.Text)+detectOsDetails "darwin" = do+ name <- tryShellCommand "sw_vers" ["-productName"]+ ver <- tryShellCommand "sw_vers" ["-productVersion"]+ let desc = case (name, ver) of+ (Just n, Just v) -> Just (n <> " " <> v)+ _ -> Nothing+ pure (name, ver, desc)+detectOsDetails "linux" = do+ osRelease <- tryReadOsRelease+ case osRelease of+ Nothing -> pure (Nothing, Nothing, Nothing)+ Just content ->+ let fields = parseOsRelease content+ name = lookup "NAME" fields+ ver = lookup "VERSION_ID" fields+ desc = lookup "PRETTY_NAME" fields+ in pure (name, ver, desc)+detectOsDetails "windows" =+ pure (Just "Windows", Nothing, Nothing)+detectOsDetails _ =+ pure (Nothing, Nothing, Nothing)+++tryShellCommand :: String -> [String] -> IO (Maybe T.Text)+tryShellCommand cmd args = do+ result <- try (readProcess cmd args "") :: IO (Either IOError String)+ pure $ case result of+ Right output ->+ let trimmed = T.strip (T.pack output)+ in if T.null trimmed then Nothing else Just trimmed+ Left _ -> Nothing+++tryReadOsRelease :: IO (Maybe T.Text)+tryReadOsRelease = do+ result <- tryIOError (T.readFile "/etc/os-release")+ pure $ case result of+ Right content | not (T.null content) -> Just content+ _ -> Nothing+++parseOsRelease :: T.Text -> [(T.Text, T.Text)]+parseOsRelease content =+ mapMaybe parseLine (T.lines content)+ where+ parseLine line =+ case T.break (== '=') line of+ (key, rest)+ | not (T.null rest) ->+ Just (key, stripQuotes (T.drop 1 rest))+ _ -> Nothing+ stripQuotes t =+ case T.uncons t of+ Just ('"', rest) -> maybe rest fst (T.unsnoc rest)+ _ -> t
src/OpenTelemetry/Resource/Process/Detector.hs view
@@ -1,18 +1,22 @@ module OpenTelemetry.Resource.Process.Detector where -import Control.Exception (throwIO, try) import qualified Data.Text as T+import qualified Data.Text.IO as T+import Data.Time.Clock (getCurrentTime)+import Data.Time.Format.ISO8601 (iso8601Show) import Data.Version+import OpenTelemetry.Platform (tryGetParentProcessID, tryGetUser) import OpenTelemetry.Resource.Process+import System.Directory (getCurrentDirectory) import System.Environment ( getArgs, getExecutablePath, getProgName, )-import System.IO.Error+import System.IO (hIsTerminalDevice, stdin)+import System.IO.Error (tryIOError) import System.Info-import System.Posix.Process (getProcessID)-import System.Posix.User (getEffectiveUserName)+import System.PosixCompat.Process (getProcessID) {- | Create a 'Process' 'Resource' based off of the current process' knowledge@@ -22,25 +26,41 @@ -} detectProcess :: IO Process detectProcess = do+ progName <- getProgName+ args <- getArgs+ now <- getCurrentTime+ let allArgs = progName : args+ ppid <- tryGetParentProcessID+ cwd <- Just . T.pack <$> getCurrentDirectory+ interactive <- Just <$> hIsTerminalDevice stdin+ cgroup <- detectLinuxCgroup Process <$> (Just . fromIntegral <$> getProcessID)- <*> (Just . T.pack <$> getProgName)+ <*> pure (Just (T.pack progName)) <*> (Just . T.pack <$> getExecutablePath)- <*> pure Nothing+ <*> pure (Just (T.pack progName)) <*> pure Nothing- <*> (Just . map T.pack <$> getArgs)+ <*> pure (Just (fmap T.pack allArgs)) <*> tryGetUser+ <*> pure (Just (T.pack (iso8601Show now)))+ <*> pure (Just (length allArgs))+ <*> pure ppid+ <*> pure cwd+ <*> pure interactive+ <*> pure (Just (T.pack progName))+ <*> pure cgroup -tryGetUser :: IO (Maybe T.Text)-tryGetUser = do- eResult <- try getEffectiveUserName- case eResult of- Left err ->- if isDoesNotExistError err- then pure Nothing- else throwIO err- Right ok -> pure $ Just $ T.pack ok+detectLinuxCgroup :: IO (Maybe T.Text)+detectLinuxCgroup = do+ result <- tryIOError (T.readFile "/proc/self/cgroup")+ pure $ case result of+ Right content+ | not (T.null content) ->+ case T.lines content of+ (firstLine : _) -> Just (T.strip firstLine)+ _ -> Nothing+ _ -> Nothing {- | A 'ProcessRuntime' 'Resource' populated with the current process' knoweldge@@ -53,5 +73,6 @@ ProcessRuntime { processRuntimeName = Just $ T.pack compilerName , processRuntimeVersion = Just $ T.pack $ showVersion compilerVersion- , processRuntimeDescription = Nothing+ , processRuntimeDescription =+ Just $ T.pack $ compilerName <> " " <> showVersion compilerVersion }
src/OpenTelemetry/Resource/Service/Detector.hs view
@@ -7,6 +7,14 @@ {- | Detect a service name using the 'OTEL_SERVICE_NAME' environment variable. Otherwise, populates the name with 'unknown_service:process_name'.++ @service.instance.id@ is NOT auto-generated. The attribute is still+ experimental in semantic conventions, and no major SDK (Java, Go, Python)+ enables auto-generation by default — Java moved it to an opt-in incubator+ package, Go gates it behind a feature flag, and Python hasn\'t merged it at+ all. A random UUID per init also inflates metric cardinality and breaks+ cross-restart correlation. Users who want it can set it explicitly via+ resource attributes or environment configuration. -} detectService :: IO Service detectService = do@@ -20,4 +28,5 @@ , serviceNamespace = Nothing , serviceInstanceId = Nothing , serviceVersion = Nothing+ , serviceCriticality = Nothing }
src/OpenTelemetry/Resource/Telemetry/Detector.hs view
@@ -12,8 +12,9 @@ detectTelemetry :: Telemetry detectTelemetry = Telemetry- { telemetrySdkName = "hs-opentelemetry-sdk"+ { telemetrySdkName = "opentelemetry" , telemetrySdkLanguage = Just "haskell" , telemetrySdkVersion = Just $ T.pack $ showVersion version- , telemetryAutoVersion = Nothing+ , telemetryDistroName = Nothing+ , telemetryDistroVersion = Nothing }
+ src/OpenTelemetry/SDK.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE ScopedTypeVariables #-}++{- |+Module : OpenTelemetry.SDK+Copyright : (c) Ian Duncan, 2026+License : BSD-3+Description : Unified SDK initialization for all three signals (traces, metrics, logs).+Stability : stable++= Overview++This is the recommended entry point for applications using the+OpenTelemetry SDK. It initializes all three signal providers+(TracerProvider, MeterProvider, LoggerProvider) from environment+variables in a single call.++= Quick example++@+import OpenTelemetry.SDK++main :: IO ()+main = withOpenTelemetry $ \otel -> do+ let tracer = makeTracer (otelTracerProvider otel) "my-app" tracerOptions+ -- ... application code ...+@++All configuration is via the standard @OTEL_*@ environment variables:++* @OTEL_SERVICE_NAME@ — service name resource attribute+* @OTEL_TRACES_EXPORTER@ — trace exporter (default: @otlp@)+* @OTEL_METRICS_EXPORTER@ — metrics exporter (default: @otlp@)+* @OTEL_LOGS_EXPORTER@ — logs exporter (default: @otlp@)+* @OTEL_EXPORTER_OTLP_ENDPOINT@ — OTLP endpoint+* @OTEL_METRIC_EXPORT_INTERVAL@ — metrics export interval (ms, default: 60000)++See "OpenTelemetry.Trace", "OpenTelemetry.Metric", and "OpenTelemetry.Log"+for signal-specific configuration and per-signal initialization.+-}+module OpenTelemetry.SDK (+ -- * Unified initialization+ OTelSignals (..),+ initializeOpenTelemetry,+ withOpenTelemetry,+) where++import Control.Exception (SomeException, bracket, catch)+import Control.Monad (void)+import OpenTelemetry.Configuration.Create (OTelSignals (..))+import OpenTelemetry.Log (initializeGlobalLoggerProvider, shutdownLoggerProvider)+import OpenTelemetry.Metric (initializeGlobalMeterProvider, shutdownMeterProvider)+import OpenTelemetry.Trace (initializeGlobalTracerProvider, shutdownTracerProvider)+++{- | Initialize all three signal providers from @OTEL_*@ environment variables,+install them as globals, and return an 'OTelSignals' with a unified shutdown handle.++@since 1.0.0.0+-}+initializeOpenTelemetry :: IO OTelSignals+initializeOpenTelemetry = do+ tp <- initializeGlobalTracerProvider+ mp <- initializeGlobalMeterProvider+ lp <- initializeGlobalLoggerProvider+ let shutdown = do+ void (shutdownTracerProvider tp Nothing) `catch` \(_ :: SomeException) -> pure ()+ void (shutdownMeterProvider mp Nothing) `catch` \(_ :: SomeException) -> pure ()+ void (shutdownLoggerProvider lp Nothing) `catch` \(_ :: SomeException) -> pure ()+ pure+ OTelSignals+ { otelTracerProvider = tp+ , otelMeterProvider = mp+ , otelLoggerProvider = lp+ , otelPropagators = mempty+ , otelShutdown = shutdown+ }+++{- | Initialize all signal providers, run an action, then shut everything down.++@+main = withOpenTelemetry $ \otel -> do+ -- use otelTracerProvider, otelMeterProvider, otelLoggerProvider+ runMyApp+@++@since 1.0.0.0+-}+withOpenTelemetry :: (OTelSignals -> IO a) -> IO a+withOpenTelemetry = bracket initializeOpenTelemetry otelShutdown
src/OpenTelemetry/Trace.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} -----------------------------------------------------------------------------@@ -90,9 +91,11 @@ TracerProvider, initializeGlobalTracerProvider, initializeTracerProvider,+ withTracerProvider, getTracerProviderInitializationOptions, getTracerProviderInitializationOptions', shutdownTracerProvider,+ forceFlushTracerProvider, -- ** Getting / setting the global 'TracerProvider' getGlobalTracerProvider,@@ -107,6 +110,7 @@ tracerOptions, HasTracer (..), InstrumentationLibrary (..),+ detectInstrumentationLibrary, -- * 'Span' operations Span,@@ -115,6 +119,7 @@ SpanArguments (..), SpanKind (..), NewLink (..),+ addLink, inSpan', updateName, addAttribute,@@ -147,33 +152,45 @@ SpanContext (..), -- TODO, don't remember if this is okay with the spec or not ImmutableSpan (..),++ -- * Internal helpers re-exported for tests+ detectSpanLimits,+ detectBatchProcessorConfig,+ registerBuiltinResourceDetectors, ) where import qualified Data.ByteString.Char8 as B+import qualified Data.CaseInsensitive as CI import Data.Either (partitionEithers) import qualified Data.HashMap.Strict as H import Data.Maybe (fromMaybe) import qualified Data.Text as T-import Data.Text.Encoding (decodeUtf8)-import Network.HTTP.Types.Header+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Network.HTTP.Types (RequestHeaders) import OpenTelemetry.Attributes (AttributeLimits (..), defaultAttributeLimits) import OpenTelemetry.Baggage (decodeBaggageHeader) import qualified OpenTelemetry.Baggage as Baggage import OpenTelemetry.Context (Context)-import OpenTelemetry.Exporter (Exporter)-import OpenTelemetry.Exporter.OTLP (loadExporterEnvironmentVariables, otlpExporter)-import OpenTelemetry.Processor (Processor)-import OpenTelemetry.Processor.Batch (BatchTimeoutConfig (..), batchProcessor, batchTimeoutConfig)-import OpenTelemetry.Propagator (Propagator)+import OpenTelemetry.Environment+import OpenTelemetry.Exporter.OTLP.Span (loadExporterEnvironmentVariables, otlpExporter)+import OpenTelemetry.Exporter.Span (SpanExporter)+import OpenTelemetry.Processor.Batch.Span (BatchTimeoutConfig (..), batchProcessor, batchTimeoutConfig)+import OpenTelemetry.Processor.Span (SpanProcessor)+import OpenTelemetry.Propagator (+ Propagator (..),+ TextMap,+ TextMapPropagator,+ setGlobalTextMapPropagator,+ textMapFromList,+ textMapToList,+ ) import OpenTelemetry.Propagator.B3 (b3MultiTraceContextPropagator, b3TraceContextPropagator)+import OpenTelemetry.Propagator.Datadog (datadogTraceContextPropagator) import OpenTelemetry.Propagator.W3CBaggage (w3cBaggagePropagator) import OpenTelemetry.Propagator.W3CTraceContext (w3cTraceContextPropagator)+import qualified OpenTelemetry.Registry as Registry import OpenTelemetry.Resource-import OpenTelemetry.Resource.Host.Detector (detectHost)-import OpenTelemetry.Resource.OperatingSystem.Detector (detectOperatingSystem)-import OpenTelemetry.Resource.Process.Detector (detectProcess, detectProcessRuntime)-import OpenTelemetry.Resource.Service.Detector (detectService)-import OpenTelemetry.Resource.Telemetry.Detector (detectTelemetry)+import qualified OpenTelemetry.Resource.Detect as ResourceDetect import OpenTelemetry.Trace.Core import OpenTelemetry.Trace.Id.Generator.Default (defaultIdGenerator) import OpenTelemetry.Trace.Sampler (Sampler, alwaysOff, alwaysOn, parentBased, parentBasedOptions, traceIdRatioBased)@@ -221,21 +238,23 @@ {- $envGeneral - +---------------------------+---------------------------------------------------------------------------------------------------------------+------------------------------------------------------------------------------------------------------------------------------------------------+--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------+- | Name | Description | Default | Notes |- +===========================+===============================================================================================================+================================================================================================================================================+================================================================================================================================================================================================================================================================================+- | OTEL_RESOURCE_ATTRIBUTES | Key-value pairs to be used as resource attributes | See [Resource semantic conventions](resource/semantic_conventions/README.md#semantic-attributes-with-sdk-provided-default-value) for details. | See [Resource SDK](./resource/sdk.md#specifying-resource-information-via-an-environment-variable) for more details. |- +---------------------------+---------------------------------------------------------------------------------------------------------------+------------------------------------------------------------------------------------------------------------------------------------------------+--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------+- | OTEL_SERVICE_NAME | Sets the value of the [`service.name`](./resource/semantic_conventions/README.md#service) resource attribute | | If `service.name` is also provided in `OTEL_RESOURCE_ATTRIBUTES`, then `OTEL_SERVICE_NAME` takes precedence. |- +---------------------------+---------------------------------------------------------------------------------------------------------------+------------------------------------------------------------------------------------------------------------------------------------------------+--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------+- | OTEL_LOG_LEVEL | Log level used by the SDK logger | "info" | |- +---------------------------+---------------------------------------------------------------------------------------------------------------+------------------------------------------------------------------------------------------------------------------------------------------------+--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------+- | OTEL_PROPAGATORS | Propagators to be used as a comma-separated list | "tracecontext,baggage" | Values MUST be deduplicated in order to register a `Propagator` only once. |- +---------------------------+---------------------------------------------------------------------------------------------------------------+------------------------------------------------------------------------------------------------------------------------------------------------+--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------+- | OTEL_TRACES_SAMPLER | Sampler to be used for traces | "parentbased_always_on" | See [Sampling](./trace/sdk.md#sampling) |- +---------------------------+---------------------------------------------------------------------------------------------------------------+------------------------------------------------------------------------------------------------------------------------------------------------+--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------+- | OTEL_TRACES_SAMPLER_ARG | String value to be used as the sampler argument | | The specified value will only be used if OTEL_TRACES_SAMPLER is set. Each Sampler type defines its own expected input, if any. Invalid or unrecognized input MUST be logged and MUST be otherwise ignored, i.e. the SDK MUST behave as if OTEL_TRACES_SAMPLER_ARG is not set. |- +---------------------------+---------------------------------------------------------------------------------------------------------------+------------------------------------------------------------------------------------------------------------------------------------------------+--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------++ +---------------------------+---------------------------------------------------------------------------------------------------------------+------------------------------------------------------------------------------------------------------------------------------------------------+------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------++ | Name | Description | Default | Notes |+ +===========================+===============================================================================================================+================================================================================================================================================+==========================================================================================================================================================================================================================================================================================++ | OTEL_SDK_DISABLED | Disable the SDK for all signals | false | Boolean value. If “true”, a no-op SDK implementation will be used for all telemetry signals. Any other value or absence of the variable will have no effect and the SDK will remain enabled. This setting has no effect on propagators configured through the OTEL_PROPAGATORS variable. |+ +---------------------------+---------------------------------------------------------------------------------------------------------------+------------------------------------------------------------------------------------------------------------------------------------------------+------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------++ | OTEL_RESOURCE_ATTRIBUTES | Key-value pairs to be used as resource attributes | See [Resource semantic conventions](resource/semantic_conventions/README.md#semantic-attributes-with-sdk-provided-default-value) for details. | See [Resource SDK](./resource/sdk.md#specifying-resource-information-via-an-environment-variable) for more details. |+ +---------------------------+---------------------------------------------------------------------------------------------------------------+------------------------------------------------------------------------------------------------------------------------------------------------+------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------++ | OTEL_SERVICE_NAME | Sets the value of the [`service.name`](./resource/semantic_conventions/README.md#service) resource attribute | | If `service.name` is also provided in `OTEL_RESOURCE_ATTRIBUTES`, then `OTEL_SERVICE_NAME` takes precedence. |+ +---------------------------+---------------------------------------------------------------------------------------------------------------+------------------------------------------------------------------------------------------------------------------------------------------------+------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------++ | OTEL_LOG_LEVEL | Log level used by the SDK logger | "info" | |+ +---------------------------+---------------------------------------------------------------------------------------------------------------+------------------------------------------------------------------------------------------------------------------------------------------------+------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------++ | OTEL_PROPAGATORS | Propagators to be used as a comma-separated list | "tracecontext,baggage" | Values MUST be deduplicated in order to register a `Propagator` only once. |+ +---------------------------+---------------------------------------------------------------------------------------------------------------+------------------------------------------------------------------------------------------------------------------------------------------------+------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------++ | OTEL_TRACES_SAMPLER | Sampler to be used for traces | "parentbased_always_on" | See [Sampling](./trace/sdk.md#sampling) |+ +---------------------------+---------------------------------------------------------------------------------------------------------------+------------------------------------------------------------------------------------------------------------------------------------------------+------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------++ | OTEL_TRACES_SAMPLER_ARG | String value to be used as the sampler argument | | The specified value will only be used if OTEL_TRACES_SAMPLER is set. Each Sampler type defines its own expected input, if any. Invalid or unrecognized input MUST be logged and MUST be otherwise ignored, i.e. the SDK MUST behave as if OTEL_TRACES_SAMPLER_ARG is not set. |+ +---------------------------+---------------------------------------------------------------------------------------------------------------+------------------------------------------------------------------------------------------------------------------------------------------------+------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------+ -} @@ -284,19 +303,46 @@ -} -knownPropagators :: [(T.Text, Propagator Context RequestHeaders ResponseHeaders)]+{- | Wrap a header-style propagator as a 'TextMapPropagator' for+'TracerProvider' / @OTEL_PROPAGATORS@ wiring.+-}+headerPropagatorToTextMap :: Propagator Context RequestHeaders RequestHeaders -> TextMapPropagator+headerPropagatorToTextMap (Propagator names ext inj) =+ Propagator names ext' inj'+ where+ ext' tm ctx = ext (textMapToRequestHeaders tm) ctx+ inj' ctx tm = do+ hs <- inj ctx (textMapToRequestHeaders tm)+ pure (requestHeadersToTextMap hs)+++textMapToRequestHeaders :: TextMap -> RequestHeaders+textMapToRequestHeaders tm =+ map (\(k, v) -> (CI.mk (encodeUtf8 k), encodeUtf8 v)) (textMapToList tm)+++requestHeadersToTextMap :: RequestHeaders -> TextMap+requestHeadersToTextMap =+ textMapFromList . map (\(name, val) -> (decodeUtf8 (CI.original name), decodeUtf8 val))+++knownPropagators :: [(T.Text, TextMapPropagator)] knownPropagators = [ ("tracecontext", w3cTraceContextPropagator) , ("baggage", w3cBaggagePropagator) , ("b3", b3TraceContextPropagator) , ("b3multi", b3MultiTraceContextPropagator)+ , ("datadog", datadogTraceContextPropagator) , ("jaeger", error "Jaeger not yet implemented") ] --- TODO, actually implement a registry systme-readRegisteredPropagators :: IO [(T.Text, Propagator Context RequestHeaders ResponseHeaders)]-readRegisteredPropagators = pure knownPropagators+readRegisteredPropagators :: IO [(T.Text, TextMapPropagator)]+readRegisteredPropagators = do+ registered <- H.toList <$> Registry.registeredTextMapPropagators+ let regKeys = map fst registered+ builtins = filter (\(k, _) -> k `notElem` regKeys) knownPropagators+ pure (registered ++ builtins) {- | Create a new 'TracerProvider' and set it as the global@@ -318,46 +364,74 @@ initializeTracerProvider :: IO TracerProvider initializeTracerProvider = do (processors, opts) <- getTracerProviderInitializationOptions+ setGlobalTextMapPropagator (tracerProviderOptionsPropagators opts) createTracerProvider processors opts -getTracerProviderInitializationOptions :: IO ([Processor], TracerProviderOptions)-getTracerProviderInitializationOptions = getTracerProviderInitializationOptions' (mempty :: Resource 'Nothing)+withTracerProvider :: (TracerProvider -> IO a) -> IO a+withTracerProvider f = do+ tp <- initializeTracerProvider+ r <- f tp+ _ <- shutdownTracerProvider tp Nothing+ pure r +getTracerProviderInitializationOptions :: IO ([SpanProcessor], TracerProviderOptions)+getTracerProviderInitializationOptions = getTracerProviderInitializationOptions' mempty++ {- | Detect options for initializing a tracer provider from the app environment, taking additional supported resources as well. @since 0.0.3.1 -}-getTracerProviderInitializationOptions' :: (ResourceMerge 'Nothing any ~ 'Nothing) => Resource any -> IO ([Processor], TracerProviderOptions)+getTracerProviderInitializationOptions'+ :: Resource+ -> IO ([SpanProcessor], TracerProviderOptions) getTracerProviderInitializationOptions' rs = do- sampler <- detectSampler- attrLimits <- detectAttributeLimits- spanLimits <- detectSpanLimits- propagators <- detectPropagators- processorConf <- detectBatchProcessorConfig- exporters <- detectExporters- builtInRs <- detectBuiltInResources- envVarRs <- mkResource . map Just <$> detectResourceAttributes- let allRs = mergeResources (builtInRs <> envVarRs) rs- processors <- case exporters of- [] -> do- pure []- e : _ -> do- pure <$> batchProcessor processorConf e- let providerOpts =- emptyTracerProviderOptions- { tracerProviderOptionsIdGenerator = defaultIdGenerator- , tracerProviderOptionsSampler = sampler- , tracerProviderOptionsAttributeLimits = attrLimits- , tracerProviderOptionsSpanLimits = spanLimits- , tracerProviderOptionsPropagators = propagators- , tracerProviderOptionsResources = materializeResources allRs- }- pure (processors, providerOpts)+ disabled <- lookupBooleanEnv "OTEL_SDK_DISABLED"+ if disabled+ then do+ propagators <- detectPropagators+ pure+ ( []+ , emptyTracerProviderOptions {tracerProviderOptionsPropagators = propagators}+ )+ else do+ sampler <- detectSampler+ attrLimits <- detectAttributeLimits+ spanLimits <- detectSpanLimits+ propagators <- detectPropagators+ processorConf <- detectBatchProcessorConfig+ exporters <- detectExporters+ builtInRs <- detectBuiltInResources+ envVarRs <- mkResource . map Just <$> detectResourceAttributes+ mSvcNameEnv <- fmap (fmap T.pack) $ lookupEnv "OTEL_SERVICE_NAME"+ let+ -- NB: Resource merge prioritizes the left value on attribute key conflict.+ baseRs = mergeResources rs (envVarRs <> builtInRs)+ allRs =+ case mSvcNameEnv of+ Nothing -> baseRs+ Just name ->+ mergeResources (mkResource ["service.name" .= name]) baseRs+ processors <- case exporters of+ [] -> do+ pure []+ e : _ -> do+ pure <$> batchProcessor processorConf e+ let providerOpts =+ emptyTracerProviderOptions+ { tracerProviderOptionsIdGenerator = defaultIdGenerator+ , tracerProviderOptionsSampler = sampler+ , tracerProviderOptionsAttributeLimits = attrLimits+ , tracerProviderOptionsSpanLimits = spanLimits+ , tracerProviderOptionsPropagators = propagators+ , tracerProviderOptionsResources = materializeResources allRs+ }+ pure (processors, providerOpts) -detectPropagators :: IO (Propagator Context RequestHeaders ResponseHeaders)+detectPropagators :: IO TextMapPropagator detectPropagators = do registeredPropagators <- readRegisteredPropagators propagatorsInEnv <- fmap (T.splitOn "," . T.pack) <$> lookupEnv "OTEL_PROPAGATORS"@@ -408,19 +482,26 @@ envSampler <- lookupEnv "OTEL_TRACES_SAMPLER" envArg <- lookupEnv "OTEL_TRACES_SAMPLER_ARG" let sampler = fromMaybe (parentBased $ parentBasedOptions alwaysOn) $ do- samplerName <- envSampler- samplerConstructor <- lookup (T.pack samplerName) knownSamplers+ samplerNameRaw <- envSampler+ let samplerName = T.strip $ T.toLower $ T.pack samplerNameRaw+ samplerConstructor <- lookup samplerName knownSamplers samplerConstructor (T.pack <$> envArg) pure sampler detectBatchProcessorConfig :: IO BatchTimeoutConfig-detectBatchProcessorConfig =- BatchTimeoutConfig- <$> readEnvDefault "OTEL_BSP_MAX_QUEUE_SIZE" (maxQueueSize batchTimeoutConfig)- <*> readEnvDefault "OTEL_BSP_SCHEDULE_DELAY" (scheduledDelayMillis batchTimeoutConfig)- <*> readEnvDefault "OTEL_BSP_EXPORT_TIMEOUT" (exportTimeoutMillis batchTimeoutConfig)- <*> readEnvDefault "OTEL_BSP_MAX_EXPORT_BATCH_SIZE" (maxExportBatchSize batchTimeoutConfig)+detectBatchProcessorConfig = do+ maxQ <- readEnvDefault "OTEL_BSP_MAX_QUEUE_SIZE" (maxQueueSize batchTimeoutConfig)+ delay <- readEnvDefault "OTEL_BSP_SCHEDULE_DELAY" (scheduledDelayMillis batchTimeoutConfig)+ expT <- readEnvDefault "OTEL_BSP_EXPORT_TIMEOUT" (exportTimeoutMillis batchTimeoutConfig)+ maxBatch <- readEnvDefault "OTEL_BSP_MAX_EXPORT_BATCH_SIZE" (maxExportBatchSize batchTimeoutConfig)+ pure+ BatchTimeoutConfig+ { maxQueueSize = maxQ+ , scheduledDelayMillis = delay+ , exportTimeoutMillis = expT+ , maxExportBatchSize = min maxBatch maxQ+ } detectAttributeLimits :: IO AttributeLimits@@ -436,12 +517,12 @@ <$> readEnv "OTEL_SPAN_ATTRIBUTE_VALUE_LENGTH_LIMIT" <*> readEnv "OTEL_SPAN_ATTRIBUTE_COUNT_LIMIT" <*> readEnv "OTEL_SPAN_EVENT_COUNT_LIMIT"- <*> readEnv "OTEL_SPAN_LINK_COUNT_LIMIT" <*> readEnv "OTEL_EVENT_ATTRIBUTE_COUNT_LIMIT"+ <*> readEnv "OTEL_SPAN_LINK_COUNT_LIMIT" <*> readEnv "OTEL_LINK_ATTRIBUTE_COUNT_LIMIT" -knownExporters :: [(T.Text, IO (Exporter ImmutableSpan))]+knownExporters :: [(T.Text, IO SpanExporter)] knownExporters = [ ( "otlp"@@ -455,19 +536,28 @@ -- TODO, support multiple exporters-detectExporters :: IO [Exporter ImmutableSpan]+detectExporters :: IO [SpanExporter] detectExporters = do exportersInEnv <- fmap (T.splitOn "," . T.pack) <$> lookupEnv "OTEL_TRACES_EXPORTER" if exportersInEnv == Just ["none"] then pure [] else do let envExporters = fromMaybe ["otlp"] exportersInEnv- exportersAndRegistryEntry = map (\k -> maybe (Left k) Right $ lookup k knownExporters) envExporters- (_notFound, exporterIntializers) = partitionEithers exportersAndRegistryEntry+ resolved <- traverse resolveSpanExporterFactory envExporters+ let (_notFound, exporterInitializers) = partitionEithers resolved -- TODO, notFound logging- sequence exporterIntializers+ sequence exporterInitializers +-- | Prefer a user 'Registry' factory for @k@ when present (left-biased merge with 'knownExporters').+resolveSpanExporterFactory :: T.Text -> IO (Either T.Text (IO SpanExporter))+resolveSpanExporterFactory k =+ Registry.lookupSpanExporterFactory k >>= \case+ Just factoryIO -> pure (Right factoryIO)+ Nothing ->+ pure $ maybe (Left k) Right $ lookup k knownExporters++ -- -- detectMetricsExporterSelection :: _ -- -- TODO other metrics stuff @@ -488,41 +578,19 @@ Baggage.values ok -readEnvDefault :: forall a. (Read a) => String -> a -> IO a-readEnvDefault k defaultValue =- fromMaybe defaultValue . (>>= readMaybe) <$> lookupEnv k---readEnv :: forall a. (Read a) => String -> IO (Maybe a)-readEnv k = (>>= readMaybe) <$> lookupEnv k---{- | Use all built-in resource detectors to populate resource information.-- Currently used detectors include:-- - 'detectService'- - 'detectProcess'- - 'detectOperatingSystem'- - 'detectHost'- - 'detectTelemetry'- - 'detectProcessRuntime'+{- | Discover resource attributes using the shared SDK implementation in+ "OpenTelemetry.Resource.Detect". - This list will grow in the future as more detectors are implemented.+ This reads @OTEL_RESOURCE_DETECTORS@, consults the detector 'Registry', and+ merges results in spec order. See 'OpenTelemetry.Resource.Detect.detectBuiltInResources'. @since 0.0.1.0+ @since 0.1.0.2 Re-exported implementation (registry + @OTEL_RESOURCE_DETECTORS@). -}-detectBuiltInResources :: IO (Resource 'Nothing)-detectBuiltInResources = do- svc <- detectService- processInfo <- detectProcess- osInfo <- detectOperatingSystem- host <- detectHost- let rs =- toResource svc- `mergeResources` toResource detectTelemetry- `mergeResources` toResource detectProcessRuntime- `mergeResources` toResource processInfo- `mergeResources` toResource osInfo- `mergeResources` toResource host- pure rs+detectBuiltInResources :: IO Resource+detectBuiltInResources = ResourceDetect.detectBuiltInResources+++registerBuiltinResourceDetectors :: IO ()+registerBuiltinResourceDetectors =+ ResourceDetect.registerBuiltinResourceDetectors
src/OpenTelemetry/Trace/Id/Generator/Default.hs view
@@ -19,8 +19,6 @@ ) where import OpenTelemetry.Trace.Id.Generator (IdGenerator (..))-import System.IO.Unsafe (unsafePerformIO)-import System.Random.Stateful {- | The default generator for trace and span ids.@@ -28,14 +26,4 @@ @since 0.1.0.0 -} defaultIdGenerator :: IdGenerator-defaultIdGenerator = unsafePerformIO $ do- genBase <- initStdGen- let (spanIdGen, traceIdGen) = split genBase- sg <- newAtomicGenM spanIdGen- tg <- newAtomicGenM traceIdGen- pure $- IdGenerator- { generateSpanIdBytes = uniformByteStringM 8 sg- , generateTraceIdBytes = uniformByteStringM 16 tg- }-{-# NOINLINE defaultIdGenerator #-}+defaultIdGenerator = DefaultIdGenerator
+ src/platform/unix/OpenTelemetry/Platform.hs view
@@ -0,0 +1,28 @@+{- |+Module : OpenTelemetry.Platform+Description : Unix-specific platform utilities for the OpenTelemetry SDK.+Stability : experimental+-}+module OpenTelemetry.Platform where++import Control.Exception (throwIO, try)+import qualified Data.Text as T+import System.IO.Error (isDoesNotExistError)+import System.Posix.Process (getParentProcessID)+import System.Posix.User (getEffectiveUserName)+++tryGetUser :: IO (Maybe T.Text)+tryGetUser = do+ eResult <- try getEffectiveUserName+ case eResult of+ Left err ->+ if isDoesNotExistError err+ then pure Nothing+ else throwIO err+ Right ok -> pure $ Just $ T.pack ok+++tryGetParentProcessID :: IO (Maybe Int)+tryGetParentProcessID =+ Just . fromIntegral <$> getParentProcessID
+ src/platform/windows/OpenTelemetry/Platform.hs view
@@ -0,0 +1,16 @@+{- |+Module : OpenTelemetry.Platform+Description : Windows-specific platform utilities for the OpenTelemetry SDK.+Stability : experimental+-}+module OpenTelemetry.Platform where++import qualified Data.Text as T+++tryGetUser :: IO (Maybe T.Text)+tryGetUser = pure Nothing+++tryGetParentProcessID :: IO (Maybe Int)+tryGetParentProcessID = pure Nothing
test/OpenTelemetry/BaggageSpec.hs view
@@ -1,9 +1,42 @@+{-# LANGUAGE OverloadedStrings #-}+ module OpenTelemetry.BaggageSpec where +import qualified Data.HashMap.Strict as HM+import Data.Maybe (isJust)+import qualified Data.Text as T+import OpenTelemetry.Baggage (Element (..), element, insert, mkToken, values)+import qualified OpenTelemetry.Baggage as Baggage+import OpenTelemetry.Context (empty)+import qualified OpenTelemetry.Context as Ctxt+import OpenTelemetry.Propagator (Propagator (..), emptyTextMap, inject, textMapLookup)+import OpenTelemetry.Propagator.W3CBaggage (w3cBaggagePropagator) import Test.Hspec spec :: Spec spec = describe "Baggage" $ do- specify "Basic support" pending- specify "User official header name `baggage`" pending+ -- Baggage API §Baggage Operations+ -- https://opentelemetry.io/docs/specs/otel/baggage/api/#operations+ specify "Basic support" $ do+ let Just k1 = mkToken "key1"+ Just k2 = mkToken "key2"+ b =+ insert k2 (element "two") $+ insert k1 (element "one") $+ Baggage.empty+ HM.lookup k1 (values b) `shouldBe` Just (element "one")+ HM.lookup k2 (values b) `shouldBe` Just (element "two")++ -- Baggage API §Propagating baggage (W3C Baggage header name)+ -- https://opentelemetry.io/docs/specs/otel/baggage/api/#propagating-baggage+ specify "User official header name `baggage`" $ do+ propagatorFields w3cBaggagePropagator `shouldBe` ["baggage"]+ let Just k = mkToken "userid"+ baggage = insert k (element "alice") Baggage.empty+ ctxt = Ctxt.insertBaggage baggage Ctxt.empty+ headers <- inject w3cBaggagePropagator ctxt emptyTextMap+ textMapLookup "baggage" headers `shouldSatisfy` isJust+ case textMapLookup "baggage" headers of+ Nothing -> expectationFailure "missing baggage header"+ Just v -> T.unpack v `shouldContain` "userid=alice"
+ test/OpenTelemetry/ConfigurationSpec.hs view
@@ -0,0 +1,450 @@+{-# LANGUAGE OverloadedStrings #-}++module OpenTelemetry.ConfigurationSpec (spec) where++import Control.Exception (bracket, bracket_)+import qualified Data.Map.Strict as Map+import Data.Text (Text, pack)+import OpenTelemetry.Attributes (lookupAttribute, toAttribute)+import OpenTelemetry.Configuration.Create (OTelSignals (..), createFromConfig)+import OpenTelemetry.Configuration.Parse (ConfigParseError (..), parseConfigBytes, parseConfigFile)+import OpenTelemetry.Configuration.Types+import OpenTelemetry.Propagator (Propagator (..))+import OpenTelemetry.Resource (getMaterializedResourcesAttributes)+import OpenTelemetry.Trace (detectSpanLimits)+import OpenTelemetry.Trace.Core (SpanLimits (..), getTracerProviderResources)+import System.Environment (lookupEnv, setEnv, unsetEnv)+import Test.Hspec+++spec :: Spec+spec = do+ -- File configuration: declarative SDK configuration (YAML)+ -- https://opentelemetry.io/docs/specs/otel/configuration/+ describe "OpenTelemetry.Configuration.Parse.parseConfigBytes" $ do+ -- Configuration file_format and empty document defaults+ -- https://opentelemetry.io/docs/specs/otel/configuration/+ it "parses minimal valid config with defaults elsewhere" $ do+ let yaml :: Text+ yaml =+ "file_format: \"1.0\"\n"+ result <- parseConfigBytes yaml+ case result of+ Left err -> expectationFailure $ "expected Right, got Left: " ++ show err+ Right cfg -> do+ configFileFormat cfg `shouldBe` "1.0"+ cfg `shouldBe` emptyConfiguration++ -- Configuration: tracer_provider processors and sampler+ -- https://opentelemetry.io/docs/specs/otel/configuration/+ it "parses full tracer_provider with batch processor and always_on sampler" $ do+ let yaml :: Text+ yaml =+ "file_format: \"1.0\"\n\+ \tracer_provider:\n\+ \ processors:\n\+ \ - batch:\n\+ \ schedule_delay: 5000\n\+ \ exporter:\n\+ \ otlp_http:\n\+ \ endpoint: \"http://localhost:4318\"\n\+ \ sampler:\n\+ \ always_on: {}\n"+ result <- parseConfigBytes yaml+ case result of+ Left err -> expectationFailure $ "expected Right, got Left: " ++ show err+ Right cfg -> case configTracerProvider cfg of+ Nothing -> expectationFailure "expected configTracerProvider"+ Just tp -> do+ case tpProcessors tp of+ Nothing -> expectationFailure "expected tpProcessors"+ Just procs -> do+ length procs `shouldBe` 1+ case procs of+ (SpanProcessorBatch bsp : _) -> do+ bspScheduleDelay bsp `shouldBe` Just 5000+ case bspExporter bsp of+ SpanExporterOtlpHttp otlp ->+ otlpCfgEndpoint otlp `shouldBe` Just "http://localhost:4318"+ other ->+ expectationFailure $ "expected SpanExporterOtlpHttp, got " ++ show other+ _ ->+ expectationFailure "expected SpanProcessorBatch as first processor"+ tpSampler tp `shouldBe` Just SamplerAlwaysOn++ -- Configuration: top-level disabled flag+ -- https://opentelemetry.io/docs/specs/otel/configuration/+ it "parses disabled: true" $ do+ let yaml :: Text+ yaml =+ "file_format: \"1.0\"\n\+ \disabled: true\n"+ result <- parseConfigBytes yaml+ case result of+ Left err -> expectationFailure $ "expected Right, got Left: " ++ show err+ Right cfg -> configDisabled cfg `shouldBe` Just True++ -- Configuration: resource.attributes map+ -- https://opentelemetry.io/docs/specs/otel/configuration/+ it "parses resource attributes map" $ do+ let yaml :: Text+ yaml =+ "file_format: \"1.0\"\n\+ \resource:\n\+ \ attributes:\n\+ \ service.name: my-service\n\+ \ service.version: \"1.0\"\n"+ result <- parseConfigBytes yaml+ case result of+ Left err -> expectationFailure $ "expected Right, got Left: " ++ show err+ Right cfg -> case configResource cfg of+ Nothing -> expectationFailure "expected configResource"+ Just res -> case resourceAttributes res of+ Nothing -> expectationFailure "expected resourceAttributes"+ Just attrs -> do+ Map.lookup "service.name" attrs `shouldBe` Just "my-service"+ Map.lookup "service.version" attrs `shouldBe` Just "1.0"++ -- Implementation-specific: parser surfaces YAML errors as ConfigYamlError+ it "returns ConfigYamlError for invalid YAML" $ do+ let garbage :: Text+ garbage = "this is not : valid ::: yaml [[[\n"+ result <- parseConfigBytes garbage+ case result of+ Right cfg -> expectationFailure $ "expected Left, got Right: " ++ show cfg+ Left err -> case err of+ ConfigYamlError _ -> pure ()+ other -> expectationFailure $ "expected ConfigYamlError, got " ++ show other++ -- Configuration: ${ENV} substitution in config file+ -- https://opentelemetry.io/docs/specs/otel/configuration/+ it "substitutes environment variables in YAML before parsing" $ do+ let varName :: String+ varName = "HS_OTEL_CONFIG_PARSE_TEST_SUBST_913847"+ yaml :: Text+ yaml =+ "file_format: \"1.0\"\n\+ \tracer_provider:\n\+ \ processors:\n\+ \ - batch:\n\+ \ exporter:\n\+ \ otlp_http:\n\+ \ endpoint: \"${HS_OTEL_CONFIG_PARSE_TEST_SUBST_913847}\"\n"+ bracketEnv varName "http://example.test:4318" $ do+ result <- parseConfigBytes yaml+ case result of+ Left err -> expectationFailure $ "expected Right, got Left: " ++ show err+ Right cfg -> case configTracerProvider cfg of+ Nothing -> expectationFailure "expected configTracerProvider"+ Just tp -> case tpProcessors tp of+ Nothing -> expectationFailure "expected tpProcessors"+ Just [] -> expectationFailure "expected non-empty processors"+ Just (SpanProcessorBatch bsp : _) -> case bspExporter bsp of+ SpanExporterOtlpHttp otlp ->+ otlpCfgEndpoint otlp `shouldBe` Just "http://example.test:4318"+ other ->+ expectationFailure $ "expected SpanExporterOtlpHttp, got " ++ show other+ Just (_ : _) ->+ expectationFailure "expected SpanProcessorBatch as first processor"++ -- Configuration: default value syntax for unset env vars+ -- https://opentelemetry.io/docs/specs/otel/configuration/+ it "uses default after :- when environment variable is unset" $ do+ let varName :: String+ varName = "HS_OTEL_CONFIG_PARSE_TEST_NONEXISTENT_774019"+ yaml :: Text+ yaml =+ "file_format: \"1.0\"\n\+ \tracer_provider:\n\+ \ processors:\n\+ \ - batch:\n\+ \ exporter:\n\+ \ otlp_http:\n\+ \ endpoint: \"${"+ <> pack varName+ <> ":-fallback_value}\"\n"+ unsetEnv varName+ result <- parseConfigBytes yaml+ case result of+ Left err -> expectationFailure $ "expected Right, got Left: " ++ show err+ Right cfg -> case configTracerProvider cfg of+ Nothing -> expectationFailure "expected configTracerProvider"+ Just tp -> case tpProcessors tp of+ Nothing -> expectationFailure "expected tpProcessors"+ Just (proc : _) -> case proc of+ SpanProcessorBatch bsp -> case bspExporter bsp of+ SpanExporterOtlpHttp otlp ->+ otlpCfgEndpoint otlp `shouldBe` Just "fallback_value"+ other ->+ expectationFailure $ "expected SpanExporterOtlpHttp, got " ++ show other+ other ->+ expectationFailure $ "expected SpanProcessorBatch, got " ++ show other+ Just [] -> expectationFailure "expected non-empty processors"++ describe "parseConfigBytes (branches)" $ do+ -- Configuration: meter_provider.readers (periodic + exporter)+ -- https://opentelemetry.io/docs/specs/otel/configuration/+ it "parses meter_provider with periodic reader and otlp_http exporter" $ do+ let yaml :: Text+ yaml =+ "file_format: \"1.0\"\n\+ \meter_provider:\n\+ \ readers:\n\+ \ - periodic:\n\+ \ interval: 30000\n\+ \ timeout: 5000\n\+ \ exporter:\n\+ \ otlp_http:\n\+ \ endpoint: \"http://localhost:4318\"\n"+ result <- parseConfigBytes yaml+ case result of+ Left err -> expectationFailure $ "expected Right, got Left: " ++ show err+ Right cfg -> case configMeterProvider cfg of+ Nothing -> expectationFailure "expected configMeterProvider"+ Just mp -> case mpReaders mp of+ Nothing -> expectationFailure "expected mpReaders"+ Just (MetricReaderPeriodic pr : _) -> do+ pmrInterval pr `shouldBe` Just 30000+ pmrTimeout pr `shouldBe` Just 5000+ case pmrExporter pr of+ PushMetricExporterOtlpHttp o ->+ otlpCfgEndpoint o `shouldBe` Just "http://localhost:4318"+ other -> expectationFailure $ "expected PushMetricExporterOtlpHttp, got " ++ show other+ _ -> expectationFailure "expected MetricReaderPeriodic"++ -- Configuration: logger_provider processors+ -- https://opentelemetry.io/docs/specs/otel/configuration/+ it "parses logger_provider with batch processor" $ do+ let yaml :: Text+ yaml =+ "file_format: \"1.0\"\n\+ \logger_provider:\n\+ \ processors:\n\+ \ - batch:\n\+ \ schedule_delay: 1000\n\+ \ exporter:\n\+ \ console: {}\n"+ result <- parseConfigBytes yaml+ case result of+ Left err -> expectationFailure $ "expected Right, got Left: " ++ show err+ Right cfg -> case configLoggerProvider cfg of+ Nothing -> expectationFailure "expected configLoggerProvider"+ Just lp -> case lpProcessors lp of+ Nothing -> expectationFailure "expected lpProcessors"+ Just (LogRecordProcessorBatch blp : _) -> do+ blpScheduleDelay blp `shouldBe` Just 1000+ case blpExporter blp of+ LogRecordExporterConsole _ -> pure ()+ other -> expectationFailure $ "expected LogRecordExporterConsole, got " ++ show other+ _ -> expectationFailure "expected LogRecordProcessorBatch"++ -- Configuration: tracer_provider simple processor+ -- https://opentelemetry.io/docs/specs/otel/configuration/+ it "parses simple span processor" $ do+ let yaml :: Text+ yaml =+ "file_format: \"1.0\"\n\+ \tracer_provider:\n\+ \ processors:\n\+ \ - simple:\n\+ \ exporter:\n\+ \ console: {}\n"+ result <- parseConfigBytes yaml+ case result of+ Left err -> expectationFailure $ "expected Right, got Left: " ++ show err+ Right cfg -> case configTracerProvider cfg of+ Nothing -> expectationFailure "expected configTracerProvider"+ Just tp -> case tpProcessors tp of+ Nothing -> expectationFailure "expected tpProcessors"+ Just (SpanProcessorSimple ssp : _) -> case sspExporter ssp of+ SpanExporterConsole _ -> pure ()+ other -> expectationFailure $ "expected SpanExporterConsole, got " ++ show other+ _ -> expectationFailure "expected SpanProcessorSimple"++ -- Configuration: parent_based sampler+ -- https://opentelemetry.io/docs/specs/otel/configuration/+ it "parses parent_based sampler with nested always_on root" $ do+ let yaml :: Text+ yaml =+ "file_format: \"1.0\"\n\+ \tracer_provider:\n\+ \ sampler:\n\+ \ parent_based:\n\+ \ root:\n\+ \ always_on: {}\n"+ result <- parseConfigBytes yaml+ case result of+ Left err -> expectationFailure $ "expected Right, got Left: " ++ show err+ Right cfg -> case configTracerProvider cfg >>= tpSampler of+ Just (SamplerParentBased pb) -> pbRoot pb `shouldBe` Just SamplerAlwaysOn+ other -> expectationFailure $ "expected SamplerParentBased with root always_on, got " ++ show other++ -- Configuration: trace_id_ratio_based sampler+ -- https://opentelemetry.io/docs/specs/otel/configuration/+ it "parses trace_id_ratio_based sampler" $ do+ let yaml :: Text+ yaml =+ "file_format: \"1.0\"\n\+ \tracer_provider:\n\+ \ sampler:\n\+ \ trace_id_ratio_based:\n\+ \ ratio: 0.5\n"+ result <- parseConfigBytes yaml+ case result of+ Left err -> expectationFailure $ "expected Right, got Left: " ++ show err+ Right cfg -> case configTracerProvider cfg >>= tpSampler of+ Just (SamplerTraceIdRatioBased r) -> ratioValue r `shouldBe` 0.5+ other -> expectationFailure $ "expected SamplerTraceIdRatioBased, got " ++ show other++ -- Implementation-specific: validation rejects non-object root+ it "returns ConfigValidationError for non-object YAML" $ do+ result <- parseConfigBytes "hello\n"+ case result of+ Right cfg -> expectationFailure $ "expected Left, got Right: " ++ show cfg+ Left err -> case err of+ ConfigValidationError _ -> pure ()+ other -> expectationFailure $ "expected ConfigValidationError, got " ++ show other++ -- Implementation-specific: parseConfigFile IO error surface+ it "returns ConfigFileNotFound for missing file" $ do+ result <- parseConfigFile "/nonexistent/hs_opentelemetry_config_missing_01928374.yaml"+ case result of+ Right cfg -> expectationFailure $ "expected Left, got Right: " ++ show cfg+ Left err -> err `shouldBe` ConfigFileNotFound "/nonexistent/hs_opentelemetry_config_missing_01928374.yaml"++ -- Implementation-specific: substitution edge cases+ it "env substitution: malformed ${...} without closing brace preserves literal" $ do+ let yaml :: Text+ yaml =+ "file_format: '${UNCLOSED'\n"+ result <- parseConfigBytes yaml+ case result of+ Left err -> expectationFailure $ "expected Right, got Left: " ++ show err+ Right cfg -> configFileFormat cfg `shouldBe` "${UNCLOSED"++ -- Implementation-specific: empty ${} substitution+ it "env substitution: empty variable name ${} is handled gracefully" $ do+ let yaml :: Text+ yaml =+ "file_format: '${}'\n"+ result <- parseConfigBytes yaml+ case result of+ Left err -> expectationFailure $ "expected Right, got Left: " ++ show err+ Right cfg -> configFileFormat cfg `shouldBe` ""++ -- Configuration: tracer_provider.limits (span limits)+ -- https://opentelemetry.io/docs/specs/otel/configuration/+ it "parses span limits" $ do+ let yaml :: Text+ yaml =+ "file_format: \"1.0\"\n\+ \tracer_provider:\n\+ \ limits:\n\+ \ attribute_value_length_limit: 1\n\+ \ attribute_count_limit: 2\n\+ \ event_count_limit: 3\n\+ \ link_count_limit: 4\n\+ \ event_attribute_count_limit: 5\n\+ \ link_attribute_count_limit: 6\n"+ result <- parseConfigBytes yaml+ case result of+ Left err -> expectationFailure $ "expected Right, got Left: " ++ show err+ Right cfg -> case configTracerProvider cfg >>= tpLimits of+ Nothing -> expectationFailure "expected tpLimits"+ Just sl -> do+ slAttributeValueLengthLimit sl `shouldBe` Just 1+ slAttributeCountLimit sl `shouldBe` Just 2+ slEventCountLimit sl `shouldBe` Just 3+ slLinkCountLimit sl `shouldBe` Just 4+ slEventAttributeCountLimit sl `shouldBe` Just 5+ slLinkAttributeCountLimit sl `shouldBe` Just 6++ describe "OpenTelemetry.Configuration.Create.createFromConfig" $ do+ -- Configuration: SDK startup from parsed file (components graph)+ -- https://opentelemetry.io/docs/specs/otel/configuration/+ it "createFromConfig produces components from minimal config" $ do+ let yaml :: Text+ yaml = "file_format: \"1.0\"\n"+ ep <- parseConfigBytes yaml+ case ep of+ Left err -> expectationFailure $ "expected Right, got Left: " ++ show err+ Right cfg ->+ bracket (createFromConfig cfg) otelShutdown $ \comps -> do+ not (null (propagatorFields (otelPropagators comps))) `shouldBe` True++ -- Configuration: disabled SDK (no-op telemetry)+ -- https://opentelemetry.io/docs/specs/otel/configuration/+ it "createFromConfig with disabled=true returns noop components" $ do+ let yaml :: Text+ yaml =+ "file_format: \"1.0\"\n\+ \disabled: true\n"+ ep <- parseConfigBytes yaml+ case ep of+ Left err -> expectationFailure $ "expected Right, got Left: " ++ show err+ Right cfg ->+ bracket (createFromConfig cfg) otelShutdown $ \comps -> do+ propagatorFields (otelPropagators comps) `shouldBe` []++ -- Resource SDK: attributes from configuration merged into TracerProvider resource+ -- https://opentelemetry.io/docs/specs/otel/resource/sdk/+ it "createFromConfig resource attributes are propagated" $ do+ let yaml :: Text+ yaml =+ "file_format: \"1.0\"\n\+ \resource:\n\+ \ attributes:\n\+ \ service.name: my-service\n\+ \ service.version: \"1.0\"\n"+ ep <- parseConfigBytes yaml+ case ep of+ Left err -> expectationFailure $ "expected Right, got Left: " ++ show err+ Right cfg ->+ bracket (createFromConfig cfg) otelShutdown $ \comps -> do+ let attrs =+ getMaterializedResourcesAttributes $+ getTracerProviderResources $+ otelTracerProvider comps+ lookupAttribute attrs "service.name" `shouldBe` Just (toAttribute ("my-service" :: Text))+ lookupAttribute attrs "service.version" `shouldBe` Just (toAttribute ("1.0" :: Text))++ describe "detectSpanLimits (environment)" $ sequential $ do+ -- General SDK environment variables for span limits (OTEL_SPAN_*)+ -- https://opentelemetry.io/docs/specs/otel/configuration/sdk-environment-variables/+ it "maps OTEL_SPAN_LINK_COUNT_LIMIT and OTEL_EVENT_ATTRIBUTE_COUNT_LIMIT to distinct SpanLimits fields" $+ bracketUnset spanLimitEnvKeys $ \_ -> do+ setEnv "OTEL_SPAN_LINK_COUNT_LIMIT" "42"+ setEnv "OTEL_EVENT_ATTRIBUTE_COUNT_LIMIT" "77"+ sl <- detectSpanLimits+ linkCountLimit sl `shouldBe` Just 42+ eventAttributeCountLimit sl `shouldBe` Just 77+++spanLimitEnvKeys :: [String]+spanLimitEnvKeys =+ [ "OTEL_SPAN_ATTRIBUTE_VALUE_LENGTH_LIMIT"+ , "OTEL_SPAN_ATTRIBUTE_COUNT_LIMIT"+ , "OTEL_SPAN_EVENT_COUNT_LIMIT"+ , "OTEL_EVENT_ATTRIBUTE_COUNT_LIMIT"+ , "OTEL_SPAN_LINK_COUNT_LIMIT"+ , "OTEL_LINK_ATTRIBUTE_COUNT_LIMIT"+ ]+++bracketUnset :: [String] -> ([(String, Maybe String)] -> IO a) -> IO a+bracketUnset keys act =+ bracket+ ( do+ saved <- mapM (\k -> (,) k <$> lookupEnv k) keys+ mapM_ unsetEnv keys+ pure saved+ )+ (mapM_ restore)+ act+ where+ restore (k, Nothing) = unsetEnv k+ restore (k, Just v) = setEnv k v+++bracketEnv :: String -> String -> IO a -> IO a+bracketEnv name value = bracket_ (setEnv name value) (unsetEnv name)
+ test/OpenTelemetry/ContextInSpanSpec.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module OpenTelemetry.ContextInSpanSpec (spec) where++import Control.Exception (SomeException, handle, throwIO)+import qualified OpenTelemetry.Context as Context+import OpenTelemetry.Context.ThreadLocal (getContext)+import OpenTelemetry.Trace+import OpenTelemetry.Trace.Core+import Test.Hspec+++spec :: Spec+spec = describe "Nested context restoration" $ do+ -- Trace API §Context interaction: active span / Context stack when nesting scopes+ -- https://opentelemetry.io/docs/specs/otel/trace/api/#context-interaction+ it "outer context is restored after inner scope" $ do+ p <- getGlobalTracerProvider+ let t = makeTracer p "ctx-test" tracerOptions+ inSpan' t "outer" defaultSpanArguments $ \outerSpan -> do+ outerSc <- getSpanContext outerSpan+ inSpan' t "inner" defaultSpanArguments $ \_innerSpan -> do+ pure ()+ ctxt <- getContext+ case Context.lookupSpan ctxt of+ Nothing -> expectationFailure "expected outer span after inner scope"+ Just restored -> do+ rsc <- getSpanContext restored+ rsc `shouldBe` outerSc++ -- Trace API §Context interaction: restore prior Context on scope exit (including errors)+ -- https://opentelemetry.io/docs/specs/otel/trace/api/#context-interaction+ it "context is restored after exception in inSpan" $ do+ p <- getGlobalTracerProvider+ let t = makeTracer p "ctx-exception" tracerOptions+ inSpan' t "outer-ex" defaultSpanArguments $ \outerSpan -> do+ outerSc <- getSpanContext outerSpan+ handle (\(_ :: SomeException) -> pure ()) $+ inSpan' t "throwing" defaultSpanArguments $ \_s ->+ throwIO (userError "boom")+ ctxt <- getContext+ case Context.lookupSpan ctxt of+ Nothing -> expectationFailure "expected outer span restored after exception"+ Just restored -> do+ rsc <- getSpanContext restored+ rsc `shouldBe` outerSc
test/OpenTelemetry/ContextSpec.hs view
@@ -2,25 +2,56 @@ module OpenTelemetry.ContextSpec where +import Control.Concurrent import Control.Monad import Data.Maybe-import OpenTelemetry.Context+import qualified OpenTelemetry.Baggage as Baggage+import OpenTelemetry.Context (+ Key,+ empty,+ insert,+ insertBaggage,+ lookup,+ lookupBaggage,+ lookupSpan,+ newKey,+ ) import OpenTelemetry.Context.ThreadLocal+import OpenTelemetry.Propagator (+ Propagator (..),+ emptyTextMap,+ extract,+ getGlobalTextMapPropagator,+ inject,+ textMapFromList,+ textMapLookup,+ )+import OpenTelemetry.Propagator.B3 (b3TraceContextPropagator)+import OpenTelemetry.Propagator.W3CBaggage (w3cBaggagePropagator)+import OpenTelemetry.Propagator.W3CTraceContext (w3cTraceContextPropagator) import Test.Hspec import Prelude hiding (lookup) spec :: Spec spec = describe "Context" $ do+ -- Context API: immutable key/value context+ -- https://opentelemetry.io/docs/specs/otel/context/ describe "Create Context Key" $ do+ -- Context API §Create a key: unique keys for Context values+ -- https://opentelemetry.io/docs/specs/otel/context/#create-a-key it "works" $ do void (newKey "k" :: IO (Key ())) describe "Set value for Context" $ do+ -- Context API §Get value / Set value+ -- https://opentelemetry.io/docs/specs/otel/context/#set-value it "works" $ do k <- newKey "k" let ctxt = insert k (12 :: Int) empty lookup k ctxt `shouldBe` Just 12 describe "Get value from Context" $ do+ -- Context API §Get value+ -- https://opentelemetry.io/docs/specs/otel/context/#get-value it "works" $ do k1 <- newKey "k.1" k2 <- newKey "k.2"@@ -28,38 +59,162 @@ lookup k1 ctxt `shouldBe` Just 12 lookup k2 ctxt `shouldBe` (Just (Just False)) describe "Attach Context" $ do+ -- Implementation-specific: thread-local attach maps to runtime propagation of "current" Context+ -- https://opentelemetry.io/docs/specs/otel/context/#optional-global-operations specify "ThreadLocal works" $ do k <- newKey "thingum"- attachContext $ insert k True empty+ tok <- attachContext $ insert k True empty mctxt <- lookupContext (mctxt >>= lookup k) `shouldBe` Just True+ detachContext tok describe "Detach Context" $ do+ -- Implementation-specific: thread-local detach restores previous Context+ -- https://opentelemetry.io/docs/specs/otel/context/#optional-global-operations specify "ThreadLocal works" $ do k <- newKey "thingum"- attachContext $ insert k True empty- mctxt <- detachContext- (mctxt >>= lookup k) `shouldBe` Just True- mctxt' <- lookupContext- isNothing mctxt' `shouldBe` True+ tok <- attachContext $ insert k True empty+ detachContext tok+ ctx <- getContext+ lookup k ctx `shouldBe` (Nothing :: Maybe Bool) + -- Implementation-specific: nested attach/detach stack (thread-local)+ -- https://opentelemetry.io/docs/specs/otel/context/#optional-global-operations specify "Get current Context" $ do k1 <- newKey "k.1" k2 <- newKey "k.2" let ctxt1 = insert k1 (12 :: Int) empty- attachContext ctxt1+ tok1 <- attachContext ctxt1 let ctxt2 = insert k2 (13 :: Int) empty- attachContext ctxt2+ tok2 <- attachContext ctxt2 (Just ctxt) <- lookupContext lookup k1 ctxt `shouldBe` Nothing lookup k2 ctxt `shouldBe` Just 13+ detachContext tok2+ detachContext tok1 - specify "Composite Propagator" pending- specify "Global Propagator" pending- specify "TraceContext Propagator" pending- specify "B3 Propagator" pending- specify "Jaeger Propagator" pending+ describe "Thread-local advanced API" $ do+ -- Implementation-specific: Haskell thread-local Context helpers (not OTel API surface)+ specify "adjustContext modifies stored context" $ do+ k <- newKey "adj"+ tok <- attachContext empty+ adjustContext (insert k ("ok" :: String))+ mctxt <- lookupContext+ (mctxt >>= lookup k) `shouldBe` Just "ok"+ detachContext tok++ -- Implementation-specific: attach Context on another OS thread+ specify "attachContextOnThread and lookupContextOnThread roundtrip" $ do+ started <- newEmptyMVar+ mainDone <- newEmptyMVar+ _childTid <-+ forkIO $ do+ tid <- myThreadId+ putMVar started tid+ takeMVar mainDone+ k <- newKey "remote"+ childTid <- takeMVar started+ tok <- attachContextOnThread childTid (insert k True empty)+ mc <- lookupContextOnThread childTid+ (mc >>= lookup k) `shouldBe` Just True+ detachContextFromThread childTid tok+ putMVar mainDone ()++ -- Implementation-specific: detach restores prior Context on remote thread+ specify "detachContextFromThread restores previous context" $ do+ started <- newEmptyMVar+ mainDone <- newEmptyMVar+ _childTid <-+ forkIO $ do+ tid <- myThreadId+ putMVar started tid+ takeMVar mainDone+ k <- newKey "detach"+ childTid <- takeMVar started+ tok <- attachContextOnThread childTid (insert k True empty)+ detachContextFromThread childTid tok+ mc <- lookupContextOnThread childTid+ (mc >>= lookup k) `shouldBe` (Nothing :: Maybe Bool)+ putMVar mainDone ()++ -- Implementation-specific: mutate current Context on remote thread+ specify "adjustContextOnThread updates remote thread context" $ do+ started <- newEmptyMVar+ mainDone <- newEmptyMVar+ _childTid <-+ forkIO $ do+ tid <- myThreadId+ putMVar started tid+ takeMVar mainDone+ k <- newKey "adj-remote"+ childTid <- takeMVar started+ tok <- attachContextOnThread childTid empty+ adjustContextOnThread childTid (insert k (7 :: Int))+ mc <- lookupContextOnThread childTid+ (mc >>= lookup k) `shouldBe` Just 7+ detachContextFromThread childTid tok+ putMVar mainDone ()++ -- Propagators API §Composite Propagator+ -- https://opentelemetry.io/docs/specs/otel/context/api-propagators/#composite-propagator+ specify "Composite Propagator" $ do+ let composed = w3cTraceContextPropagator <> w3cBaggagePropagator+ propagatorFields composed `shouldBe` ["traceparent", "tracestate", "baggage"]+ let Propagator {extractor = ex, injector = inj} = composed+ c <- ex emptyTextMap empty+ isNothing (lookupSpan c) `shouldBe` True+ isNothing (lookupBaggage c) `shouldBe` True+ hs <- inj c emptyTextMap+ hs `shouldBe` emptyTextMap++ -- Propagators API: global TextMapPropagator (SDK/runtime wiring)+ -- https://opentelemetry.io/docs/specs/otel/context/api-propagators/#global-propagators+ specify "Global Propagator" $ do+ p <- getGlobalTextMapPropagator+ propagatorFields p `shouldNotBe` []+ propagatorFields p `shouldContain` ["traceparent"]++ -- W3C Trace Context propagation (fields: traceparent, tracestate)+ -- https://opentelemetry.io/docs/specs/otel/context/api-propagators/#trace-context-propagator+ specify "TraceContext Propagator" $+ propagatorFields w3cTraceContextPropagator `shouldBe` ["traceparent", "tracestate"]++ -- B3 propagator (de facto); OTel defines composite/multi-header behavior+ -- https://opentelemetry.io/docs/specs/otel/context/api-propagators/+ specify "B3 Propagator" $+ propagatorFields b3TraceContextPropagator+ `shouldBe` ["B3 Trace Context"]++ -- Implementation gap: Jaeger propagator not provided by this repo+ specify "Jaeger Propagator" $+ pendingWith "No Jaeger propagator implementation in this repository."+ describe "TextMap Propagator" $ do- specify "Fields" pending- specify "Setter argument" pending- specify "Getter argument" pending- specify "Getter argument returning keys" pending+ -- Baggage API §Propagating baggage: W3C Baggage header+ -- https://opentelemetry.io/docs/specs/otel/baggage/api/#propagating-baggage+ specify "Fields" $+ propagatorFields w3cBaggagePropagator `shouldBe` ["baggage"]++ -- Propagators API §Inject+ -- https://opentelemetry.io/docs/specs/otel/context/api-propagators/#inject+ specify "Setter argument" $ do+ let Just tok = Baggage.mkToken "uid"+ baggage = Baggage.insert tok (Baggage.element "x") Baggage.empty+ ctxt = insertBaggage baggage empty+ hs <- inject w3cBaggagePropagator ctxt emptyTextMap+ textMapLookup "baggage" hs `shouldNotBe` Nothing++ -- Propagators API §Extract+ -- https://opentelemetry.io/docs/specs/otel/context/api-propagators/#extract+ specify "Getter argument" $ do+ let hs = textMapFromList [("baggage", "uid=alpha")]+ ctxt' <- extract w3cBaggagePropagator hs empty+ lookupBaggage ctxt' `shouldNotBe` Nothing++ -- Baggage API: extract yields non-empty baggage in Context+ -- https://opentelemetry.io/docs/specs/otel/baggage/api/+ specify "Getter argument returning keys" $ do+ let hs = textMapFromList [("baggage", "a=1")]+ ctxt' <- extract w3cBaggagePropagator hs empty+ case lookupBaggage ctxt' of+ Nothing -> expectationFailure "expected baggage in context"+ Just b -> Baggage.values b `shouldNotBe` mempty
+ test/OpenTelemetry/LogSpec.hs view
@@ -0,0 +1,257 @@+{-# LANGUAGE OverloadedStrings #-}++module OpenTelemetry.LogSpec where++import Control.Monad (replicateM_)+import qualified Data.HashMap.Strict as H+import Data.IORef+import qualified Data.Text as T+import qualified Data.Vector as V+import OpenTelemetry.Attributes (AttributeLimits (..), defaultAttributeLimits, emptyAttributes)+import OpenTelemetry.Exporter.LogRecord (LogRecordExporterArguments (..), mkLogRecordExporter)+import OpenTelemetry.Internal.Common.Types (ExportResult (..), FlushResult (..), InstrumentationLibrary (..), ShutdownResult (..))+import OpenTelemetry.Internal.Log.Types+import OpenTelemetry.Log.Core+import OpenTelemetry.LogAttributes (AnyValue (..), ToValue (..))+import qualified OpenTelemetry.LogAttributes as LA+import OpenTelemetry.Processor.Batch.LogRecord (BatchLogRecordProcessorConfig (..), batchLogRecordProcessor, defaultBatchLogRecordProcessorConfig)+import OpenTelemetry.Resource (emptyMaterializedResources)+import System.Mem.StableName (eqStableName, makeStableName)+import Test.Hspec+++spec :: Spec+spec = describe "OpenTelemetry.Log (SDK)" $ do+ -- Logs SDK+ -- https://opentelemetry.io/docs/specs/otel/logs/sdk/+ describe "getLogger scope caching" $ do+ it "getLogger returns same Logger for same scope" $ do+ -- OTel Logs SDK §LoggerProvider: "Implementations SHOULD return the same+ -- Logger instance when called multiple times with the same [scope identity]."+ -- https://opentelemetry.io/docs/specs/otel/logs/sdk/#loggerprovider+ processor <- captureProcessor+ lp <-+ createLoggerProvider [processor] $+ LoggerProviderOptions+ { loggerProviderOptionsResource = emptyMaterializedResources+ , loggerProviderOptionsAttributeLimits = defaultAttributeLimits+ , loggerProviderOptionsMinSeverity = Nothing+ }+ let scope = instrumentationLibrary "test-lib" "1.0"+ l1 <- getLogger lp scope+ l2 <- getLogger lp scope+ loggerInstrumentationScope l1 `shouldBe` loggerInstrumentationScope l2+ sn1 <- makeStableName l1+ sn2 <- makeStableName l2+ eqStableName sn1 sn2 `shouldBe` True+ let scope2 = instrumentationLibrary "other-lib" "2.0"+ l3 <- getLogger lp scope2+ loggerInstrumentationScope l3 `shouldNotBe` loggerInstrumentationScope l1+ sn3 <- makeStableName l3+ eqStableName sn1 sn3 `shouldBe` False++ describe "LogRecord attribute limits" $ do+ -- Logs SDK §LogRecord limits+ -- https://opentelemetry.io/docs/specs/otel/logs/sdk/#logrecord-limits+ specify "attributes within count limit are preserved" $ do+ let limits = AttributeLimits {attributeCountLimit = Just 3, attributeLengthLimit = Nothing}+ processor <- captureProcessor+ lp <-+ createLoggerProvider [processor] $+ LoggerProviderOptions+ { loggerProviderOptionsResource = emptyMaterializedResources+ , loggerProviderOptionsAttributeLimits = limits+ , loggerProviderOptionsMinSeverity = Nothing+ }+ let logger = makeLogger lp testLib+ lr <-+ emitLogRecord logger $+ emptyLogRecordArguments+ { attributes = H.fromList [("a", toValue ("1" :: T.Text)), ("b", toValue ("2" :: T.Text))]+ , severityNumber = Just Info+ }+ ilr <- readLogRecord lr+ LA.attributesCount (logRecordAttributes ilr) `shouldBe` 2+ LA.attributesDropped (logRecordAttributes ilr) `shouldBe` 0++ -- Logs SDK §LogRecord limits: dropped attributes+ -- https://opentelemetry.io/docs/specs/otel/logs/sdk/#logrecord-limits+ specify "attributes exceeding count limit are dropped" $ do+ let limits = AttributeLimits {attributeCountLimit = Just 2, attributeLengthLimit = Nothing}+ processor <- captureProcessor+ lp <-+ createLoggerProvider [processor] $+ LoggerProviderOptions+ { loggerProviderOptionsResource = emptyMaterializedResources+ , loggerProviderOptionsAttributeLimits = limits+ , loggerProviderOptionsMinSeverity = Nothing+ }+ let logger = makeLogger lp testLib+ lr <-+ emitLogRecord logger $+ emptyLogRecordArguments+ { attributes = H.fromList [("a", toValue ("1" :: T.Text)), ("b", toValue ("2" :: T.Text)), ("c", toValue ("3" :: T.Text))]+ , severityNumber = Just Info+ }+ ilr <- readLogRecord lr+ LA.attributesDropped (logRecordAttributes ilr) `shouldSatisfy` (> 0)++ -- Logs SDK §LogRecord limits: attribute value length+ -- https://opentelemetry.io/docs/specs/otel/logs/sdk/#logrecord-limits+ specify "length limit truncates log record attribute values" $ do+ let limits = AttributeLimits {attributeCountLimit = Nothing, attributeLengthLimit = Just 5}+ processor <- captureProcessor+ lp <-+ createLoggerProvider [processor] $+ LoggerProviderOptions+ { loggerProviderOptionsResource = emptyMaterializedResources+ , loggerProviderOptionsAttributeLimits = limits+ , loggerProviderOptionsMinSeverity = Nothing+ }+ let logger = makeLogger lp testLib+ lr <-+ emitLogRecord logger $+ emptyLogRecordArguments+ { attributes = H.fromList [("key", toValue ("hello world" :: T.Text))]+ , severityNumber = Just Info+ }+ ilr <- readLogRecord lr+ LA.lookupAttribute (logRecordAttributes ilr) "key" `shouldBe` Just (TextValue "hello")++ -- Logs SDK §LogRecord limits: unset limits+ -- https://opentelemetry.io/docs/specs/otel/logs/sdk/#logrecord-limits+ specify "no limit allows many attributes" $ do+ let limits = AttributeLimits {attributeCountLimit = Nothing, attributeLengthLimit = Nothing}+ processor <- captureProcessor+ lp <-+ createLoggerProvider [processor] $+ LoggerProviderOptions+ { loggerProviderOptionsResource = emptyMaterializedResources+ , loggerProviderOptionsAttributeLimits = limits+ , loggerProviderOptionsMinSeverity = Nothing+ }+ let logger = makeLogger lp testLib+ attrs = H.fromList [(T.pack ("k" ++ show i), toValue (T.pack (show i))) | i <- [1 :: Int .. 200]]+ lr <-+ emitLogRecord logger $+ emptyLogRecordArguments+ { attributes = attrs+ , severityNumber = Just Info+ }+ ilr <- readLogRecord lr+ LA.attributesCount (logRecordAttributes ilr) `shouldBe` 200+ LA.attributesDropped (logRecordAttributes ilr) `shouldBe` 0++ describe "Batch LogRecord Processor" $ do+ -- Logs SDK §BatchLogRecordProcessor: shutdown flushes pending records+ -- https://opentelemetry.io/docs/specs/otel/logs/sdk/#batchlogrecordprocessor+ specify "shutdown exports buffered records" $ do+ exportedRef <- newIORef (0 :: Int)+ exporter <-+ mkLogRecordExporter+ LogRecordExporterArguments+ { logRecordExporterArgumentsExport = \batch -> do+ atomicModifyIORef' exportedRef (\n -> (n + V.length batch, ()))+ pure Success+ , logRecordExporterArgumentsForceFlush = pure FlushSuccess+ , logRecordExporterArgumentsShutdown = pure ()+ }+ let conf =+ (defaultBatchLogRecordProcessorConfig exporter)+ { batchLogScheduledDelayMillis = 60000+ , batchLogMaxQueueSize = 100+ }+ proc <- batchLogRecordProcessor conf+ lp <- createLoggerProvider [proc] emptyLoggerProviderOptions+ let logger = makeLogger lp testLib+ replicateM_ 5 $ emitLogRecord logger emptyLogRecordArguments {severityNumber = Just Info}+ _ <- shutdownLoggerProvider lp Nothing+ exported <- readIORef exportedRef+ exported `shouldBe` 5++ -- Logs SDK §BatchLogRecordProcessor: ForceFlush exports pending records+ -- https://opentelemetry.io/docs/specs/otel/logs/sdk/#batchlogrecordprocessor+ specify "forceFlush exports buffered records" $ do+ exportedRef <- newIORef (0 :: Int)+ exporter <-+ mkLogRecordExporter+ LogRecordExporterArguments+ { logRecordExporterArgumentsExport = \batch -> do+ atomicModifyIORef' exportedRef (\n -> (n + V.length batch, ()))+ pure Success+ , logRecordExporterArgumentsForceFlush = pure FlushSuccess+ , logRecordExporterArgumentsShutdown = pure ()+ }+ let conf =+ (defaultBatchLogRecordProcessorConfig exporter)+ { batchLogScheduledDelayMillis = 60000+ , batchLogMaxQueueSize = 100+ }+ proc <- batchLogRecordProcessor conf+ lp <- createLoggerProvider [proc] emptyLoggerProviderOptions+ let logger = makeLogger lp testLib+ replicateM_ 3 $ emitLogRecord logger emptyLogRecordArguments {severityNumber = Just Warn}+ _ <- forceFlushLoggerProvider lp Nothing+ exported <- readIORef exportedRef+ exported `shouldBe` 3++ -- Logs SDK §LoggerProvider: Shutdown is idempotent / second shutdown fails+ -- https://opentelemetry.io/docs/specs/otel/logs/sdk/#shutdown+ specify "shutdown after shutdown returns failure" $ do+ exporter <-+ mkLogRecordExporter+ LogRecordExporterArguments+ { logRecordExporterArgumentsExport = \_ -> pure Success+ , logRecordExporterArgumentsForceFlush = pure FlushSuccess+ , logRecordExporterArgumentsShutdown = pure ()+ }+ proc <- batchLogRecordProcessor (defaultBatchLogRecordProcessorConfig exporter)+ lp <- createLoggerProvider [proc] emptyLoggerProviderOptions+ r1 <- shutdownLoggerProvider lp Nothing+ r1 `shouldBe` ShutdownSuccess+ r2 <- shutdownLoggerProvider lp Nothing+ r2 `shouldBe` ShutdownFailure++ -- Logs SDK §LoggerProvider: no telemetry after Shutdown+ -- https://opentelemetry.io/docs/specs/otel/logs/sdk/#shutdown+ specify "records emitted after shutdown are silently dropped" $ do+ exportedRef <- newIORef (0 :: Int)+ exporter <-+ mkLogRecordExporter+ LogRecordExporterArguments+ { logRecordExporterArgumentsExport = \batch -> do+ atomicModifyIORef' exportedRef (\n -> (n + V.length batch, ()))+ pure Success+ , logRecordExporterArgumentsForceFlush = pure FlushSuccess+ , logRecordExporterArgumentsShutdown = pure ()+ }+ proc <- batchLogRecordProcessor (defaultBatchLogRecordProcessorConfig exporter)+ lp <- createLoggerProvider [proc] emptyLoggerProviderOptions+ let logger = makeLogger lp testLib+ _ <- emitLogRecord logger emptyLogRecordArguments {severityNumber = Just Info}+ _ <- shutdownLoggerProvider lp Nothing+ beforeCount <- readIORef exportedRef+ _ <- emitLogRecord logger emptyLogRecordArguments {severityNumber = Just Info}+ afterCount <- readIORef exportedRef+ afterCount `shouldBe` beforeCount+++testLib :: InstrumentationLibrary+testLib =+ InstrumentationLibrary+ { libraryName = "test"+ , libraryVersion = "0.0.0"+ , librarySchemaUrl = ""+ , libraryAttributes = emptyAttributes+ }+++captureProcessor :: IO LogRecordProcessor+captureProcessor = do+ ref <- newIORef ([] :: [ReadWriteLogRecord])+ pure+ LogRecordProcessor+ { logRecordProcessorOnEmit = \lr _ctx -> atomicModifyIORef' ref (\rs -> (lr : rs, ()))+ , logRecordProcessorShutdown = pure ShutdownSuccess+ , logRecordProcessorForceFlush = pure FlushSuccess+ }
+ test/OpenTelemetry/MeterProviderSpec.hs view
@@ -0,0 +1,501 @@+{-# LANGUAGE OverloadedStrings #-}++module OpenTelemetry.MeterProviderSpec (spec) where++import Data.Int (Int64)+import Data.Text (Text)+import qualified Data.Vector as V+import Data.Word (Word64)+import OpenTelemetry.Attributes (addAttribute, defaultAttributeLimits, emptyAttributes, lookupAttribute)+import OpenTelemetry.Attributes.Attribute (Attribute (..), PrimitiveAttribute (..))+import OpenTelemetry.Exporter.Metric (+ AggregationTemporality (..),+ ExponentialHistogramDataPoint (..),+ GaugeDataPoint (..),+ HistogramDataPoint (..),+ MetricExport (..),+ NumberValue (..),+ ResourceMetricsExport (..),+ ScopeMetricsExport (..),+ SumDataPoint (..),+ )+import OpenTelemetry.Internal.Common.Types (FlushResult (..), InstrumentationLibrary (..), ShutdownResult (..))+import OpenTelemetry.MeterProvider+import OpenTelemetry.Metric.Core (+ AdvisoryParameters (..),+ Counter (..),+ Gauge (..),+ Histogram (..),+ HistogramAggregation (..),+ Meter (..),+ MeterProvider (..),+ ObservableResult (..),+ UpDownCounter (..),+ defaultAdvisoryParameters,+ forceFlushMeterProvider,+ getMeter,+ shutdownMeterProvider,+ )+import OpenTelemetry.Metric.View (View (..), ViewAggregation (..), ViewSelector (..))+import OpenTelemetry.Resource (emptyMaterializedResources)+import Test.Hspec+++mkView :: Text -> Maybe Text -> ViewAggregation -> Maybe [Text] -> Maybe Text -> Maybe Text -> View+mkView namePat mKind agg mKeys mName mDesc =+ View+ { viewSelector =+ ViewSelector+ { viewInstrumentNamePattern = namePat+ , viewInstrumentKind = Nothing+ , viewInstrumentUnit = Nothing+ , viewMeterName = Nothing+ , viewMeterVersion = Nothing+ , viewMeterSchemaUrl = Nothing+ }+ , viewAggregation = agg+ , viewAttributeKeys = mKeys+ , viewName = mName+ , viewDescription = mDesc+ }+++scope :: InstrumentationLibrary+scope = "test-scope"+++firstMetric :: [ResourceMetricsExport] -> MetricExport+firstMetric [rme] =+ V.head (scopeMetricsExports (V.head (resourceMetricsScopes rme)))+firstMetric _ = error "expected single ResourceMetricsExport"+++spec :: Spec+spec = do+ describe "OpenTelemetry.MeterProvider" $ do+ -- Counter (Int64)+ it "aggregates Int64 counter measurements (cumulative sum)" $ do+ (provider, env) <- createMeterProvider emptyMaterializedResources defaultSdkMeterProviderOptions+ m <- getMeter provider scope+ c <- meterCreateCounterInt64 m "acount" Nothing Nothing defaultAdvisoryParameters+ counterAdd c 3 emptyAttributes+ counterAdd c 7 emptyAttributes+ batches <- collectResourceMetrics env+ case firstMetric batches of+ MetricExportSum {mesSumPoints = pts, mesName = nm, mesMonotonic = mono, mesIsInt = isInt} -> do+ nm `shouldBe` "acount"+ mono `shouldBe` True+ isInt `shouldBe` True+ V.length pts `shouldBe` 1+ sumDataPointValue (V.head pts) `shouldBe` IntNumber 10+ _ -> expectationFailure "expected MetricExportSum"++ -- Counter (Double)+ it "aggregates Double counter measurements" $ do+ (provider, env) <- createMeterProvider emptyMaterializedResources defaultSdkMeterProviderOptions+ m <- getMeter provider scope+ c <- meterCreateCounterDouble m "dcounter" Nothing Nothing defaultAdvisoryParameters+ counterAdd c 1.5 emptyAttributes+ counterAdd c 2.5 emptyAttributes+ batches <- collectResourceMetrics env+ case firstMetric batches of+ MetricExportSum {mesSumPoints = pts, mesIsInt = isInt} -> do+ isInt `shouldBe` False+ sumDataPointValue (V.head pts) `shouldBe` DoubleNumber 4.0+ _ -> expectationFailure "expected MetricExportSum"++ -- UpDownCounter (Int64)+ it "aggregates Int64 up-down counter (non-monotonic)" $ do+ (provider, env) <- createMeterProvider emptyMaterializedResources defaultSdkMeterProviderOptions+ m <- getMeter provider scope+ udc <- meterCreateUpDownCounterInt64 m "queue.depth" Nothing Nothing defaultAdvisoryParameters+ upDownCounterAdd udc 10 emptyAttributes+ upDownCounterAdd udc (-3) emptyAttributes+ batches <- collectResourceMetrics env+ case firstMetric batches of+ MetricExportSum {mesSumPoints = pts, mesMonotonic = mono} -> do+ mono `shouldBe` False+ sumDataPointValue (V.head pts) `shouldBe` IntNumber 7+ _ -> expectationFailure "expected MetricExportSum"++ -- UpDownCounter (Double)+ it "aggregates Double up-down counter" $ do+ (provider, env) <- createMeterProvider emptyMaterializedResources defaultSdkMeterProviderOptions+ m <- getMeter provider scope+ udc <- meterCreateUpDownCounterDouble m "temp.diff" Nothing Nothing defaultAdvisoryParameters+ upDownCounterAdd udc 5.0 emptyAttributes+ upDownCounterAdd udc (-1.2) emptyAttributes+ batches <- collectResourceMetrics env+ case firstMetric batches of+ MetricExportSum {mesSumPoints = pts, mesMonotonic = mono, mesIsInt = isInt} -> do+ mono `shouldBe` False+ isInt `shouldBe` False+ case sumDataPointValue (V.head pts) of+ DoubleNumber d -> abs (d - 3.8) `shouldSatisfy` (< 0.001)+ _ -> expectationFailure "expected Double"+ _ -> expectationFailure "expected MetricExportSum"++ -- Histogram (explicit bounds)+ it "records explicit histogram measurements" $ do+ (provider, env) <- createMeterProvider emptyMaterializedResources defaultSdkMeterProviderOptions+ m <- getMeter provider scope+ h <- meterCreateHistogram m "latency" Nothing Nothing defaultAdvisoryParameters+ histogramRecord h 1.0 emptyAttributes+ histogramRecord h 50.0 emptyAttributes+ histogramRecord h 9999.0 emptyAttributes+ batches <- collectResourceMetrics env+ case firstMetric batches of+ MetricExportHistogram {mehPoints = pts, mehName = nm} -> do+ nm `shouldBe` "latency"+ V.length pts `shouldBe` 1+ let p = V.head pts+ histogramDataPointCount p `shouldBe` 3+ abs (histogramDataPointSum p - 10050.0) `shouldSatisfy` (< 0.001)+ histogramDataPointMin p `shouldBe` Just 1.0+ histogramDataPointMax p `shouldBe` Just 9999.0+ _ -> expectationFailure "expected MetricExportHistogram"++ -- Histogram with custom bounds via advisory+ it "honors advisory explicit bucket boundaries" $ do+ let adv = defaultAdvisoryParameters {advisoryExplicitBucketBoundaries = Just [10, 100]}+ (provider, env) <- createMeterProvider emptyMaterializedResources defaultSdkMeterProviderOptions+ m <- getMeter provider scope+ h <- meterCreateHistogram m "custom.hist" Nothing Nothing adv+ histogramRecord h 5.0 emptyAttributes+ histogramRecord h 50.0 emptyAttributes+ histogramRecord h 200.0 emptyAttributes+ batches <- collectResourceMetrics env+ case firstMetric batches of+ MetricExportHistogram {mehPoints = pts} -> do+ let p = V.head pts+ V.length (histogramDataPointExplicitBounds p) `shouldBe` 2+ V.length (histogramDataPointBucketCounts p) `shouldBe` 3+ V.toList (histogramDataPointBucketCounts p) `shouldBe` [1, 1, 1]+ _ -> expectationFailure "expected MetricExportHistogram"++ -- Gauge (Int64)+ it "records Int64 gauge (last value wins)" $ do+ (provider, env) <- createMeterProvider emptyMaterializedResources defaultSdkMeterProviderOptions+ m <- getMeter provider scope+ g <- meterCreateGaugeInt64 m "mem.used" Nothing Nothing defaultAdvisoryParameters+ gaugeRecord g 100 emptyAttributes+ gaugeRecord g 200 emptyAttributes+ batches <- collectResourceMetrics env+ case firstMetric batches of+ MetricExportGauge {megGaugePoints = pts, megIsInt = isInt} -> do+ isInt `shouldBe` True+ gaugeDataPointValue (V.head pts) `shouldBe` IntNumber 200+ _ -> expectationFailure "expected MetricExportGauge"++ -- Gauge (Double)+ it "records Double gauge" $ do+ (provider, env) <- createMeterProvider emptyMaterializedResources defaultSdkMeterProviderOptions+ m <- getMeter provider scope+ g <- meterCreateGaugeDouble m "cpu.pct" Nothing Nothing defaultAdvisoryParameters+ gaugeRecord g 0.75 emptyAttributes+ gaugeRecord g 0.42 emptyAttributes+ batches <- collectResourceMetrics env+ case firstMetric batches of+ MetricExportGauge {megGaugePoints = pts} ->+ gaugeDataPointValue (V.head pts) `shouldBe` DoubleNumber 0.42+ _ -> expectationFailure "expected MetricExportGauge"++ -- Exponential histogram+ it "exponential histogram records positive measurements" $ do+ let adv = defaultAdvisoryParameters {advisoryHistogramAggregation = Just (HistogramAggregationExponential 3)}+ (provider, env) <- createMeterProvider emptyMaterializedResources defaultSdkMeterProviderOptions+ m <- getMeter provider scope+ h <- meterCreateHistogram m "exp.latency" Nothing Nothing adv+ histogramRecord h 2.5 emptyAttributes+ histogramRecord h 0.0 emptyAttributes+ histogramRecord h 100.0 emptyAttributes+ batches <- collectResourceMetrics env+ case firstMetric batches of+ MetricExportExponentialHistogram {meehPoints = pts} -> do+ V.length pts `shouldBe` 1+ let p = V.head pts+ exponentialHistogramDataPointCount p `shouldBe` 3+ exponentialHistogramDataPointZeroCount p `shouldBe` 1+ V.null (exponentialHistogramDataPointPositiveBucketCounts p) `shouldBe` False+ _ -> expectationFailure "expected MetricExportExponentialHistogram"++ -- Exponential histogram negative values+ it "exponential histogram records negative measurements" $ do+ let adv = defaultAdvisoryParameters {advisoryHistogramAggregation = Just (HistogramAggregationExponential 2)}+ (provider, env) <- createMeterProvider emptyMaterializedResources defaultSdkMeterProviderOptions+ m <- getMeter provider scope+ h <- meterCreateHistogram m "signed" Nothing Nothing adv+ histogramRecord h (-5.0) emptyAttributes+ histogramRecord h (-1.0) emptyAttributes+ batches <- collectResourceMetrics env+ case firstMetric batches of+ MetricExportExponentialHistogram {meehPoints = pts} -> do+ let p = V.head pts+ exponentialHistogramDataPointCount p `shouldBe` 2+ V.null (exponentialHistogramDataPointNegativeBucketCounts p) `shouldBe` False+ _ -> expectationFailure "expected MetricExportExponentialHistogram"++ -- Observable counter+ it "observable counter callbacks run on collect" $ do+ (provider, env) <- createMeterProvider emptyMaterializedResources defaultSdkMeterProviderOptions+ m <- getMeter provider scope+ let cb res = observe res (42 :: Int64) emptyAttributes+ _ <- meterCreateObservableCounterInt64 m "obs.counter" Nothing Nothing defaultAdvisoryParameters [cb]+ batches <- collectResourceMetrics env+ case firstMetric batches of+ MetricExportSum {mesSumPoints = pts, mesName = nm, mesMonotonic = mono} -> do+ nm `shouldBe` "obs.counter"+ mono `shouldBe` True+ sumDataPointValue (V.head pts) `shouldBe` IntNumber 42+ _ -> expectationFailure "expected MetricExportSum"++ -- Observable gauge+ it "observable gauge reports last observed value" $ do+ (provider, env) <- createMeterProvider emptyMaterializedResources defaultSdkMeterProviderOptions+ m <- getMeter provider scope+ let cb res = observe res (3.14 :: Double) emptyAttributes+ _ <- meterCreateObservableGaugeDouble m "obs.gauge" Nothing Nothing defaultAdvisoryParameters [cb]+ batches <- collectResourceMetrics env+ case firstMetric batches of+ MetricExportGauge {megGaugePoints = pts, megName = nm} -> do+ nm `shouldBe` "obs.gauge"+ gaugeDataPointValue (V.head pts) `shouldBe` DoubleNumber 3.14+ _ -> expectationFailure "expected MetricExportGauge"++ -- Observable up-down counter+ it "observable up-down counter is non-monotonic" $ do+ (provider, env) <- createMeterProvider emptyMaterializedResources defaultSdkMeterProviderOptions+ m <- getMeter provider scope+ let cb res = observe res (-10 :: Int64) emptyAttributes+ _ <- meterCreateObservableUpDownCounterInt64 m "obs.udc" Nothing Nothing defaultAdvisoryParameters [cb]+ batches <- collectResourceMetrics env+ case firstMetric batches of+ MetricExportSum {mesSumPoints = pts, mesMonotonic = mono} -> do+ mono `shouldBe` False+ sumDataPointValue (V.head pts) `shouldBe` IntNumber (-10)+ _ -> expectationFailure "expected MetricExportSum"++ -- Cardinality limit — excess goes to overflow bucket (otel.metric.overflow=true)+ it "respects cardinality limit (overflow attribute)" $ do+ (provider, env) <-+ createMeterProvider emptyMaterializedResources $+ defaultSdkMeterProviderOptions {cardinalityLimit = 1}+ m <- getMeter provider scope+ c <- meterCreateCounterInt64 m "acount" Nothing Nothing defaultAdvisoryParameters+ let a1 = addAttribute defaultAttributeLimits emptyAttributes "route" ("x" :: Text)+ a2 = addAttribute defaultAttributeLimits emptyAttributes "route" ("y" :: Text)+ counterAdd c 1 a1+ counterAdd c 100 a2+ batches <- collectResourceMetrics env+ case firstMetric batches of+ MetricExportSum {mesSumPoints = pts} -> do+ V.length pts `shouldBe` 2+ let overflow = V.filter (\p -> lookupAttribute (sumDataPointAttributes p) "otel.metric.overflow" == Just (AttributeValue (BoolAttribute True))) pts+ V.length overflow `shouldBe` 1+ sumDataPointValue (V.head overflow) `shouldBe` IntNumber 100+ _ -> expectationFailure "expected MetricExportSum"++ -- View drop+ it "view drop prevents recording" $ do+ let v = mkView "nope" Nothing ViewAggregationDrop Nothing Nothing Nothing+ opts = defaultSdkMeterProviderOptions {views = [v]}+ (provider, env) <- createMeterProvider emptyMaterializedResources opts+ m <- getMeter provider scope+ c <- meterCreateCounterInt64 m "nope" Nothing Nothing defaultAdvisoryParameters+ counterAdd c 1 emptyAttributes+ batches <- collectResourceMetrics env+ case batches of+ [rme] -> V.null (resourceMetricsScopes rme) `shouldBe` True+ _ -> expectationFailure "expected single ResourceMetricsExport"++ -- View name override+ it "view overrides exported metric name" $ do+ let v = mkView "original" Nothing ViewAggregationDefault Nothing (Just "renamed") Nothing+ opts = defaultSdkMeterProviderOptions {views = [v]}+ (provider, env) <- createMeterProvider emptyMaterializedResources opts+ m <- getMeter provider scope+ c <- meterCreateCounterInt64 m "original" Nothing Nothing defaultAdvisoryParameters+ counterAdd c 5 emptyAttributes+ batches <- collectResourceMetrics env+ case firstMetric batches of+ MetricExportSum {mesName = nm} -> nm `shouldBe` "renamed"+ _ -> expectationFailure "expected MetricExportSum"++ -- View description override+ it "view overrides exported metric description" $ do+ let v = mkView "described" Nothing ViewAggregationDefault Nothing Nothing (Just "new desc")+ opts = defaultSdkMeterProviderOptions {views = [v]}+ (provider, env) <- createMeterProvider emptyMaterializedResources opts+ m <- getMeter provider scope+ c <- meterCreateCounterInt64 m "described" Nothing (Just "old desc") defaultAdvisoryParameters+ counterAdd c 1 emptyAttributes+ batches <- collectResourceMetrics env+ case firstMetric batches of+ MetricExportSum {mesDescription = d} -> d `shouldBe` "new desc"+ _ -> expectationFailure "expected MetricExportSum"++ -- View attribute key filtering+ it "view filters attribute keys on export" $ do+ let v = mkView "filtered" Nothing ViewAggregationDefault (Just ["keep"]) Nothing Nothing+ opts = defaultSdkMeterProviderOptions {views = [v]}+ (provider, env) <- createMeterProvider emptyMaterializedResources opts+ m <- getMeter provider scope+ c <- meterCreateCounterInt64 m "filtered" Nothing Nothing defaultAdvisoryParameters+ let attrs =+ addAttribute+ defaultAttributeLimits+ (addAttribute defaultAttributeLimits emptyAttributes "keep" ("v1" :: Text))+ "drop"+ ("v2" :: Text)+ counterAdd c 1 attrs+ batches <- collectResourceMetrics env+ case firstMetric batches of+ MetricExportSum {mesSumPoints = pts} -> do+ let a = sumDataPointAttributes (V.head pts)+ a `shouldSatisfy` (\x -> show x `seq` True)+ _ -> expectationFailure "expected MetricExportSum"++ -- View explicit bucket histogram override+ it "view overrides histogram to explicit bucket with custom bounds" $ do+ let v = mkView "h.*" Nothing (ViewAggregationExplicitBucketHistogram [1, 10, 100]) Nothing Nothing Nothing+ opts = defaultSdkMeterProviderOptions {views = [v]}+ (provider, env) <- createMeterProvider emptyMaterializedResources opts+ m <- getMeter provider scope+ h <- meterCreateHistogram m "h.latency" Nothing Nothing defaultAdvisoryParameters+ histogramRecord h 5.0 emptyAttributes+ batches <- collectResourceMetrics env+ case firstMetric batches of+ MetricExportHistogram {mehPoints = pts} -> do+ let p = V.head pts+ V.length (histogramDataPointExplicitBounds p) `shouldBe` 3+ _ -> expectationFailure "expected MetricExportHistogram"++ -- View exponential histogram override+ it "view overrides histogram to exponential" $ do+ let v = mkView "h.*" Nothing (ViewAggregationExponentialHistogram 5) Nothing Nothing Nothing+ opts = defaultSdkMeterProviderOptions {views = [v]}+ (provider, env) <- createMeterProvider emptyMaterializedResources opts+ m <- getMeter provider scope+ h <- meterCreateHistogram m "h.exp" Nothing Nothing defaultAdvisoryParameters+ histogramRecord h 42.0 emptyAttributes+ batches <- collectResourceMetrics env+ case firstMetric batches of+ MetricExportExponentialHistogram {meehPoints = pts} ->+ V.length pts `shouldBe` 1+ _ -> expectationFailure "expected MetricExportExponentialHistogram"++ -- Delta temporality+ it "delta temporality resets after collect" $ do+ let opts = defaultSdkMeterProviderOptions {aggregationTemporality = AggregationDelta}+ (provider, env) <- createMeterProvider emptyMaterializedResources opts+ m <- getMeter provider scope+ c <- meterCreateCounterInt64 m "delta.c" Nothing Nothing defaultAdvisoryParameters+ counterAdd c 5 emptyAttributes+ b1 <- collectResourceMetrics env+ case firstMetric b1 of+ MetricExportSum {mesSumPoints = pts, mesAggregationTemporality = temp} -> do+ temp `shouldBe` AggregationDelta+ sumDataPointValue (V.head pts) `shouldBe` IntNumber 5+ _ -> expectationFailure "expected MetricExportSum"+ counterAdd c 3 emptyAttributes+ b2 <- collectResourceMetrics env+ case firstMetric b2 of+ MetricExportSum {mesSumPoints = pts} ->+ sumDataPointValue (V.head pts) `shouldBe` IntNumber 3+ _ -> expectationFailure "expected MetricExportSum"++ -- Delta temporality for histogram+ it "delta temporality resets histogram after collect" $ do+ let opts = defaultSdkMeterProviderOptions {aggregationTemporality = AggregationDelta}+ (provider, env) <- createMeterProvider emptyMaterializedResources opts+ m <- getMeter provider scope+ h <- meterCreateHistogram m "delta.hist" Nothing Nothing defaultAdvisoryParameters+ histogramRecord h 10.0 emptyAttributes+ _ <- collectResourceMetrics env+ histogramRecord h 20.0 emptyAttributes+ b2 <- collectResourceMetrics env+ case firstMetric b2 of+ MetricExportHistogram {mehPoints = pts} -> do+ let p = V.head pts+ histogramDataPointCount p `shouldBe` 1+ abs (histogramDataPointSum p - 20.0) `shouldSatisfy` (< 0.001)+ _ -> expectationFailure "expected MetricExportHistogram"++ -- Multiple attribute sets produce multiple points+ it "multiple attribute sets produce separate data points" $ do+ (provider, env) <- createMeterProvider emptyMaterializedResources defaultSdkMeterProviderOptions+ m <- getMeter provider scope+ c <- meterCreateCounterInt64 m "multi" Nothing Nothing defaultAdvisoryParameters+ let a1 = addAttribute defaultAttributeLimits emptyAttributes "k" ("v1" :: Text)+ a2 = addAttribute defaultAttributeLimits emptyAttributes "k" ("v2" :: Text)+ counterAdd c 1 a1+ counterAdd c 2 a2+ batches <- collectResourceMetrics env+ case firstMetric batches of+ MetricExportSum {mesSumPoints = pts} ->+ V.length pts `shouldBe` 2+ _ -> expectationFailure "expected MetricExportSum"++ -- startTimeUnixNano is populated+ it "startTimeUnixNano is non-zero for cumulative" $ do+ (provider, env) <- createMeterProvider emptyMaterializedResources defaultSdkMeterProviderOptions+ m <- getMeter provider scope+ c <- meterCreateCounterInt64 m "timed" Nothing Nothing defaultAdvisoryParameters+ counterAdd c 1 emptyAttributes+ batches <- collectResourceMetrics env+ case firstMetric batches of+ MetricExportSum {mesSumPoints = pts} ->+ sumDataPointStartTimeUnixNano (V.head pts) `shouldSatisfy` (> (0 :: Word64))+ _ -> expectationFailure "expected MetricExportSum"++ -- Shutdown prevents further recording+ it "shutdown prevents further recording" $ do+ (provider, env) <- createMeterProvider emptyMaterializedResources defaultSdkMeterProviderOptions+ m <- getMeter provider scope+ c <- meterCreateCounterInt64 m "pre.shutdown" Nothing Nothing defaultAdvisoryParameters+ counterAdd c 10 emptyAttributes+ result <- shutdownMeterProvider provider Nothing+ result `shouldBe` ShutdownSuccess+ -- After shutdown, getMeter returns noop+ m2 <- getMeter provider scope+ c2 <- meterCreateCounterInt64 m2 "post.shutdown" Nothing Nothing defaultAdvisoryParameters+ counterAdd c2 99 emptyAttributes+ batches <- collectResourceMetrics env+ case batches of+ [rme] -> V.null (resourceMetricsScopes rme) `shouldBe` True+ _ -> expectationFailure "expected single ResourceMetricsExport"++ -- ForceFlush triggers a collect+ it "forceFlush succeeds" $ do+ (provider, _env) <- createMeterProvider emptyMaterializedResources defaultSdkMeterProviderOptions+ result <- forceFlushMeterProvider provider Nothing+ result `shouldBe` FlushSuccess++ -- Invalid instrument name produces noop+ it "invalid instrument name produces noop instrument" $ do+ (provider, env) <- createMeterProvider emptyMaterializedResources defaultSdkMeterProviderOptions+ m <- getMeter provider scope+ c <- meterCreateCounterInt64 m "" Nothing Nothing defaultAdvisoryParameters+ enabled <- counterEnabled c+ enabled `shouldBe` False+ counterAdd c 99 emptyAttributes+ batches <- collectResourceMetrics env+ case batches of+ [rme] -> V.null (resourceMetricsScopes rme) `shouldBe` True+ _ -> expectationFailure "expected single ResourceMetricsExport"++ -- Enabled is True for valid SDK instruments+ it "enabled returns True for valid SDK instruments" $ do+ (provider, _) <- createMeterProvider emptyMaterializedResources defaultSdkMeterProviderOptions+ m <- getMeter provider scope+ c <- meterCreateCounterInt64 m "valid" Nothing Nothing defaultAdvisoryParameters+ enabled <- counterEnabled c+ enabled `shouldBe` True++ -- Empty collect returns empty scopes+ it "collecting without recording returns empty scopes" $ do+ (_, env) <- createMeterProvider emptyMaterializedResources defaultSdkMeterProviderOptions+ batches <- collectResourceMetrics env+ case batches of+ [rme] -> V.null (resourceMetricsScopes rme) `shouldBe` True+ _ -> expectationFailure "expected single ResourceMetricsExport"
+ test/OpenTelemetry/MetricReaderSpec.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}++module OpenTelemetry.MetricReaderSpec (spec) where++import Data.IORef+import OpenTelemetry.Exporter.Metric (+ MetricExporter (..),+ )+import OpenTelemetry.Internal.Common.Types (ExportResult (..), FlushResult (..), ShutdownResult (..))+import OpenTelemetry.MeterProvider (+ SdkMeterProviderOptions (..),+ createMeterProvider,+ defaultSdkMeterProviderOptions,+ )+import OpenTelemetry.MetricReader+import OpenTelemetry.Resource (emptyMaterializedResources)+import Test.Hspec+++spec :: Spec+spec = describe "MetricReader" $ do+ describe "defaultPeriodicMetricReaderOptions" $ do+ it "has 60s interval" $ do+ periodicIntervalMicros defaultPeriodicMetricReaderOptions `shouldBe` 60_000_000++ describe "exportMetricsOnce" $ do+ it "collects and exports a single batch" $ do+ exportCountRef <- newIORef (0 :: Int)+ let exporter =+ MetricExporter+ { metricExporterExport = \_ -> do+ modifyIORef' exportCountRef (+ 1)+ pure Success+ , metricExporterShutdown = pure ShutdownSuccess+ , metricExporterForceFlush = pure FlushSuccess+ }+ (_mp, env) <- createMeterProvider emptyMaterializedResources defaultSdkMeterProviderOptions {metricExporter = Just exporter}+ result <- exportMetricsOnce env exporter+ case result of+ Success -> pure ()+ _ -> expectationFailure "expected Success"+ count <- readIORef exportCountRef+ count `shouldBe` 1++ describe "forkPeriodicMetricReader" $ do+ it "can be started and stopped" $ do+ exportCountRef <- newIORef (0 :: Int)+ let exporter =+ MetricExporter+ { metricExporterExport = \_ -> do+ modifyIORef' exportCountRef (+ 1)+ pure Success+ , metricExporterShutdown = pure ShutdownSuccess+ , metricExporterForceFlush = pure FlushSuccess+ }+ opts =+ PeriodicMetricReaderOptions+ { periodicIntervalMicros = 100_000+ }+ (_mp, env) <- createMeterProvider emptyMaterializedResources defaultSdkMeterProviderOptions {metricExporter = Just exporter}+ handle <- forkPeriodicMetricReader env exporter opts+ stopPeriodicMetricReader handle+ count <- readIORef exportCountRef+ count `shouldSatisfy` (>= 1)
+ test/OpenTelemetry/Resource/DetectorSpec.hs view
@@ -0,0 +1,624 @@+{-# LANGUAGE OverloadedStrings #-}++module OpenTelemetry.Resource.DetectorSpec where++import Control.Exception (throwIO)+import qualified Data.HashMap.Strict as H+import Data.Maybe (isJust, isNothing)+import qualified Data.Text as T+import OpenTelemetry.Attributes (lookupAttribute, toAttribute)+import OpenTelemetry.Attributes.Key (unkey)+import OpenTelemetry.Registry (registerResourceDetector, registeredResourceDetectors)+import OpenTelemetry.Resource (Resource, getMaterializedResourcesAttributes, getResourceAttributes, materializeResources, mkResource, (.=))+import OpenTelemetry.Resource.Cloud (Cloud (..))+import OpenTelemetry.Resource.Cloud.Detector (detectCloud)+import OpenTelemetry.Resource.Container (Container (..))+import OpenTelemetry.Resource.Container.Detector (detectContainer)+import OpenTelemetry.Resource.Detector.AWS.EKS (detectEKSSelf)+import OpenTelemetry.Resource.Detector.Heroku (detectHeroku)+import OpenTelemetry.Resource.FaaS (FaaS (..))+import OpenTelemetry.Resource.FaaS.Detector (detectFaaS)+import qualified OpenTelemetry.Resource.Kubernetes as K8s+import OpenTelemetry.Resource.Kubernetes.Detector (KubernetesResources (..), detectKubernetes, isRunningInKubernetes)+import OpenTelemetry.Resource.OperatingSystem (OperatingSystem (..))+import OpenTelemetry.Resource.OperatingSystem.Detector (detectOperatingSystem)+import qualified OpenTelemetry.SemanticConventions as SC+import OpenTelemetry.Trace (detectBuiltInResources, registerBuiltinResourceDetectors)+import System.Environment (lookupEnv, setEnv, unsetEnv)+import System.Info (os)+import Test.Hspec+++spec :: Spec+spec = describe "Resource Detectors" $ do+ -- Resource SDK §Detecting Resource information from the environment+ -- https://opentelemetry.io/docs/specs/otel/resource/sdk/#detecting-resource-information-from-the-environment+ containerSpec+ kubernetesSpec+ cloudSpec+ eksSpec+ faasSpec+ osSpec+ herokuSpec+ gcpParsingSpec+ ecsArnSpec+ registrySpec+++containerSpec :: Spec+containerSpec = describe "Container" $ do+ -- Semantic conventions: container.* resource attributes (when detectable)+ -- https://opentelemetry.io/docs/specs/semconv/resource/container/+ it "returns all Nothing fields on macOS/non-Linux" $ do+ container <- detectContainer+ case os of+ "darwin" -> do+ containerId container `shouldBe` Nothing+ _ -> pure ()+++kubernetesSpec :: Spec+kubernetesSpec = describe "Kubernetes" $ do+ -- Semantic conventions: Kubernetes resource (k8s.*)+ -- https://opentelemetry.io/docs/specs/semconv/resource/kubernetes/+ around_ withCleanK8sEnv $ do+ it "returns Nothing when not in k8s" $ do+ result <- detectKubernetes+ result `shouldSatisfy` isNothing++ it "detects k8s via KUBERNETES_SERVICE_HOST" $ do+ setEnv "KUBERNETES_SERVICE_HOST" "10.0.0.1"+ setEnv "HOSTNAME" "my-pod-abc123"+ inK8s <- isRunningInKubernetes+ inK8s `shouldBe` True+ result <- detectKubernetes+ result `shouldSatisfy` isJust++ it "reads pod name from HOSTNAME" $ do+ setEnv "KUBERNETES_SERVICE_HOST" "10.0.0.1"+ setEnv "HOSTNAME" "web-server-7f9d4c-x2k4p"+ Just k8s <- detectKubernetes+ K8s.podName (k8sPod k8s) `shouldBe` Just "web-server-7f9d4c-x2k4p"++ it "prefers K8S_POD_NAME over HOSTNAME" $ do+ setEnv "KUBERNETES_SERVICE_HOST" "10.0.0.1"+ setEnv "HOSTNAME" "web-server-7f9d4c-x2k4p"+ setEnv "K8S_POD_NAME" "explicit-pod-name"+ Just k8s <- detectKubernetes+ K8s.podName (k8sPod k8s) `shouldBe` Just "explicit-pod-name"++ it "reads cluster name from K8S_CLUSTER_NAME" $ do+ setEnv "KUBERNETES_SERVICE_HOST" "10.0.0.1"+ setEnv "K8S_CLUSTER_NAME" "production-us-east"+ Just k8s <- detectKubernetes+ K8s.clusterName (k8sCluster k8s) `shouldBe` Just "production-us-east"++ it "reads node name from K8S_NODE_NAME" $ do+ setEnv "KUBERNETES_SERVICE_HOST" "10.0.0.1"+ setEnv "K8S_NODE_NAME" "ip-10-0-1-42"+ Just k8s <- detectKubernetes+ K8s.nodeName (k8sNode k8s) `shouldBe` Just "ip-10-0-1-42"++ it "reads namespace from K8S_NAMESPACE" $ do+ setEnv "KUBERNETES_SERVICE_HOST" "10.0.0.1"+ setEnv "K8S_NAMESPACE" "production"+ Just k8s <- detectKubernetes+ K8s.namespaceName (k8sNamespace k8s) `shouldBe` Just "production"+++cloudSpec :: Spec+cloudSpec = describe "Cloud" $ do+ -- Semantic conventions: cloud.* resource attributes+ -- https://opentelemetry.io/docs/specs/semconv/resource/cloud/+ around_ withCleanCloudEnv $ do+ it "returns empty cloud when no provider detected" $ do+ cloud <- detectCloud+ cloudProvider cloud `shouldBe` Nothing++ it "detects AWS from AWS_REGION" $ do+ setEnv "AWS_REGION" "us-east-1"+ cloud <- detectCloud+ cloudProvider cloud `shouldBe` Just "aws"+ cloudRegion cloud `shouldBe` Just "us-east-1"++ it "detects AWS Lambda" $ do+ setEnv "AWS_LAMBDA_FUNCTION_NAME" "my-function"+ setEnv "AWS_REGION" "eu-west-1"+ cloud <- detectCloud+ cloudProvider cloud `shouldBe` Just "aws"+ cloudPlatform cloud `shouldBe` Just "aws_lambda"+ cloudRegion cloud `shouldBe` Just "eu-west-1"++ it "detects AWS ECS" $ do+ setEnv "ECS_CONTAINER_METADATA_URI_V4" "http://169.254.170.2/v4/abc123"+ setEnv "AWS_REGION" "us-west-2"+ cloud <- detectCloud+ cloudProvider cloud `shouldBe` Just "aws"+ cloudPlatform cloud `shouldBe` Just "aws_ecs"++ it "detects AWS App Runner" $ do+ setEnv "AWS_APP_RUNNER_SERVICE_ID" "svc-123"+ setEnv "AWS_REGION" "us-east-1"+ cloud <- detectCloud+ cloudProvider cloud `shouldBe` Just "aws"+ cloudPlatform cloud `shouldBe` Just "aws_app_runner"++ it "detects GCP from GOOGLE_CLOUD_PROJECT" $ do+ setEnv "GOOGLE_CLOUD_PROJECT" "my-project"+ cloud <- detectCloud+ cloudProvider cloud `shouldBe` Just "gcp"+ cloudAccountId cloud `shouldBe` Just "my-project"++ it "detects GCP Cloud Run" $ do+ setEnv "K_SERVICE" "my-service"+ setEnv "GOOGLE_CLOUD_PROJECT" "my-project"+ setEnv "GOOGLE_CLOUD_REGION" "us-central1"+ cloud <- detectCloud+ cloudProvider cloud `shouldBe` Just "gcp"+ cloudPlatform cloud `shouldBe` Just "gcp_cloud_run"+ cloudRegion cloud `shouldBe` Just "us-central1"++ it "detects GCP Cloud Functions" $ do+ setEnv "FUNCTION_TARGET" "helloWorld"+ setEnv "GOOGLE_CLOUD_PROJECT" "my-project"+ setEnv "FUNCTION_REGION" "us-central1"+ cloud <- detectCloud+ cloudProvider cloud `shouldBe` Just "gcp"+ cloudPlatform cloud `shouldBe` Just "gcp_cloud_functions"+ cloudRegion cloud `shouldBe` Just "us-central1"++ it "detects Azure App Service" $ do+ setEnv "WEBSITE_SITE_NAME" "my-app"+ cloud <- detectCloud+ cloudProvider cloud `shouldBe` Just "azure"+ cloudPlatform cloud `shouldBe` Just "azure.app_service"++ it "detects Azure Functions" $ do+ setEnv "FUNCTIONS_WORKER_RUNTIME" "custom"+ setEnv "REGION_NAME" "eastus"+ cloud <- detectCloud+ cloudProvider cloud `shouldBe` Just "azure"+ cloudPlatform cloud `shouldBe` Just "azure.functions"+ cloudRegion cloud `shouldBe` Just "eastus"++ it "detects Azure Container Apps" $ do+ setEnv "CONTAINER_APP_NAME" "my-container-app"+ cloud <- detectCloud+ cloudProvider cloud `shouldBe` Just "azure"+ cloudPlatform cloud `shouldBe` Just "azure.container_apps"++ it "detects AWS EKS from KUBERNETES_SERVICE_HOST + AWS env" $ do+ setEnv "AWS_REGION" "us-east-1"+ setEnv "KUBERNETES_SERVICE_HOST" "10.96.0.1"+ cloud <- detectCloud+ cloudProvider cloud `shouldBe` Just "aws"+ cloudPlatform cloud `shouldBe` Just "aws_eks"++ it "prefers ECS over EKS when both present" $ do+ setEnv "ECS_CONTAINER_METADATA_URI_V4" "http://169.254.170.2/v4/abc"+ setEnv "AWS_REGION" "us-east-1"+ setEnv "KUBERNETES_SERVICE_HOST" "10.96.0.1"+ cloud <- detectCloud+ cloudPlatform cloud `shouldBe` Just "aws_ecs"++ it "prefers AWS over GCP when both present" $ do+ setEnv "AWS_REGION" "us-east-1"+ setEnv "GOOGLE_CLOUD_PROJECT" "my-project"+ cloud <- detectCloud+ cloudProvider cloud `shouldBe` Just "aws"+++eksSpec :: Spec+eksSpec = describe "EKS" $ do+ -- Semantic conventions: AWS EKS (cloud.platform aws_eks)+ -- https://opentelemetry.io/docs/specs/semconv/resource/cloud/+ around_ withCleanEksEnv $ do+ it "returns empty when not in k8s" $ do+ r <- detectEKSSelf+ lookupAttribute (getResourceAttributes r) (unkey SC.cloud_platform) `shouldBe` Nothing++ it "returns empty when ECS is detected (yields to more specific detector)" $ do+ setEnv "KUBERNETES_SERVICE_HOST" "10.96.0.1"+ setEnv "ECS_CONTAINER_METADATA_URI_V4" "http://169.254.170.2/v4/abc"+ r <- detectEKSSelf+ lookupAttribute (getResourceAttributes r) (unkey SC.cloud_platform) `shouldBe` Nothing++ it "returns empty when Lambda is detected" $ do+ setEnv "KUBERNETES_SERVICE_HOST" "10.96.0.1"+ setEnv "AWS_LAMBDA_FUNCTION_NAME" "my-func"+ r <- detectEKSSelf+ lookupAttribute (getResourceAttributes r) (unkey SC.cloud_platform) `shouldBe` Nothing++ it "returns empty when service account files are missing" $ do+ setEnv "KUBERNETES_SERVICE_HOST" "10.96.0.1"+ r <- detectEKSSelf+ lookupAttribute (getResourceAttributes r) (unkey SC.cloud_platform) `shouldBe` Nothing+++faasSpec :: Spec+faasSpec = describe "FaaS" $ do+ -- Semantic conventions: faas.* resource attributes+ -- https://opentelemetry.io/docs/specs/semconv/resource/faas/+ around_ withCleanFaaSEnv $ do+ it "returns Nothing when not in FaaS" $ do+ result <- detectFaaS+ result `shouldSatisfy` isNothing++ it "detects AWS Lambda" $ do+ setEnv "AWS_LAMBDA_FUNCTION_NAME" "my-handler"+ setEnv "AWS_LAMBDA_FUNCTION_VERSION" "$LATEST"+ setEnv "AWS_LAMBDA_LOG_STREAM_NAME" "2024/01/01/[$LATEST]abc123"+ setEnv "AWS_LAMBDA_FUNCTION_MEMORY_SIZE" "256"+ setEnv "AWS_REGION" "us-east-1"+ result <- detectFaaS+ case result of+ Nothing -> expectationFailure "Expected FaaS detection"+ Just faas -> do+ faasName faas `shouldBe` "my-handler"+ faasVersion faas `shouldBe` Just "$LATEST"+ faasInstance faas `shouldBe` Just "2024/01/01/[$LATEST]abc123"+ faasMaxMemory faas `shouldBe` Just (256 * 1048576)++ it "detects GCP Cloud Functions" $ do+ setEnv "FUNCTION_TARGET" "helloWorld"+ setEnv "K_REVISION" "helloWorld-00001"+ setEnv "FUNCTION_MEMORY_MB" "256"+ result <- detectFaaS+ case result of+ Nothing -> expectationFailure "Expected FaaS detection"+ Just faas -> do+ faasName faas `shouldBe` "helloWorld"+ faasVersion faas `shouldBe` Just "helloWorld-00001"+ faasMaxMemory faas `shouldBe` Just (256 * 1048576)++ it "detects Azure Functions" $ do+ setEnv "FUNCTIONS_WORKER_RUNTIME" "custom"+ setEnv "WEBSITE_SITE_NAME" "my-func-app"+ result <- detectFaaS+ case result of+ Nothing -> expectationFailure "Expected FaaS detection"+ Just faas -> do+ faasName faas `shouldBe` "my-func-app"++ it "prefers Lambda over GCF when both present" $ do+ setEnv "AWS_LAMBDA_FUNCTION_NAME" "my-lambda"+ setEnv "FUNCTION_TARGET" "my-gcf"+ result <- detectFaaS+ case result of+ Nothing -> expectationFailure "Expected FaaS detection"+ Just faas -> faasName faas `shouldBe` "my-lambda"+++herokuSpec :: Spec+herokuSpec = describe "Heroku" $ do+ -- Semantic conventions: Heroku (cloud.provider heroku, heroku.*)+ -- https://opentelemetry.io/docs/specs/semconv/resource/heroku/+ around_ withCleanHerokuEnv $ do+ it "returns empty resource when not on Heroku" $ do+ r <- detectHeroku+ lookupAttribute (getResourceAttributes r) (unkey SC.cloud_provider) `shouldBe` Nothing++ it "detects Heroku from HEROKU_APP_ID" $ do+ setEnv "HEROKU_APP_ID" "abc-123"+ setEnv "HEROKU_APP_NAME" "my-haskell-app"+ setEnv "HEROKU_DYNO_ID" "web.1"+ setEnv "HEROKU_RELEASE_VERSION" "v42"+ setEnv "HEROKU_SLUG_COMMIT" "deadbeef"+ setEnv "HEROKU_RELEASE_CREATED_AT" "2026-04-06T12:00:00Z"+ r <- detectHeroku+ let attrs = getResourceAttributes r+ lookupAttribute attrs (unkey SC.cloud_provider) `shouldBe` Just (toAttribute ("heroku" :: T.Text))+ lookupAttribute attrs (unkey SC.heroku_app_id) `shouldBe` Just (toAttribute ("abc-123" :: T.Text))+ lookupAttribute attrs (unkey SC.service_name) `shouldBe` Just (toAttribute ("my-haskell-app" :: T.Text))+ lookupAttribute attrs (unkey SC.service_instance_id) `shouldBe` Just (toAttribute ("web.1" :: T.Text))+ lookupAttribute attrs (unkey SC.service_version) `shouldBe` Just (toAttribute ("v42" :: T.Text))+ lookupAttribute attrs (unkey SC.heroku_release_commit) `shouldBe` Just (toAttribute ("deadbeef" :: T.Text))+ lookupAttribute attrs (unkey SC.heroku_release_creationTimestamp) `shouldBe` Just (toAttribute ("2026-04-06T12:00:00Z" :: T.Text))++ it "sets only cloud.provider and heroku.app.id when other vars are missing" $ do+ setEnv "HEROKU_APP_ID" "minimal-123"+ r <- detectHeroku+ let attrs = getResourceAttributes r+ lookupAttribute attrs (unkey SC.cloud_provider) `shouldBe` Just (toAttribute ("heroku" :: T.Text))+ lookupAttribute attrs (unkey SC.heroku_app_id) `shouldBe` Just (toAttribute ("minimal-123" :: T.Text))+ lookupAttribute attrs (unkey SC.service_name) `shouldBe` Nothing+++osSpec :: Spec+osSpec = describe "OperatingSystem" $ do+ -- Semantic conventions: operating system (os.type)+ -- https://opentelemetry.io/docs/specs/semconv/resource/os/+ it "detects os type" $ do+ osInfo <- detectOperatingSystem+ osType osInfo `shouldSatisfy` (not . T.null)++ it "maps mingw32 to windows" $ do+ osInfo <- detectOperatingSystem+ if os == "mingw32"+ then osType osInfo `shouldBe` "windows"+ else osType osInfo `shouldBe` T.pack os+++-- Helpers to clean up env vars between tests++withCleanK8sEnv :: IO () -> IO ()+withCleanK8sEnv action = do+ saved <- mapM saveEnv k8sEnvVars+ mapM_ safeUnsetEnv k8sEnvVars+ action+ mapM_ (uncurry restoreEnv) (zip k8sEnvVars saved)+++withCleanCloudEnv :: IO () -> IO ()+withCleanCloudEnv action = do+ saved <- mapM saveEnv cloudEnvVars+ mapM_ safeUnsetEnv cloudEnvVars+ action+ mapM_ (uncurry restoreEnv) (zip cloudEnvVars saved)+++withCleanFaaSEnv :: IO () -> IO ()+withCleanFaaSEnv action = do+ saved <- mapM saveEnv faasEnvVars+ mapM_ safeUnsetEnv faasEnvVars+ action+ mapM_ (uncurry restoreEnv) (zip faasEnvVars saved)+++withCleanHerokuEnv :: IO () -> IO ()+withCleanHerokuEnv action = do+ saved <- mapM saveEnv herokuEnvVars+ mapM_ safeUnsetEnv herokuEnvVars+ action+ mapM_ (uncurry restoreEnv) (zip herokuEnvVars saved)+++saveEnv :: String -> IO (Maybe String)+saveEnv = lookupEnv+++restoreEnv :: String -> Maybe String -> IO ()+restoreEnv key Nothing = safeUnsetEnv key+restoreEnv key (Just val) = setEnv key val+++safeUnsetEnv :: String -> IO ()+safeUnsetEnv = unsetEnv+++k8sEnvVars :: [String]+k8sEnvVars =+ [ "KUBERNETES_SERVICE_HOST"+ , "KUBERNETES_SERVICE_PORT"+ , "HOSTNAME"+ , "K8S_POD_NAME"+ , "K8S_POD_UID"+ , "K8S_CLUSTER_NAME"+ , "K8S_NODE_NAME"+ , "K8S_NAMESPACE"+ ]+++cloudEnvVars :: [String]+cloudEnvVars =+ [ "AWS_REGION"+ , "AWS_DEFAULT_REGION"+ , "AWS_LAMBDA_FUNCTION_NAME"+ , "ECS_CONTAINER_METADATA_URI_V4"+ , "ECS_CONTAINER_METADATA_URI"+ , "ELASTIC_BEANSTALK_ENVIRONMENT_NAME"+ , "AWS_APP_RUNNER_SERVICE_ID"+ , "AWS_EXECUTION_ENV"+ , "AWS_AVAILABILITY_ZONE"+ , "AWS_ACCOUNT_ID"+ , "KUBERNETES_SERVICE_HOST"+ , "KUBERNETES_SERVICE_PORT"+ , "GOOGLE_CLOUD_PROJECT"+ , "GCLOUD_PROJECT"+ , "GCP_PROJECT"+ , "K_SERVICE"+ , "FUNCTION_TARGET"+ , "GAE_SERVICE"+ , "GAE_ENV"+ , "GOOGLE_CLOUD_REGION"+ , "FUNCTION_REGION"+ , "WEBSITE_SITE_NAME"+ , "FUNCTIONS_WORKER_RUNTIME"+ , "CONTAINER_APP_NAME"+ , "AZURE_FUNCTIONS_ENVIRONMENT"+ , "REGION_NAME"+ , "AZURE_SUBSCRIPTION_ID"+ ]+++faasEnvVars :: [String]+faasEnvVars =+ [ "AWS_LAMBDA_FUNCTION_NAME"+ , "AWS_LAMBDA_FUNCTION_VERSION"+ , "AWS_LAMBDA_LOG_STREAM_NAME"+ , "AWS_LAMBDA_FUNCTION_MEMORY_SIZE"+ , "AWS_REGION"+ , "AWS_ACCOUNT_ID"+ , "FUNCTION_TARGET"+ , "K_REVISION"+ , "FUNCTION_MEMORY_MB"+ , "FUNCTIONS_WORKER_RUNTIME"+ , "WEBSITE_SITE_NAME"+ ]+++herokuEnvVars :: [String]+herokuEnvVars =+ [ "HEROKU_APP_ID"+ , "HEROKU_APP_NAME"+ , "HEROKU_DYNO_ID"+ , "HEROKU_RELEASE_VERSION"+ , "HEROKU_SLUG_COMMIT"+ , "HEROKU_RELEASE_CREATED_AT"+ ]+++-- Internal module re-exports for testing. These are tested via+-- the public API (detectGCPCompute), but the pure parsing functions+-- are worth testing directly since we can't call real metadata servers.++gcpExtractLastSegment :: T.Text -> T.Text+gcpExtractLastSegment t = case T.splitOn "/" t of+ [] -> t+ parts -> last parts+++gcpExtractRegionFromZone :: T.Text -> Maybe T.Text+gcpExtractRegionFromZone az =+ let parts = T.splitOn "-" az+ in if length parts >= 3+ then Just $ T.intercalate "-" (take (length parts - 1) parts)+ else Nothing+++ecsNormalizeArn :: T.Text -> [T.Text] -> T.Text -> T.Text+ecsNormalizeArn val arnParts suffix+ | "arn:" `T.isPrefixOf` val = val+ | length arnParts >= 5 =+ let base = T.intercalate ":" (take 5 arnParts)+ in base <> ":" <> suffix <> "/" <> val+ | otherwise = val+++gcpParsingSpec :: Spec+gcpParsingSpec = describe "GCP metadata parsing" $ do+ -- Implementation-specific: pure helpers for GCP metadata path parsing+ describe "extractLastSegment" $ do+ it "extracts zone from full path" $ do+ gcpExtractLastSegment "projects/123456/zones/us-central1-a"+ `shouldBe` "us-central1-a"++ it "extracts machine type from full path" $ do+ gcpExtractLastSegment "projects/123456/machineTypes/n2-standard-4"+ `shouldBe` "n2-standard-4"++ it "returns input unchanged when no slashes" $ do+ gcpExtractLastSegment "us-central1-a"+ `shouldBe` "us-central1-a"++ describe "extractRegionFromZone" $ do+ it "extracts region from standard zone" $ do+ gcpExtractRegionFromZone "us-central1-a" `shouldBe` Just "us-central1"++ it "extracts region from two-part region" $ do+ gcpExtractRegionFromZone "europe-west1-b" `shouldBe` Just "europe-west1"++ it "handles zones with more dashes" $ do+ gcpExtractRegionFromZone "asia-southeast1-c" `shouldBe` Just "asia-southeast1"++ it "returns Nothing for invalid zone format" $ do+ gcpExtractRegionFromZone "invalid" `shouldBe` Nothing++ it "returns Nothing for single dash" $ do+ gcpExtractRegionFromZone "us-central1" `shouldBe` Nothing+++ecsArnSpec :: Spec+ecsArnSpec = describe "ECS ARN normalization" $ do+ -- Implementation-specific: ECS ARN string normalization for resource attributes+ it "passes through a full ARN unchanged" $ do+ let arn = "arn:aws:ecs:us-east-1:123456789:cluster/my-cluster"+ ecsNormalizeArn arn [] "cluster" `shouldBe` arn++ it "constructs ARN from short name and task ARN parts" $ do+ let taskArnParts = T.splitOn ":" "arn:aws:ecs:us-east-1:123456789:task/my-task-id"+ ecsNormalizeArn "my-cluster" taskArnParts "cluster"+ `shouldBe` "arn:aws:ecs:us-east-1:123456789:cluster/my-cluster"++ it "returns the value as-is if ARN parts are insufficient" $ do+ ecsNormalizeArn "my-cluster" ["arn", "aws"] "cluster"+ `shouldBe` "my-cluster"++ it "extracts region from task ARN" $ do+ let arnParts = T.splitOn ":" "arn:aws:ecs:eu-west-1:987654321:task/task-id"+ case arnParts of+ [_, _, _, region, _, _] -> region `shouldBe` "eu-west-1"+ _ -> expectationFailure "ARN should have 6 parts"++ it "extracts account ID from task ARN" $ do+ let arnParts = T.splitOn ":" "arn:aws:ecs:us-west-2:111222333:task/task-id"+ case arnParts of+ [_, _, _, _, acctId, _] -> acctId `shouldBe` "111222333"+ _ -> expectationFailure "ARN should have 6 parts"+++registrySpec :: Spec+registrySpec = describe "Resource Detector Registry" $ do+ -- Resource SDK: OTEL_RESOURCE_DETECTORS and detector registration+ -- https://opentelemetry.io/docs/specs/otel/resource/sdk/#detecting-resource-information-from-the-environment+ around_ withCleanDetectorEnv $ do+ it "registerBuiltinResourceDetectors populates the registry" $ do+ registerBuiltinResourceDetectors+ detectors <- registeredResourceDetectors+ let names = H.keys detectors+ names `shouldSatisfy` elem "service"+ names `shouldSatisfy` elem "host"+ names `shouldSatisfy` elem "aws_ec2"+ names `shouldSatisfy` elem "aws_ecs"+ names `shouldSatisfy` elem "aws_eks"+ names `shouldSatisfy` elem "gcp"+ names `shouldSatisfy` elem "azure_vm"+ names `shouldSatisfy` elem "heroku"++ it "custom detectors can be registered" $ do+ let myDetector = pure $ mkResource ["custom.key" .= ("val" :: T.Text)]+ registerResourceDetector "custom" myDetector+ detectors <- registeredResourceDetectors+ H.keys detectors `shouldSatisfy` elem "custom"++ it "OTEL_RESOURCE_DETECTORS filters active detectors" $ do+ setEnv "OTEL_RESOURCE_DETECTORS" "service,os"+ _ <- detectBuiltInResources+ pure () :: IO ()++ it "OTEL_RESOURCE_DETECTORS=all runs all detectors" $ do+ setEnv "OTEL_RESOURCE_DETECTORS" "all"+ _ <- detectBuiltInResources+ pure () :: IO ()++ it "a failing detector does not crash detection of other detectors" $ do+ let failingDetector = throwIO (userError "detector explosion") :: IO Resource+ goodDetector = pure $ mkResource ["good.key" .= ("found" :: T.Text)]+ registerResourceDetector "failing_test" failingDetector+ registerResourceDetector "good_test" goodDetector+ setEnv "OTEL_RESOURCE_DETECTORS" "failing_test,good_test"+ rs <- detectBuiltInResources+ let materialized = materializeResources rs+ attrs = getMaterializedResourcesAttributes materialized+ lookupAttribute attrs "good.key" `shouldBe` Just (toAttribute ("found" :: T.Text))+ unsetEnv "OTEL_RESOURCE_DETECTORS"+++withCleanDetectorEnv :: IO () -> IO ()+withCleanDetectorEnv action = do+ saved <- mapM saveEnv detectorEnvVars+ mapM_ safeUnsetEnv detectorEnvVars+ action+ mapM_ (uncurry restoreEnv) (zip detectorEnvVars saved)+++withCleanEksEnv :: IO () -> IO ()+withCleanEksEnv action = do+ saved <- mapM saveEnv eksEnvVars+ mapM_ safeUnsetEnv eksEnvVars+ action+ mapM_ (uncurry restoreEnv) (zip eksEnvVars saved)+++eksEnvVars :: [String]+eksEnvVars =+ [ "KUBERNETES_SERVICE_HOST"+ , "KUBERNETES_SERVICE_PORT"+ , "ECS_CONTAINER_METADATA_URI_V4"+ , "AWS_LAMBDA_FUNCTION_NAME"+ ]+++detectorEnvVars :: [String]+detectorEnvVars =+ cloudEnvVars ++ ["OTEL_RESOURCE_DETECTORS"]
test/OpenTelemetry/ResourceSpec.hs view
@@ -1,12 +1,75 @@+{-# LANGUAGE OverloadedStrings #-}+ module OpenTelemetry.ResourceSpec where +import qualified Data.HashMap.Strict as HM+import Data.Maybe (isJust)+import Data.Text (Text)+import OpenTelemetry.Attributes (getAttributeMap, lookupAttribute, toAttribute)+import OpenTelemetry.Resource+import OpenTelemetry.Trace (TracerProviderOptions (..), getTracerProviderInitializationOptions') import Test.Hspec spec :: Spec spec = describe "Resource" $ do- specify "Create from Attributes" pending- specify "Create empty" pending- specify "Merge (v2)" pending- specify "Retrieve attributes" pending- specify "Default value for service.name" pending+ -- Resource SDK §Create: Resource from attributes+ -- https://opentelemetry.io/docs/specs/otel/resource/sdk/#create+ specify "Create from Attributes" $ do+ let r :: Resource+ r =+ mkResource+ [ "app.id" .= ("my-app" :: Text)+ , "app.version" .= (2 :: Int)+ ]+ mat = materializeResources r+ attrs = getMaterializedResourcesAttributes mat+ lookupAttribute attrs "app.id" `shouldBe` Just (toAttribute ("my-app" :: Text))+ lookupAttribute attrs "app.version" `shouldBe` Just (toAttribute (2 :: Int))+ HM.lookup "app.id" (getAttributeMap attrs) `shouldBe` lookupAttribute attrs "app.id"++ -- Resource SDK §Create: empty Resource+ -- https://opentelemetry.io/docs/specs/otel/resource/sdk/#create+ specify "Create empty" $ do+ let mat = materializeResources (mempty :: Resource)+ attrs = getMaterializedResourcesAttributes mat+ HM.null (getAttributeMap attrs) `shouldBe` True++ -- Resource SDK §Merge: older Resource wins on key collision+ -- https://opentelemetry.io/docs/specs/otel/resource/sdk/#merge+ specify "Merge (v2)" $ do+ let left :: Resource+ left =+ mkResource+ [ "shared" .= ("from-left" :: Text)+ , "only-left" .= (1 :: Int)+ ]+ right :: Resource+ right =+ mkResource+ [ "shared" .= ("from-right" :: Text)+ , "only-right" .= (2 :: Int)+ ]+ merged = left <> right+ mat = materializeResources merged+ attrs = getMaterializedResourcesAttributes mat+ lookupAttribute attrs "shared" `shouldBe` Just (toAttribute ("from-left" :: Text))+ lookupAttribute attrs "only-left" `shouldBe` Just (toAttribute (1 :: Int))+ lookupAttribute attrs "only-right" `shouldBe` Just (toAttribute (2 :: Int))++ -- Resource SDK §Resource operations: immutable attribute set+ -- https://opentelemetry.io/docs/specs/otel/resource/sdk/#resource-operations+ specify "Retrieve attributes" $ do+ let r :: Resource+ r = mkResource ["k.str" .= ("v" :: Text), "k.int" .= (99 :: Int)]+ mat = materializeResources r+ attrs = getMaterializedResourcesAttributes mat+ lookupAttribute attrs "k.str" `shouldBe` Just (toAttribute ("v" :: Text))+ HM.size (getAttributeMap attrs) `shouldBe` 2++ -- Resource semantic convention: service.name (SDK defaulting via env/config)+ -- https://opentelemetry.io/docs/specs/otel/resource/sdk/#detecting-resource-information-from-the-environment+ specify "Default value for service.name" $ do+ (_processors, opts) <- getTracerProviderInitializationOptions' mempty+ let attrs = getMaterializedResourcesAttributes (tracerProviderOptionsResources opts)+ isJust (lookupAttribute attrs "service.name") `shouldBe` True
+ test/OpenTelemetry/Trace/CallStackSpec.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module OpenTelemetry.Trace.CallStackSpec (spec) where++import Control.Monad (void)+import qualified Data.HashMap.Strict as HM+import Data.IORef+import Data.Maybe (isJust)+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Stack (HasCallStack, withFrozenCallStack)+import OpenTelemetry.Attributes (Attribute (..), Attributes, PrimitiveAttribute (..), lookupAttribute, toAttribute)+import OpenTelemetry.Attributes.Key (unkey)+import qualified OpenTelemetry.Context as Context+import OpenTelemetry.Exporter.InMemory.Span (inMemoryListExporter)+import qualified OpenTelemetry.SemanticConventions as SC+import OpenTelemetry.Trace.Core+import Test.Hspec+++withTestTracer :: (Tracer -> IORef [ImmutableSpan] -> IO ()) -> IO ()+withTestTracer action = do+ (processor, ref) <- inMemoryListExporter+ tp <- createTracerProvider [processor] emptyTracerProviderOptions+ let t = makeTracer tp "callstack-test" tracerOptions+ action t ref+ void $ forceFlushTracerProvider tp Nothing+ void $ shutdownTracerProvider tp Nothing+++getLatestExportedSpan :: IORef [ImmutableSpan] -> IO ImmutableSpan+getLatestExportedSpan ref = do+ spans <- readIORef ref+ case spans of+ [] -> fail "expected at least one exported span"+ (sp : _) -> pure sp+++readExportedHotAttributes :: IORef [ImmutableSpan] -> IO Attributes+readExportedHotAttributes ref = do+ sp <- getLatestExportedSpan ref+ hot <- readIORef (spanHot sp)+ pure (hotAttributes hot)+++textFromAttribute :: Attribute -> Maybe Text+textFromAttribute (AttributeValue (TextAttribute x)) = Just x+textFromAttribute _ = Nothing+++thisModule :: Text+thisModule = "OpenTelemetry.Trace.CallStackSpec"+++shouldHaveCallerCodeAttrs :: Attributes -> Text -> Expectation+shouldHaveCallerCodeAttrs attrs expectedFn = do+ lookupAttribute attrs (unkey SC.code_function) `shouldBe` Just (toAttribute expectedFn)+ lookupAttribute attrs (unkey SC.code_namespace) `shouldBe` Just (toAttribute thisModule)+ lookupAttribute attrs (unkey SC.code_lineno) `shouldSatisfy` isJust+ case lookupAttribute attrs (unkey SC.code_filepath) >>= textFromAttribute of+ Nothing -> expectationFailure "expected code.filepath as text attribute"+ Just fp -> do+ fp `shouldSatisfy` ("CallStackSpec" `T.isInfixOf`)+ fp `shouldNotSatisfy` ("OpenTelemetry/Trace/Core.hs" `T.isInfixOf`)+ fp `shouldNotSatisfy` ("OpenTelemetry\\Trace\\Core.hs" `T.isInfixOf`)+++shouldHaveNoCodeLocationAttrs :: Attributes -> Expectation+shouldHaveNoCodeLocationAttrs attrs = do+ lookupAttribute attrs (unkey SC.code_filepath) `shouldBe` Nothing+ lookupAttribute attrs (unkey SC.code_lineno) `shouldBe` Nothing+ lookupAttribute attrs (unkey SC.code_namespace) `shouldBe` Nothing+ lookupAttribute attrs (unkey SC.code_function) `shouldBe` Nothing+++spec :: Spec+spec = describe "CallStack / source location capture" $ do+ -- Semantic conventions: source code attributes (code.function, code.namespace, …)+ -- https://opentelemetry.io/docs/specs/semconv/general/attributes/#source-code-attributes+ it "inSpan captures caller source location" $+ withTestTracer $ \t ref -> do+ namedInSpan t+ attrs <- readExportedHotAttributes ref+ shouldHaveCallerCodeAttrs attrs "namedInSpan"++ -- Semantic conventions: source code attributes+ -- https://opentelemetry.io/docs/specs/semconv/general/attributes/#source-code-attributes+ it "inSpan' captures caller source location" $+ withTestTracer $ \t ref -> do+ namedInSpan' t+ attrs <- readExportedHotAttributes ref+ shouldHaveCallerCodeAttrs attrs "namedInSpan'"++ -- Implementation-specific: inSpan'' omits automatic caller code attributes+ it "inSpan'' does NOT add source location attributes" $+ withTestTracer $ \t ref -> do+ namedInSpan'' t+ attrs <- readExportedHotAttributes ref+ shouldHaveNoCodeLocationAttrs attrs++ -- Semantic conventions: source code attributes on span creation+ -- https://opentelemetry.io/docs/specs/semconv/general/attributes/#source-code-attributes+ it "createSpan captures source location" $+ withTestTracer $ \t ref -> do+ namedCreateSpan t+ attrs <- readExportedHotAttributes ref+ lookupAttribute attrs (unkey SC.code_function) `shouldBe` Just (toAttribute @Text "namedCreateSpan")+ lookupAttribute attrs (unkey SC.code_namespace) `shouldBe` Just (toAttribute thisModule)+ lookupAttribute attrs (unkey SC.code_lineno) `shouldSatisfy` isJust+ case lookupAttribute attrs (unkey SC.code_filepath) >>= textFromAttribute of+ Nothing -> expectationFailure "expected code.filepath"+ Just fp -> fp `shouldSatisfy` ("CallStackSpec" `T.isInfixOf`)++ -- Implementation-specific: explicit API without CallStack-based code attributes+ it "createSpanWithoutCallStack does NOT add source location attributes" $+ withTestTracer $ \t ref -> do+ namedCreateSpanWithoutCallStack t+ attrs <- readExportedHotAttributes ref+ shouldHaveNoCodeLocationAttrs attrs++ -- Semantic conventions: user-supplied code.* must not be overwritten+ -- https://opentelemetry.io/docs/specs/semconv/general/attributes/#source-code-attributes+ it "user-provided code.function in SpanArguments is preserved by inSpan" $+ withTestTracer $ \t ref -> do+ inSpanWithUserCodeFunction t+ attrs <- readExportedHotAttributes ref+ lookupAttribute attrs (unkey SC.code_function)+ `shouldBe` Just (toAttribute @Text "user-chosen-function")++ -- Implementation-specific: filepath must reflect user module, not SDK internals+ it "source location points to test module, not OpenTelemetry.Trace.Core" $+ withTestTracer $ \t ref -> do+ namedInSpanForLibraryPathCheck t+ attrs <- readExportedHotAttributes ref+ case lookupAttribute attrs (unkey SC.code_filepath) >>= textFromAttribute of+ Nothing -> expectationFailure "expected code.filepath"+ Just fp -> do+ fp `shouldSatisfy` ("CallStackSpec" `T.isInfixOf`)+ fp `shouldNotSatisfy` ("Trace/Core.hs" `T.isInfixOf`)++ -- Implementation-specific: frozen CallStack disables automatic code.* injection+ it "withFrozenCallStack: createSpan adds no code location attributes" $+ withTestTracer $ \t ref -> do+ -- Same idea as @g@ in "TraceSpec": frozen stack makes 'callerAttributes' return+ -- 'mempty'. ('inSpan' uses 'callerCodeAttrs', which can still attach 'srcLoc' for a+ -- one-frame stack, so we test @createSpan@ here for truly empty @code.*@.)+ createSpanUnderFrozenCallStack t+ attrs <- readExportedHotAttributes ref+ shouldHaveNoCodeLocationAttrs attrs+++{- | Each helper needs @HasCallStack@ so the implicit stack passed into+@inSpan@ / @createSpan@ includes this module\'s caller frame; otherwise+@callerCodeAttrs@ / @callerAttributes@ only see one frame and set+@code.function@ to @\"<unknown>\"@.+-}+namedInSpan :: HasCallStack => Tracer -> IO ()+namedInSpan t = inSpan t "named-inspan" defaultSpanArguments (pure ())+{-# NOINLINE namedInSpan #-}+++namedInSpan' :: HasCallStack => Tracer -> IO ()+namedInSpan' t = inSpan' t "named-inspan-prime" defaultSpanArguments $ const (pure ())+{-# NOINLINE namedInSpan' #-}+++namedInSpan'' :: HasCallStack => Tracer -> IO ()+namedInSpan'' t = inSpan'' t "named-inspan-prime-prime" defaultSpanArguments $ const (pure ())+{-# NOINLINE namedInSpan'' #-}+++namedCreateSpan :: HasCallStack => Tracer -> IO ()+namedCreateSpan t = do+ s <- createSpan t Context.empty "named-create" defaultSpanArguments+ endSpan s Nothing+{-# NOINLINE namedCreateSpan #-}+++namedCreateSpanWithoutCallStack :: Tracer -> IO ()+namedCreateSpanWithoutCallStack t = do+ s <- createSpanWithoutCallStack t Context.empty "named-create-nocs" defaultSpanArguments+ endSpan s Nothing+{-# NOINLINE namedCreateSpanWithoutCallStack #-}+++inSpanWithUserCodeFunction :: HasCallStack => Tracer -> IO ()+inSpanWithUserCodeFunction t =+ inSpan+ t+ "user-code-fn-span"+ defaultSpanArguments {attributes = HM.singleton (unkey SC.code_function) (toAttribute @Text "user-chosen-function")}+ (pure ())+{-# NOINLINE inSpanWithUserCodeFunction #-}+++namedInSpanForLibraryPathCheck :: HasCallStack => Tracer -> IO ()+namedInSpanForLibraryPathCheck t = inSpan t "library-path-check" defaultSpanArguments (pure ())+{-# NOINLINE namedInSpanForLibraryPathCheck #-}+++createSpanUnderFrozenCallStack :: HasCallStack => Tracer -> IO ()+createSpanUnderFrozenCallStack t =+ withFrozenCallStack $ do+ s <- createSpan t Context.empty "frozen-create" defaultSpanArguments+ endSpan s Nothing+{-# NOINLINE createSpanUnderFrozenCallStack #-}
test/OpenTelemetry/TraceSpec.hs view
@@ -1,20 +1,35 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} module OpenTelemetry.TraceSpec where +import Control.Exception (IOException) import Control.Monad+import Data.Foldable (traverse_)+import qualified Data.HashMap.Strict as HM import Data.IORef import Data.Int+import Data.List (nub)+import Data.Maybe (isJust) import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Vector as V+import GHC.Stack (withFrozenCallStack)+import OpenTelemetry.Attributes (AttributeLimits (..), Attributes, defaultAttributeLimits, getCount, lookupAttribute) import qualified OpenTelemetry.Context as Context+import OpenTelemetry.Exporter.InMemory.Span (inMemoryListExporter)+import OpenTelemetry.Processor.Span (SpanProcessor (..))+import OpenTelemetry.Resource import OpenTelemetry.Trace import OpenTelemetry.Trace.Core import OpenTelemetry.Trace.Id-import OpenTelemetry.Trace.Id.Generator import OpenTelemetry.Trace.Id.Generator.Default+import OpenTelemetry.Trace.Sampler import qualified OpenTelemetry.Trace.TraceState as TraceState-import System.Clock+import OpenTelemetry.Util (appendOnlyBoundedCollectionValues) import Test.Hspec @@ -22,22 +37,106 @@ asIO = id +immutableSpanStatus :: ImmutableSpan -> IO SpanStatus+immutableSpanStatus imm = hotStatus <$> readIORef (spanHot imm)+++immutableSpanAttributes :: ImmutableSpan -> IO Attributes+immutableSpanAttributes imm = hotAttributes <$> readIORef (spanHot imm)+++immutableSpanEvents :: ImmutableSpan -> IO (V.Vector Event)+immutableSpanEvents imm = do+ hot <- readIORef (spanHot imm)+ pure $ appendOnlyBoundedCollectionValues (hotEvents hot)+++immutableSpanLinks :: ImmutableSpan -> IO (V.Vector Link)+immutableSpanLinks imm = do+ hot <- readIORef (spanHot imm)+ pure $ appendOnlyBoundedCollectionValues (hotLinks hot)+++pattern HostName :: Text+pattern HostName = "host.name"+++pattern TelemetrySdkLanguage :: Text+pattern TelemetrySdkLanguage = "telemetry.sdk.language"+++pattern ExampleName :: Text+pattern ExampleName = "example.name"+++pattern ExampleCount :: Text+pattern ExampleCount = "example.count"++ spec :: Spec spec = describe "Trace" $ do describe "TracerProvider" $ do specify "Create TracerProvider" $ do void (createTracerProvider [] (emptyTracerProviderOptions :: TracerProviderOptions) :: IO TracerProvider)- -- TODO make these tests do something meaningful with makeTracer- -- specify "Get a Tracer" $ asIO $ do- -- p <- getGlobalTracerProvider- -- void $ getTracer p "woo" tracerOptions- -- specify "Get a Tracer with schema_url" $ asIO $ do- -- p <- getGlobalTracerProvider- -- void $ getTracer p "woo" (tracerOptions { tracerSchema = Just "https://woo.com" })- specify "Safe for concurrent calls" pending- specify "Shutdown" pending- specify "ForceFlush" pending + specify "Shutdown" $ do+ (processor, ref) <- inMemoryListExporter+ tp <- createTracerProvider [processor] emptyTracerProviderOptions {tracerProviderOptionsIdGenerator = defaultIdGenerator}+ let tracer = makeTracer tp "test" tracerOptions+ s <- createSpan tracer Context.empty "shutdown_test" defaultSpanArguments+ endSpan s Nothing+ result <- shutdownTracerProvider tp Nothing+ result `shouldBe` ShutdownSuccess+ spans <- readIORef ref+ length spans `shouldBe` 1+ -- After shutdown, createSpan should return a Dropped span+ s2 <- createSpan tracer Context.empty "after_shutdown" defaultSpanArguments+ recording <- isRecording s2+ recording `shouldBe` False++ specify "ForceFlush" $ do+ (processor, ref) <- inMemoryListExporter+ tp <- createTracerProvider [processor] emptyTracerProviderOptions {tracerProviderOptionsIdGenerator = defaultIdGenerator}+ let tracer = makeTracer tp "test" tracerOptions+ s <- createSpan tracer Context.empty "flush_test" defaultSpanArguments+ endSpan s Nothing+ result <- forceFlushTracerProvider tp Nothing+ result `shouldBe` FlushSuccess+ spans <- readIORef ref+ length spans `shouldBe` 1++ specify "Resource initialization prioritizes user override, then OTEL_RESOURCE_ATTRIBUTES env var" $ do+ let getInitialResourceAttrs :: Resource -> IO Attributes+ getInitialResourceAttrs resource = do+ opts <- snd <$> getTracerProviderInitializationOptions' resource+ pure . getMaterializedResourcesAttributes $ tracerProviderOptionsResources opts+ shouldHaveAttrPair :: Attributes -> (Text, Attribute) -> Expectation+ shouldHaveAttrPair attrs (k, v) = lookupAttribute attrs k `shouldBe` Just v+ attrsFromEnv <- getInitialResourceAttrs mempty+ traverse_+ (attrsFromEnv `shouldHaveAttrPair`)+ [ (HostName, toAttribute @Text "env_host_name")+ , (TelemetrySdkLanguage, toAttribute @Text "haskell")+ , (ExampleName, toAttribute @Text "env_example_name")+ , -- OTEL_RESOURCE_ATTRIBUTES uses Baggage format, where attribute values are always text+ (ExampleCount, toAttribute @Text "42")+ ]+ attrsFromUser <-+ getInitialResourceAttrs $+ mkResource+ [ HostName .= toAttribute @Text "user_host_name"+ , TelemetrySdkLanguage .= toAttribute @Text "GHC2021"+ , ExampleCount .= toAttribute @Int 11+ ]+ traverse_+ (attrsFromUser `shouldHaveAttrPair`)+ [ (HostName, toAttribute @Text "user_host_name")+ , (TelemetrySdkLanguage, toAttribute @Text "GHC2021")+ , -- No user override for "example.name", so the value from OTEL_RESOURCES_ATTRIBUTES shines through+ (ExampleName, toAttribute @Text "env_example_name")+ , (ExampleCount, toAttribute @Int 11)+ ]+ describe "Trace / Context interaction" $ do specify "Set active span, Get active span" $ do p <- getGlobalTracerProvider@@ -54,9 +153,7 @@ p <- getGlobalTracerProvider let t = makeTracer p "woo" tracerOptions void $ createSpan t Context.empty "create_root_span" defaultSpanArguments- specify "Get active new span" pending- specify "Mark Span active" pending- specify "Safe for concurrent calls" pending+ describe "SpanContext" $ do specify "IsValid" $ do t <- newTraceId defaultIdGenerator@@ -75,23 +172,107 @@ } validSpan `shouldSatisfy` isValid (validSpan {spanId = badSpan, traceId = badTrace}) `shouldSatisfy` (not . isValid)- specify "IsRemote" pending- specify "Conforms to the W3C TraceContext spec" pending+ -- Spec: BOTH TraceId AND SpanId must be non-zero+ (validSpan {spanId = badSpan}) `shouldSatisfy` (not . isValid)+ (validSpan {traceId = badTrace}) `shouldSatisfy` (not . isValid)++ specify "IsRemote" $ do+ let (Right sid) = bytesToSpanId "\1\0\0\0\0\0\0\1"+ (Right tid) = bytesToTraceId "\1\0\0\0\0\0\0\0\0\0\0\0\0\0\0\1"+ sc =+ SpanContext+ { traceFlags = defaultTraceFlags+ , isRemote = True+ , traceState = TraceState.empty+ , spanId = sid+ , traceId = tid+ }+ OpenTelemetry.Trace.Core.isRemote sc `shouldBe` True+ OpenTelemetry.Trace.Core.isRemote (sc {isRemote = False}) `shouldBe` False+ describe "Span" $ do specify "Create root span" $ asIO $ do p <- getGlobalTracerProvider let t = makeTracer p "woo" tracerOptions void $ createSpan t Context.empty "create_root_span" defaultSpanArguments- specify "Create with default parent (active span)" pending- specify "Create with parent from Context" pending- -- specify "No explict parent from Span/SpanContext allowed" pending- specify "Processor.OnStart receives parent Context" pending++ specify "Create with default parent (active span)" $ do+ (processor, _ref) <- inMemoryListExporter+ tp <- createTracerProvider [processor] emptyTracerProviderOptions {tracerProviderOptionsIdGenerator = defaultIdGenerator}+ let tracer = makeTracer tp "test" tracerOptions+ parentSpan <- createSpan tracer Context.empty "parent" defaultSpanArguments+ let ctxt = Context.insertSpan parentSpan Context.empty+ childSpan <- createSpan tracer ctxt "child" defaultSpanArguments+ parentImm <- unsafeReadSpan parentSpan+ childImm <- unsafeReadSpan childSpan+ -- Child's parent should be present and match the parent span's context+ case spanParent childImm of+ Nothing -> expectationFailure "Child span should have a parent"+ Just p -> do+ parentSc <- getSpanContext p+ parentSc `shouldBe` spanContext parentImm++ specify "Create with parent from Context" $ do+ (processor, _ref) <- inMemoryListExporter+ tp <- createTracerProvider [processor] emptyTracerProviderOptions {tracerProviderOptionsIdGenerator = defaultIdGenerator}+ let tracer = makeTracer tp "test" tracerOptions+ parentSpan <- createSpan tracer Context.empty "parent" defaultSpanArguments+ let ctxtWithParent = Context.insertSpan parentSpan Context.empty+ childSpan <- createSpan tracer ctxtWithParent "child" defaultSpanArguments+ parentImm <- unsafeReadSpan parentSpan+ childImm <- unsafeReadSpan childSpan+ -- The child should share the parent's trace ID+ traceId (spanContext childImm) `shouldBe` traceId (spanContext parentImm)+ -- The child's parent span ID should be the parent's span ID+ case spanParent childImm of+ Nothing -> expectationFailure "Child span should have a parent"+ Just p -> do+ pSc <- getSpanContext p+ spanId pSc `shouldBe` spanId (spanContext parentImm)++ specify "Processor.OnStart receives parent Context" $ do+ ctxRef <- newIORef (Nothing :: Maybe Context.Context)+ let testProcessor =+ SpanProcessor+ { spanProcessorOnStart = \_imm ctx -> writeIORef ctxRef (Just ctx)+ , spanProcessorOnEnd = \_ -> pure ()+ , spanProcessorShutdown = pure ShutdownSuccess+ , spanProcessorForceFlush = pure FlushSuccess+ }+ tp <- createTracerProvider [testProcessor] emptyTracerProviderOptions {tracerProviderOptionsIdGenerator = defaultIdGenerator}+ let tracer = makeTracer tp "test" tracerOptions+ parentSpan <- createSpan tracer Context.empty "parent" defaultSpanArguments+ let ctxt = Context.insertSpan parentSpan Context.empty+ -- Reset the ref so we only see what the child's OnStart gets+ writeIORef ctxRef Nothing+ _childSpan <- createSpan tracer ctxt "child" defaultSpanArguments+ receivedCtx <- readIORef ctxRef+ case receivedCtx of+ Nothing -> expectationFailure "OnStart should receive context"+ Just ctx -> do+ let parentInCtx = Context.lookupSpan ctx+ case parentInCtx of+ Nothing -> expectationFailure "Context passed to OnStart should contain parent span"+ Just p -> do+ pSc <- getSpanContext p+ parentSc <- getSpanContext parentSpan+ pSc `shouldBe` parentSc+ specify "UpdateName" $ asIO $ do p <- getGlobalTracerProvider let t = makeTracer p "woo" tracerOptions s <- createSpan t Context.empty "create_root_span" defaultSpanArguments updateName s "renamed_span"- specify "User-defined start timestamp" pending++ specify "User-defined start timestamp" $ do+ (processor, _ref) <- inMemoryListExporter+ tp <- createTracerProvider [processor] emptyTracerProviderOptions {tracerProviderOptionsIdGenerator = defaultIdGenerator}+ let tracer = makeTracer tp "test" tracerOptions+ userTs <- getTimestamp+ s <- createSpan tracer Context.empty "ts_test" defaultSpanArguments {startTime = Just userTs}+ imm <- unsafeReadSpan s+ spanStart imm `shouldBe` userTs+ specify "End" $ asIO $ do p <- getGlobalTracerProvider let t = makeTracer p "woo" tracerOptions@@ -106,7 +287,6 @@ specify "IsRecording" $ asIO $ do p <- getGlobalTracerProvider let t = makeTracer p "woo" tracerOptions- ts <- getTime Realtime s <- createSpan t Context.empty "create_root_span" defaultSpanArguments recording <- isRecording s recording `shouldBe` True@@ -114,7 +294,6 @@ specify "IsRecording becomes false after End" $ do p <- getGlobalTracerProvider let t = makeTracer p "woo" tracerOptions- ts <- getTime Realtime s <- createSpan t Context.empty "create_root_span" defaultSpanArguments endSpan s Nothing recording <- isRecording s@@ -123,27 +302,96 @@ specify "Set status with StatusCode (Unset, Ok, Error)" $ do p <- getGlobalTracerProvider let t = makeTracer p "woo" tracerOptions- ts <- getTime Realtime s <- createSpan t Context.empty "create_root_span" defaultSpanArguments setStatus s $ Error "woo" do i <- unsafeReadSpan s- spanStatus i `shouldBe` Error "woo"+ immutableSpanStatus i `shouldReturn` Error "woo" setStatus s $ Ok do i <- unsafeReadSpan s- spanStatus i `shouldBe` Ok+ immutableSpanStatus i `shouldReturn` Ok setStatus s $ Error "woo" do i <- unsafeReadSpan s- spanStatus i `shouldBe` Ok+ immutableSpanStatus i `shouldReturn` Ok - specify "Safe for concurrent calls" pending- specify "events collection size limit" pending- specify "attribute collection size limit" pending- specify "links collection size limit" pending+ specify "events collection size limit" $ do+ (processor, _ref) <- inMemoryListExporter+ let limits = defaultSpanLimits {eventCountLimit = Just 3}+ tp <-+ createTracerProvider+ [processor]+ emptyTracerProviderOptions+ { tracerProviderOptionsIdGenerator = defaultIdGenerator+ , tracerProviderOptionsSpanLimits = limits+ }+ let tracer = makeTracer tp "test" tracerOptions+ s <- createSpan tracer Context.empty "limit_test" defaultSpanArguments+ -- Add 5 events but limit is 3+ forM_ [1 .. 5 :: Int] $ \i ->+ addEvent s $+ NewEvent+ { newEventName = Text.pack ("event_" <> show i)+ , newEventAttributes = HM.empty+ , newEventTimestamp = Nothing+ }+ imm <- unsafeReadSpan s+ evts <- immutableSpanEvents imm+ V.length evts `shouldBe` 3 + specify "attribute collection size limit" $ do+ (processor, _ref) <- inMemoryListExporter+ let limits = defaultSpanLimits {spanAttributeCountLimit = Just 5}+ tp <-+ createTracerProvider+ [processor]+ emptyTracerProviderOptions+ { tracerProviderOptionsIdGenerator = defaultIdGenerator+ , tracerProviderOptionsSpanLimits = limits+ , tracerProviderOptionsAttributeLimits = defaultAttributeLimits {attributeCountLimit = Just 5}+ }+ let tracer = makeTracer tp "test" tracerOptions+ s <- createSpan tracer Context.empty "limit_test" defaultSpanArguments+ -- Add many more attributes than the limit allows+ forM_ [1 .. 20 :: Int] $ \i ->+ addAttribute s (Text.pack ("attr_" <> show i)) (toAttribute i)+ imm <- unsafeReadSpan s+ attrs <- immutableSpanAttributes imm+ -- Total attribute count (including thread.id and any auto-added attrs)+ -- should not exceed the configured limit of 5+ getCount attrs `shouldSatisfy` (<= 5)++ specify "links collection size limit" $ do+ (processor, _ref) <- inMemoryListExporter+ let limits = defaultSpanLimits {linkCountLimit = Just 2}+ tp <-+ createTracerProvider+ [processor]+ emptyTracerProviderOptions+ { tracerProviderOptionsIdGenerator = defaultIdGenerator+ , tracerProviderOptionsSpanLimits = limits+ }+ let tracer = makeTracer tp "test" tracerOptions+ s <- createSpan tracer Context.empty "limit_test" defaultSpanArguments+ let (Right sid) = bytesToSpanId "\1\2\3\4\5\6\7\8"+ (Right tid) = bytesToTraceId "\1\2\3\4\5\6\7\8\9\10\11\12\13\14\15\16"+ linkSc =+ SpanContext+ { traceFlags = defaultTraceFlags+ , isRemote = False+ , traceState = TraceState.empty+ , spanId = sid+ , traceId = tid+ }+ -- Add 5 links but limit is 2+ forM_ [1 .. 5 :: Int] $ \_ ->+ addLink s $ NewLink {linkContext = linkSc, linkAttributes = HM.empty}+ imm <- unsafeReadSpan s+ lnks <- immutableSpanLinks imm+ V.length lnks `shouldBe` 2+ describe "Span attributes" $ do specify "SetAttribute" $ asIO $ do p <- getGlobalTracerProvider@@ -151,7 +399,6 @@ s <- createSpan t Context.empty "create_root_span" defaultSpanArguments addAttribute s "attr" (1.0 :: Double) - specify "Set order preserved" pending specify "String type" $ asIO $ do p <- getGlobalTracerProvider let t = makeTracer p "woo" tracerOptions@@ -187,8 +434,59 @@ let t = makeTracer p "woo" tracerOptions s <- createSpan t Context.empty "create_root_span" defaultSpanArguments addAttribute s "🚀" ("🚀" :: Text)- -- TODO actually get attributes out+ -- TODO actually get attributes out + specify "Source code attributes are added correctly" $ asIO $ do+ p <- getGlobalTracerProvider+ let t = makeTracer p "woo" tracerOptions+ attrs <- immutableSpanAttributes =<< unsafeReadSpan =<< f t+ attrs `shouldSatisfy` \a ->+ (lookupAttribute a "code.function") == Just (toAttribute @Text "f")+ && (lookupAttribute a "code.namespace") == Just (toAttribute @Text "OpenTelemetry.TraceSpec")+ && isJust (lookupAttribute a "code.lineno")++ specify "Source code attributes are not added in the presence of frozen call stacks" $ asIO $ do+ p <- getGlobalTracerProvider+ let t = makeTracer p "woo" tracerOptions+ attrs <- immutableSpanAttributes =<< unsafeReadSpan =<< g3 t+ attrs `shouldSatisfy` \a ->+ (lookupAttribute a "code.function") == Nothing+ && (lookupAttribute a "code.namespace") == Nothing+ && (lookupAttribute a "code.lineno") == Nothing++ specify "Source code attributes are not added if source attributes are already present" $ asIO $ do+ p <- getGlobalTracerProvider+ let t = makeTracer p "woo" tracerOptions+ attrs <- immutableSpanAttributes =<< unsafeReadSpan =<< h t+ attrs `shouldSatisfy` \a ->+ (lookupAttribute a "code.function") == Just (toAttribute @Text "something")+ && (lookupAttribute a "code.namespace") == Nothing+ && (lookupAttribute a "code.lineno") == Nothing++ specify "Source code attributes can be added for span creation wrappers" $ asIO $ do+ p <- getGlobalTracerProvider+ let t = makeTracer p "woo" tracerOptions+ attrs <- immutableSpanAttributes =<< unsafeReadSpan =<< useSpanHelper t+ attrs `shouldSatisfy` \a ->+ (lookupAttribute a "code.function") == Just (toAttribute @Text "useSpanHelper")++ specify "Attribute length limit is respected" $ asIO $ do+ p <- getGlobalTracerProvider+ let t = makeTracer p "woo" tracerOptions+ s <- createSpan t Context.empty "test_span" defaultSpanArguments+ let+ longAttribute :: Text = "looooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooong"+ -- We set this limit in Spec.hs+ -- The long attribute should be truncated down to this length+ truncatedAttribute :: Text = Text.take 50 longAttribute+ addAttribute s "attr1" longAttribute+ addAttributes s (HM.singleton "attr2" (toAttribute longAttribute))+ s <- unsafeReadSpan s++ attrs <- immutableSpanAttributes s+ lookupAttribute attrs "attr1" `shouldBe` Just (toAttribute truncatedAttribute)+ lookupAttribute attrs "attr2" `shouldBe` Just (toAttribute truncatedAttribute)+ describe "Span events" $ do specify "AddEvent" $ asIO $ do p <- getGlobalTracerProvider@@ -200,20 +498,143 @@ , newEventAttributes = mempty , newEventTimestamp = Nothing }- specify "Add order preserved" pending- specify "Safe for concurrent calls" pending describe "Span exceptions" $ do- specify "RecordException" pending- specify "RecordException with extra parameters" pending+ specify "RecordException" $ do+ (processor, _ref) <- inMemoryListExporter+ tp <- createTracerProvider [processor] emptyTracerProviderOptions {tracerProviderOptionsIdGenerator = defaultIdGenerator}+ let tracer = makeTracer tp "test" tracerOptions+ s <- createSpan tracer Context.empty "exception_test" defaultSpanArguments+ let ex = userError "test error" :: IOException+ recordException s HM.empty Nothing ex+ imm <- unsafeReadSpan s+ evts <- immutableSpanEvents imm+ V.length evts `shouldSatisfy` (>= 1)+ let evt = V.head evts+ eventName evt `shouldBe` "exception"+ let evtAttrs = eventAttributes evt+ lookupAttribute evtAttrs "exception.message" `shouldSatisfy` isJust+ lookupAttribute evtAttrs "exception.type" `shouldSatisfy` isJust describe "Sampling" $ do- specify "Allow samplers to modify tracestate" pending- specify "ShouldSample gets full parent Context" pending- specify "ShouldSample gets InstrumentationLibrary" pending+ specify "Allow samplers to modify tracestate" $ do+ (processor, _ref) <- inMemoryListExporter+ let customTs = TraceState.insert (TraceState.Key "custom_key") (TraceState.Value "custom_value") TraceState.empty+ sampler =+ CustomSampler "tracestate-modifier" $ \_ctx _tid _name _args _scope ->+ pure $ SamplingDecision RecordAndSample HM.empty customTs+ tp <-+ createTracerProvider+ [processor]+ emptyTracerProviderOptions+ { tracerProviderOptionsIdGenerator = defaultIdGenerator+ , tracerProviderOptionsSampler = sampler+ }+ let tracer = makeTracer tp "test" tracerOptions+ s <- createSpan tracer Context.empty "sampler_test" defaultSpanArguments+ sc <- getSpanContext s+ traceState sc `shouldBe` customTs - specify "New Span ID created also for non-recording spans" pending- specify "IdGenerators" pending- specify "SpanLimits" pending- specify "Built-in Processors implement ForceFlush spec" pending- specify "Attribute Limits" pending+ specify "ShouldSample gets full parent Context" $ do+ receivedCtxRef <- newIORef (Nothing :: Maybe Context.Context)+ let sampler =+ CustomSampler "context-recorder" $ \ctx _tid _name _args _scope -> do+ writeIORef receivedCtxRef (Just ctx)+ pure $ SamplingDecision RecordAndSample HM.empty TraceState.empty+ (processor, _ref) <- inMemoryListExporter+ tp <-+ createTracerProvider+ [processor]+ emptyTracerProviderOptions+ { tracerProviderOptionsIdGenerator = defaultIdGenerator+ , tracerProviderOptionsSampler = sampler+ }+ let tracer = makeTracer tp "test" tracerOptions+ parentSpan <- createSpan tracer Context.empty "parent" defaultSpanArguments+ -- Reset the ref after the parent creation+ writeIORef receivedCtxRef Nothing+ let ctxt = Context.insertSpan parentSpan Context.empty+ _childSpan <- createSpan tracer ctxt "child" defaultSpanArguments+ receivedCtx <- readIORef receivedCtxRef+ case receivedCtx of+ Nothing -> expectationFailure "Sampler should have received a context"+ Just ctx -> do+ let spanInCtx = Context.lookupSpan ctx+ case spanInCtx of+ Nothing -> expectationFailure "Context passed to sampler should contain parent span"+ Just p -> do+ pSc <- getSpanContext p+ parentSc <- getSpanContext parentSpan+ pSc `shouldBe` parentSc++ specify "ShouldSample gets InstrumentationLibrary" $ do+ (processor, _ref) <- inMemoryListExporter+ receivedScopeRef <- newIORef (Nothing :: Maybe InstrumentationLibrary)+ let sampler =+ CustomSampler "scope-recorder" $ \_ctx _tid _name _args scope -> do+ writeIORef receivedScopeRef (Just scope)+ pure $ SamplingDecision RecordAndSample HM.empty TraceState.empty+ tp <-+ createTracerProvider+ [processor]+ emptyTracerProviderOptions+ { tracerProviderOptionsIdGenerator = defaultIdGenerator+ , tracerProviderOptionsSampler = sampler+ }+ let tracer = makeTracer tp "my-library" tracerOptions+ _s <- createSpan tracer Context.empty "scope_test" defaultSpanArguments+ receivedScope <- readIORef receivedScopeRef+ case receivedScope of+ Nothing -> expectationFailure "Sampler should have received InstrumentationLibrary"+ Just scope -> libraryName scope `shouldBe` "my-library"++ specify "New Span ID created also for non-recording spans" $ do+ (processor, _ref) <- inMemoryListExporter+ tp <-+ createTracerProvider+ [processor]+ emptyTracerProviderOptions+ { tracerProviderOptionsIdGenerator = defaultIdGenerator+ , tracerProviderOptionsSampler = alwaysOff+ }+ let tracer = makeTracer tp "test" tracerOptions+ spanIds <- forM [1 .. 5 :: Int] $ \_ -> do+ s <- createSpan tracer Context.empty "dropped" defaultSpanArguments+ sc <- getSpanContext s+ pure (spanId sc)+ -- All span IDs should be distinct even for non-recording (dropped) spans+ nub spanIds `shouldBe` spanIds+++f :: (HasCallStack) => Tracer -> IO Span+f tracer =+ createSpan tracer Context.empty "name" defaultSpanArguments+++g :: (HasCallStack) => Tracer -> IO Span+-- block createSpan and callerAttributes from appearing in the call stack+g tracer = withFrozenCallStack $ createSpan tracer Context.empty "name" defaultSpanArguments+++g2 :: (HasCallStack) => Tracer -> IO Span+g2 tracer = g tracer+++-- Make a 3-deep call stack+g3 :: (HasCallStack) => Tracer -> IO Span+g3 tracer = g2 tracer+++h :: (HasCallStack) => Tracer -> IO Span+h tracer =+ createSpan tracer Context.empty "name" (addAttributesToSpanArguments (HM.singleton "code.function" "something") defaultSpanArguments)+++myInSpan :: (HasCallStack) => Tracer -> Text -> IO a -> IO (a, Span)+myInSpan tracer name act = inSpan' tracer name (addAttributesToSpanArguments callerAttributes defaultSpanArguments) $ \traceSpan -> do+ res <- act+ pure (res, traceSpan)+++useSpanHelper :: (HasCallStack) => Tracer -> IO Span+useSpanHelper tracer = snd <$> myInSpan tracer "useSpanHelper" (pure ())
test/Spec.hs view
@@ -1,16 +1,90 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++import Control.Concurrent (myThreadId)+import Control.Exception (AsyncException (UserInterrupt), SomeException, throwTo, try) import qualified OpenTelemetry.BaggageSpec as BaggageSpec+import qualified OpenTelemetry.ConfigurationSpec as ConfigurationSpec+import qualified OpenTelemetry.ContextInSpanSpec as ContextInSpanSpec import qualified OpenTelemetry.ContextSpec as ContextSpec+import qualified OpenTelemetry.LogSpec as LogSpec+import qualified OpenTelemetry.MeterProviderSpec as MeterProviderSpec+import qualified OpenTelemetry.MetricReaderSpec as MetricReaderSpec+import qualified OpenTelemetry.Resource.DetectorSpec as DetectorSpec import qualified OpenTelemetry.ResourceSpec as ResourceSpec-import OpenTelemetry.Trace (initializeGlobalTracerProvider)+import OpenTelemetry.Trace (initializeGlobalTracerProvider, withTracerProvider)+import qualified OpenTelemetry.Trace.CallStackSpec as CallStackSpec import qualified OpenTelemetry.TraceSpec as TraceSpec+import System.Environment (getArgs, setEnv, unsetEnv)+import System.Exit (ExitCode (..), exitWith)+import System.IO (hFlush, stdout)+++{- FOURMOLU_DISABLE -}+#if !defined(mingw32_HOST_OS)+import System.Posix.Signals (Handler (CatchOnce), installHandler, sigTERM)+#endif+{- FOURMOLU_ENABLE -}+ import Test.Hspec main :: IO () main = do+ args <- getArgs+ case args of+ ("--signal-test-helper" : rest) -> signalTestHelper rest+ _ -> runTests+++runTests :: IO ()+runTests = do+ setEnv "OTEL_ATTRIBUTE_VALUE_LENGTH_LIMIT" "50"+ setEnv "OTEL_RESOURCE_ATTRIBUTES" "host.name=env_host_name,example.name=env_example_name,example.count=42" initializeGlobalTracerProvider hspec $ do BaggageSpec.spec ContextSpec.spec+ ContextInSpanSpec.spec TraceSpec.spec+ CallStackSpec.spec ResourceSpec.spec+ DetectorSpec.spec+ LogSpec.spec+ MeterProviderSpec.spec+ MetricReaderSpec.spec+ ConfigurationSpec.spec+++signalTestHelper :: [String] -> IO ()++{- FOURMOLU_DISABLE -}+#if !defined(mingw32_HOST_OS)+signalTestHelper [markerPath] = do+ tid <- myThreadId+ _ <- installHandler sigTERM (CatchOnce (throwTo tid UserInterrupt)) Nothing+ setEnv "OTEL_TRACES_EXPORTER" "none"+ setEnv "OTEL_PROPAGATORS" "none"+ unsetEnv "OTEL_CONFIG_FILE"+ setEnv "OTEL_LOG_LEVEL" "none"+ _ <- try @SomeException $ withTracerProvider $ \_ -> do+ putStrLn "READY"+ hFlush stdout+ waitForever+ writeFile markerPath "SHUTDOWN_COMPLETE"+ exitWith ExitSuccess+ where+ waitForever :: IO ()+ waitForever = do+ _ <- getLine+ waitForever+#else+signalTestHelper [_markerPath] = pure ()+#endif+{- FOURMOLU_ENABLE -}+++signalTestHelper _ = do+ putStrLn "Usage: --signal-test-helper <marker-path>"+ exitWith (ExitFailure 1)