hs-opentelemetry-sdk 0.1.0.1 → 1.0.0.0
raw patch · 55 files changed
+9035/−347 lines, 55 filesdep +aesondep +case-insensitivedep +containersdep −unagi-chandep ~hs-opentelemetry-apidep ~hs-opentelemetry-exporter-otlpdep ~hs-opentelemetry-propagator-b3
Dependencies added: aeson, case-insensitive, containers, crypton-connection, crypton-x509, crypton-x509-store, directory, hashable, hs-opentelemetry-exporter-handle, hs-opentelemetry-exporter-in-memory, hs-opentelemetry-propagator-jaeger, hs-opentelemetry-propagator-xray, hs-opentelemetry-semantic-conventions, http-client, http-client-tls, process, scientific, time, tls, yaml
Dependencies removed: unagi-chan
Dependency ranges changed: hs-opentelemetry-api, hs-opentelemetry-exporter-otlp, hs-opentelemetry-propagator-b3, hs-opentelemetry-propagator-datadog, hs-opentelemetry-propagator-w3c
Files
- ChangeLog.md +163/−0
- LICENSE +1/−1
- README.md +13/−3
- hs-opentelemetry-sdk.cabal +92/−24
- 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/−0
- src/OpenTelemetry/Processor/Batch/LogRecord.hs +198/−1
- src/OpenTelemetry/Processor/Batch/Span.hs +122/−75
- src/OpenTelemetry/Processor/Simple.hs +5/−0
- src/OpenTelemetry/Processor/Simple/LogRecord.hs +99/−1
- src/OpenTelemetry/Processor/Simple/Span.hs +80/−29
- 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 +39/−5
- 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 +115/−65
- src/OpenTelemetry/Trace/Id/Generator/Default.hs +1/−13
- src/platform/unix/OpenTelemetry/Platform.hs +11/−0
- src/platform/windows/OpenTelemetry/Platform.hs +9/−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 +356/−75
- test/Spec.hs +73/−4
ChangeLog.md view
@@ -2,6 +2,169 @@ ## 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
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,41 +1,69 @@ cabal-version: 1.22 --- This file has been generated from package.yaml by hpack version 0.37.0.+-- This file has been generated from package.yaml by hpack version 0.38.3. -- -- see: https://github.com/sol/hpack -name: hs-opentelemetry-sdk-version: 0.1.0.1-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+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@@ -43,6 +71,7 @@ OpenTelemetry.Trace OpenTelemetry.Trace.Id.Generator.Default other-modules:+ OpenTelemetry.Resource.Detector.Internal Paths_hs_opentelemetry_sdk reexported-modules: OpenTelemetry.Attributes@@ -78,24 +107,38 @@ src ghc-options: -Wall build-depends:- async+ aeson+ , async , base >=4.7 && <5 , bytestring- , hs-opentelemetry-api ==0.3.*- , hs-opentelemetry-exporter-otlp ==0.1.*- , hs-opentelemetry-propagator-b3 >=0.0.1 && <0.1- , hs-opentelemetry-propagator-datadog >=0.0.0 && <0.1- , hs-opentelemetry-propagator-w3c >=0.1.0 && <0.2+ , 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- , unagi-chan+ , time , unix-compat >=0.7.1 , unordered-containers , vector , vector-builder+ , yaml default-language: Haskell2010 if os(windows) other-modules:@@ -109,25 +152,50 @@ 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 build-depends:- base >=4.7 && <5+ async+ , base >=4.7 && <5+ , bytestring , clock+ , containers+ , directory , hs-opentelemetry-api+ , hs-opentelemetry-exporter-in-memory+ , hs-opentelemetry-propagator-b3+ , hs-opentelemetry-propagator-w3c , hs-opentelemetry-sdk+ , hs-opentelemetry-semantic-conventions , hspec+ , process , text+ , unix , unordered-containers+ , vector 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,3 +1,8 @@+{- |+Module : OpenTelemetry.Processor.Batch+Description : Re-exports for batch processors (both span and log record).+Stability : experimental+-} module OpenTelemetry.Processor.Batch ( module OpenTelemetry.Processor.Batch.Span, ) where
src/OpenTelemetry/Processor/Batch/LogRecord.hs view
@@ -1,2 +1,199 @@-module OpenTelemetry.Processor.Batch.LogRecord () where+{-# 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
@@ -30,12 +30,15 @@ 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.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 @@ -45,14 +48,17 @@ { 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.+ {- ^ 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.+ {- ^ 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.+ {- ^ The maximum batch size of every export. It must be+ smaller or equal to 'maxQueueSize'. The default value is 512.+ -} } deriving (Show) @@ -61,7 +67,7 @@ batchTimeoutConfig :: BatchTimeoutConfig batchTimeoutConfig = BatchTimeoutConfig- { maxQueueSize = 1024+ { maxQueueSize = 2048 , scheduledDelayMillis = 5000 , exportTimeoutMillis = 30000 , maxExportBatchSize = 512@@ -160,8 +166,6 @@ -- -- 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@@ -176,7 +180,7 @@ push :: ImmutableSpan -> BoundedMap ImmutableSpan -> Maybe (BoundedMap ImmutableSpan) push s m =- if itemCount m + 1 >= itemBounds m+ if itemCount m >= itemBounds m then Nothing else Just $!@@ -198,7 +202,7 @@ ) -data ProcessorMessage = ScheduledFlush | MaxExportFlush | Shutdown+data ProcessorMessage = ScheduledFlush | MaxExportFlush | FlushRequested | Shutdown -- note: [Unmasking Asyncs]@@ -235,48 +239,80 @@ 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- 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.- SpanExporter.spanExporterExport exporter batchToProcess+ 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 do- pure ret+ then pure ret else do- ret' <- publish batchToProcess+ 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 $ do+ atomically $ msum- -- Flush every scheduled delay time, when we've reached the max export size, or when the shutdown signal is received.- [ ScheduledFlush <$ do+ [ Shutdown <$ takeTMVar shutdownSignal+ , FlushRequested <$ takeTMVar flushRequestSignal+ , MaxExportFlush <$ takeTMVar workSignal+ , 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+ res <- publishBounded batchToProcess - -- if we were asked to shutdown, stop waiting and flush it all out case req of Shutdown -> flushQueueImmediately res+ FlushRequested -> do+ _ <- flushQueueImmediately res+ atomically $ putTMVar flushDoneSignal ()+ workerAction _ -> workerAction -- see note [Unmasking Asyncs]@@ -286,21 +322,23 @@ SpanProcessor { spanProcessorOnStart = \_ _ -> pure () , spanProcessorOnEnd = \s -> do- span_ <- readIORef s- appendFailedOrExportNeeded <- atomicModifyIORef' batch $ \builder ->- case push span_ builder of- Nothing -> (builder, True)+ (dropped, exportNeeded) <- atomicModifyIORef' batch $ \builder ->+ case push s builder of+ Nothing -> (builder, (True, 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 ()- , spanProcessorForceFlush = void $ atomically $ tryPutTMVar workSignal ()+ 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 =- asyncWithUnmask $ \unmask -> unmask $ do- -- we call asyncWithUnmask here because the shutdown action is+ 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@@ -310,47 +348,44 @@ -- 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 ()+ -- 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- ]+ -- 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+ -- 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+ pure $ case shutdownResult of+ Nothing ->+ ShutdownTimeout+ Just er ->+ case er of+ Left _ ->+ ShutdownFailure+ Right _ ->+ ShutdownSuccess } where millisToMicros = (* 1000) + {- buffer <- newGreenBlueBuffer _ _ batchProcessorAction <- async $ forever $ do@@ -370,3 +405,15 @@ 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,3 +1,8 @@+{- |+Module : OpenTelemetry.Processor.Simple+Description : Re-exports for simple (synchronous) processors.+Stability : experimental+-} module OpenTelemetry.Processor.Simple ( module OpenTelemetry.Processor.Simple.Span, ) where
src/OpenTelemetry/Processor/Simple/LogRecord.hs view
@@ -1,2 +1,100 @@-module OpenTelemetry.Processor.Simple.LogRecord () where+{-# 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
@@ -7,58 +7,109 @@ ) where import Control.Concurrent.Async-import Control.Concurrent.Chan.Unagi-import Control.Exception+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 (ImmutableSpan, spanTracer, tracerName)+import OpenTelemetry.Trace.Core (spanTracer, tracerName) -newtype SimpleProcessorConfig = SimpleProcessorConfig+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- (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_ (spanExporter `SpanExporter.spanExporterExport` HashMap.singleton (tracerName $ spanTracer span_) (pure span_))+ 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 = writeChan inChan- , spanProcessorShutdown = async $ mask $ \restore -> do- cancel exportWorker- -- TODO handle timeouts- restore $ do- -- TODO, not convinced we should shut down processor here- shutdownProcessor outChan `finally` SpanExporter.spanExporterShutdown spanExporter+ , 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 = pure ()+ , spanProcessorForceFlush = do+ isShut <- readTVarIO shutdownVar+ unless isShut $ do+ atomically $ putTMVar flushReq ()+ atomically $ takeTMVar flushDone+ SpanExporter.spanExporterForceFlush spanExporter }- 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- _ <- spanExporter `SpanExporter.spanExporterExport` HashMap.singleton (tracerName $ spanTracer span_) (pure span_)- shutdownProcessor outChan
+ 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,14 +1,20 @@ module OpenTelemetry.Resource.Process.Detector where 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 (tryGetUser)+import OpenTelemetry.Platform (tryGetParentProcessID, tryGetUser) import OpenTelemetry.Resource.Process+import System.Directory (getCurrentDirectory) import System.Environment ( getArgs, getExecutablePath, getProgName, )+import System.IO (hIsTerminalDevice, stdin)+import System.IO.Error (tryIOError) import System.Info import System.PosixCompat.Process (getProcessID) @@ -20,16 +26,43 @@ -} 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 +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 of itself. @@ -40,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
@@ -91,9 +91,11 @@ TracerProvider, initializeGlobalTracerProvider, initializeTracerProvider,+ withTracerProvider, getTracerProviderInitializationOptions, getTracerProviderInitializationOptions', shutdownTracerProvider,+ forceFlushTracerProvider, -- ** Getting / setting the global 'TracerProvider' getGlobalTracerProvider,@@ -150,15 +152,21 @@ 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@@ -168,17 +176,21 @@ import OpenTelemetry.Exporter.Span (SpanExporter) import OpenTelemetry.Processor.Batch.Span (BatchTimeoutConfig (..), batchProcessor, batchTimeoutConfig) import OpenTelemetry.Processor.Span (SpanProcessor)-import OpenTelemetry.Propagator (Propagator)+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)@@ -291,7 +303,30 @@ -} -knownPropagators :: [(T.Text, Propagator Context RequestHeaders RequestHeaders)]+{- | 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)@@ -302,9 +337,12 @@ ] --- TODO, actually implement a registry systme-readRegisteredPropagators :: IO [(T.Text, Propagator Context RequestHeaders RequestHeaders)]-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@@ -326,11 +364,20 @@ initializeTracerProvider :: IO TracerProvider initializeTracerProvider = do (processors, opts) <- getTracerProviderInitializationOptions+ setGlobalTextMapPropagator (tracerProviderOptionsPropagators opts) createTracerProvider processors opts +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 :: Resource 'Nothing)+getTracerProviderInitializationOptions = getTracerProviderInitializationOptions' mempty {- | Detect options for initializing a tracer provider from the app environment, taking additional supported resources as well.@@ -338,14 +385,17 @@ @since 0.0.3.1 -} getTracerProviderInitializationOptions'- :: forall schema- . (MaterializeResource schema)- => Resource schema+ :: Resource -> IO ([SpanProcessor], TracerProviderOptions) getTracerProviderInitializationOptions' rs = do disabled <- lookupBooleanEnv "OTEL_SDK_DISABLED" if disabled- then pure ([], emptyTracerProviderOptions)+ then do+ propagators <- detectPropagators+ pure+ ( []+ , emptyTracerProviderOptions {tracerProviderOptionsPropagators = propagators}+ ) else do sampler <- detectSampler attrLimits <- detectAttributeLimits@@ -355,9 +405,15 @@ 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.- allRs = mergeResources rs (envVarRs <> builtInRs)+ 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 []@@ -375,7 +431,7 @@ pure (processors, providerOpts) -detectPropagators :: IO (Propagator Context RequestHeaders RequestHeaders)+detectPropagators :: IO TextMapPropagator detectPropagators = do registeredPropagators <- readRegisteredPropagators propagatorsInEnv <- fmap (T.splitOn "," . T.pack) <$> lookupEnv "OTEL_PROPAGATORS"@@ -426,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@@ -454,8 +517,8 @@ <$> 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" @@ -480,12 +543,21 @@ 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 @@ -506,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
@@ -1,8 +1,14 @@+{- |+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) @@ -15,3 +21,8 @@ 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
@@ -1,3 +1,8 @@+{- |+Module : OpenTelemetry.Platform+Description : Windows-specific platform utilities for the OpenTelemetry SDK.+Stability : experimental+-} module OpenTelemetry.Platform where import qualified Data.Text as T@@ -5,3 +10,7 @@ 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
@@ -6,24 +6,30 @@ 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, lookupAttribute)+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 @@ -31,6 +37,26 @@ 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" @@ -52,18 +78,35 @@ 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 'Nothing -> IO Attributes+ let getInitialResourceAttrs :: Resource -> IO Attributes getInitialResourceAttrs resource = do opts <- snd <$> getTracerProviderInitializationOptions' resource pure . getMaterializedResourcesAttributes $ tracerProviderOptionsResources opts@@ -80,7 +123,7 @@ ] attrsFromUser <- getInitialResourceAttrs $- mkResource @'Nothing+ mkResource [ HostName .= toAttribute @Text "user_host_name" , TelemetrySdkLanguage .= toAttribute @Text "GHC2021" , ExampleCount .= toAttribute @Int 11@@ -110,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@@ -131,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@@ -162,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@@ -170,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@@ -179,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@@ -207,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@@ -248,36 +439,36 @@ specify "Source code attributes are added correctly" $ asIO $ do p <- getGlobalTracerProvider let t = makeTracer p "woo" tracerOptions- s <- unsafeReadSpan =<< f t- spanAttributes s `shouldSatisfy` \attrs ->- (lookupAttribute attrs "code.function") == Just (toAttribute @Text "f")- && (lookupAttribute attrs "code.namespace") == Just (toAttribute @Text "OpenTelemetry.TraceSpec")- && (lookupAttribute attrs "code.lineno") == Just (toAttribute @Int 330)+ 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- s <- unsafeReadSpan =<< g3 t- spanAttributes s `shouldSatisfy` \attrs ->- (lookupAttribute attrs "code.function") == Nothing- && (lookupAttribute attrs "code.namespace") == Nothing- && (lookupAttribute attrs "code.lineno") == Nothing+ 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- s <- unsafeReadSpan =<< h t- spanAttributes s `shouldSatisfy` \attrs ->- (lookupAttribute attrs "code.function") == Just (toAttribute @Text "something")- && (lookupAttribute attrs "code.namespace") == Nothing- && (lookupAttribute attrs "code.lineno") == Nothing+ 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- s <- unsafeReadSpan =<< useSpanHelper t- spanAttributes s `shouldSatisfy` \attrs ->- (lookupAttribute attrs "code.function") == Just (toAttribute @Text "useSpanHelper")+ 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@@ -292,8 +483,9 @@ addAttributes s (HM.singleton "attr2" (toAttribute longAttribute)) s <- unsafeReadSpan s - lookupAttribute (spanAttributes s) "attr1" `shouldBe` Just (toAttribute truncatedAttribute)- lookupAttribute (spanAttributes s) "attr2" `shouldBe` Just (toAttribute truncatedAttribute)+ 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@@ -306,54 +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" -f :: HasCallStack => Tracer -> IO Span+ 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+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 :: (HasCallStack) => Tracer -> IO Span g2 tracer = g tracer -- Make a 3-deep call stack-g3 :: HasCallStack => Tracer -> IO Span+g3 :: (HasCallStack) => Tracer -> IO Span g3 tracer = g2 tracer -h :: HasCallStack => Tracer -> IO Span+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 :: (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 :: (HasCallStack) => Tracer -> IO Span useSpanHelper tracer = snd <$> myInSpan tracer "useSpanHelper" (pure ())
test/Spec.hs view
@@ -1,21 +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 (setEnv)+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- -- For the attribute length limit test+ args <- getArgs+ case args of+ ("--signal-test-helper" : rest) -> signalTestHelper rest+ _ -> runTests+++runTests :: IO ()+runTests = do setEnv "OTEL_ATTRIBUTE_VALUE_LENGTH_LIMIT" "50"- -- For the resource attributes initialization test 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)