diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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: + +### 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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Ian Duncan (c) 2021 +Copyright Ian Duncan (c) 2021-2026 All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. +[![hs-opentelemetry-sdk](https://img.shields.io/hackage/v/hs-opentelemetry-sdk?style=flat-square&logo=haskell&label=hs-opentelemetry-sdk&labelColor=5D4F85)](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 diff --git a/hs-opentelemetry-sdk.cabal b/hs-opentelemetry-sdk.cabal --- a/hs-opentelemetry-sdk.cabal +++ b/hs-opentelemetry-sdk.cabal @@ -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 -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 +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 diff --git a/src/OpenTelemetry/Configuration.hs b/src/OpenTelemetry/Configuration.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/Configuration.hs @@ -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 +), +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 diff --git a/src/OpenTelemetry/Configuration/Create.hs b/src/OpenTelemetry/Configuration/Create.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/Configuration/Create.hs @@ -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 diff --git a/src/OpenTelemetry/Configuration/Parse.hs b/src/OpenTelemetry/Configuration/Parse.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/Configuration/Parse.hs @@ -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 diff --git a/src/OpenTelemetry/Configuration/Types.hs b/src/OpenTelemetry/Configuration/Types.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/Configuration/Types.hs @@ -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 + } diff --git a/src/OpenTelemetry/Log.hs b/src/OpenTelemetry/Log.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/Log.hs @@ -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 + + +-} +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 diff --git a/src/OpenTelemetry/MeterProvider.hs b/src/OpenTelemetry/MeterProvider.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/MeterProvider.hs @@ -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) diff --git a/src/OpenTelemetry/Metric.hs b/src/OpenTelemetry/Metric.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/Metric.hs @@ -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 + + +-} +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' diff --git a/src/OpenTelemetry/Metric/ExporterSelection.hs b/src/OpenTelemetry/Metric/ExporterSelection.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/Metric/ExporterSelection.hs @@ -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 + } diff --git a/src/OpenTelemetry/Metric/View.hs b/src/OpenTelemetry/Metric/View.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/Metric/View.hs @@ -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 diff --git a/src/OpenTelemetry/MetricReader.hs b/src/OpenTelemetry/MetricReader.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/MetricReader.hs @@ -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 + } diff --git a/src/OpenTelemetry/Processor/Batch.hs b/src/OpenTelemetry/Processor/Batch.hs --- a/src/OpenTelemetry/Processor/Batch.hs +++ b/src/OpenTelemetry/Processor/Batch.hs @@ -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 diff --git a/src/OpenTelemetry/Processor/Batch/LogRecord.hs b/src/OpenTelemetry/Processor/Batch/LogRecord.hs --- a/src/OpenTelemetry/Processor/Batch/LogRecord.hs +++ b/src/OpenTelemetry/Processor/Batch/LogRecord.hs @@ -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 diff --git a/src/OpenTelemetry/Processor/Batch/Span.hs b/src/OpenTelemetry/Processor/Batch/Span.hs --- a/src/OpenTelemetry/Processor/Batch/Span.hs +++ b/src/OpenTelemetry/Processor/Batch/Span.hs @@ -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 diff --git a/src/OpenTelemetry/Processor/Simple.hs b/src/OpenTelemetry/Processor/Simple.hs --- a/src/OpenTelemetry/Processor/Simple.hs +++ b/src/OpenTelemetry/Processor/Simple.hs @@ -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 diff --git a/src/OpenTelemetry/Processor/Simple/LogRecord.hs b/src/OpenTelemetry/Processor/Simple/LogRecord.hs --- a/src/OpenTelemetry/Processor/Simple/LogRecord.hs +++ b/src/OpenTelemetry/Processor/Simple/LogRecord.hs @@ -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 + } diff --git a/src/OpenTelemetry/Processor/Simple/Span.hs b/src/OpenTelemetry/Processor/Simple/Span.hs --- a/src/OpenTelemetry/Processor/Simple/Span.hs +++ b/src/OpenTelemetry/Processor/Simple/Span.hs @@ -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 diff --git a/src/OpenTelemetry/Resource/Cloud/Detector.hs b/src/OpenTelemetry/Resource/Cloud/Detector.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/Resource/Cloud/Detector.hs @@ -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 + } diff --git a/src/OpenTelemetry/Resource/Container/Detector.hs b/src/OpenTelemetry/Resource/Container/Detector.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/Resource/Container/Detector.hs @@ -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 diff --git a/src/OpenTelemetry/Resource/Detect.hs b/src/OpenTelemetry/Resource/Detect.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/Resource/Detect.hs @@ -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) diff --git a/src/OpenTelemetry/Resource/Detector/AWS/EC2.hs b/src/OpenTelemetry/Resource/Detector/AWS/EC2.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/Resource/Detector/AWS/EC2.hs @@ -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 diff --git a/src/OpenTelemetry/Resource/Detector/AWS/ECS.hs b/src/OpenTelemetry/Resource/Detector/AWS/ECS.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/Resource/Detector/AWS/ECS.hs @@ -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) diff --git a/src/OpenTelemetry/Resource/Detector/AWS/EKS.hs b/src/OpenTelemetry/Resource/Detector/AWS/EKS.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/Resource/Detector/AWS/EKS.hs @@ -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 diff --git a/src/OpenTelemetry/Resource/Detector/Azure.hs b/src/OpenTelemetry/Resource/Detector/Azure.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/Resource/Detector/Azure.hs @@ -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" diff --git a/src/OpenTelemetry/Resource/Detector/GCP.hs b/src/OpenTelemetry/Resource/Detector/GCP.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/Resource/Detector/GCP.hs @@ -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 diff --git a/src/OpenTelemetry/Resource/Detector/Heroku.hs b/src/OpenTelemetry/Resource/Detector/Heroku.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/Resource/Detector/Heroku.hs @@ -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 +. + +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 + ] diff --git a/src/OpenTelemetry/Resource/Detector/Internal.hs b/src/OpenTelemetry/Resource/Detector/Internal.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/Resource/Detector/Internal.hs @@ -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 diff --git a/src/OpenTelemetry/Resource/Detector/Metadata.hs b/src/OpenTelemetry/Resource/Detector/Metadata.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/Resource/Detector/Metadata.hs @@ -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 diff --git a/src/OpenTelemetry/Resource/FaaS/Detector.hs b/src/OpenTelemetry/Resource/FaaS/Detector.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/Resource/FaaS/Detector.hs @@ -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 = "/" + 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 + } diff --git a/src/OpenTelemetry/Resource/Host/Detector.hs b/src/OpenTelemetry/Resource/Host/Detector.hs --- a/src/OpenTelemetry/Resource/Host/Detector.hs +++ b/src/OpenTelemetry/Resource/Host/Detector.hs @@ -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 {..} diff --git a/src/OpenTelemetry/Resource/Kubernetes/Detector.hs b/src/OpenTelemetry/Resource/Kubernetes/Detector.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/Resource/Kubernetes/Detector.hs @@ -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} diff --git a/src/OpenTelemetry/Resource/OperatingSystem/Detector.hs b/src/OpenTelemetry/Resource/OperatingSystem/Detector.hs --- a/src/OpenTelemetry/Resource/OperatingSystem/Detector.hs +++ b/src/OpenTelemetry/Resource/OperatingSystem/Detector.hs @@ -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 diff --git a/src/OpenTelemetry/Resource/Process/Detector.hs b/src/OpenTelemetry/Resource/Process/Detector.hs --- a/src/OpenTelemetry/Resource/Process/Detector.hs +++ b/src/OpenTelemetry/Resource/Process/Detector.hs @@ -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 } diff --git a/src/OpenTelemetry/Resource/Service/Detector.hs b/src/OpenTelemetry/Resource/Service/Detector.hs --- a/src/OpenTelemetry/Resource/Service/Detector.hs +++ b/src/OpenTelemetry/Resource/Service/Detector.hs @@ -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 } diff --git a/src/OpenTelemetry/Resource/Telemetry/Detector.hs b/src/OpenTelemetry/Resource/Telemetry/Detector.hs --- a/src/OpenTelemetry/Resource/Telemetry/Detector.hs +++ b/src/OpenTelemetry/Resource/Telemetry/Detector.hs @@ -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 } diff --git a/src/OpenTelemetry/SDK.hs b/src/OpenTelemetry/SDK.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/SDK.hs @@ -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 diff --git a/src/OpenTelemetry/Trace.hs b/src/OpenTelemetry/Trace.hs --- a/src/OpenTelemetry/Trace.hs +++ b/src/OpenTelemetry/Trace.hs @@ -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 diff --git a/src/OpenTelemetry/Trace/Id/Generator/Default.hs b/src/OpenTelemetry/Trace/Id/Generator/Default.hs --- a/src/OpenTelemetry/Trace/Id/Generator/Default.hs +++ b/src/OpenTelemetry/Trace/Id/Generator/Default.hs @@ -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 diff --git a/src/platform/unix/OpenTelemetry/Platform.hs b/src/platform/unix/OpenTelemetry/Platform.hs --- a/src/platform/unix/OpenTelemetry/Platform.hs +++ b/src/platform/unix/OpenTelemetry/Platform.hs @@ -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 diff --git a/src/platform/windows/OpenTelemetry/Platform.hs b/src/platform/windows/OpenTelemetry/Platform.hs --- a/src/platform/windows/OpenTelemetry/Platform.hs +++ b/src/platform/windows/OpenTelemetry/Platform.hs @@ -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 diff --git a/test/OpenTelemetry/BaggageSpec.hs b/test/OpenTelemetry/BaggageSpec.hs --- a/test/OpenTelemetry/BaggageSpec.hs +++ b/test/OpenTelemetry/BaggageSpec.hs @@ -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" diff --git a/test/OpenTelemetry/ConfigurationSpec.hs b/test/OpenTelemetry/ConfigurationSpec.hs new file mode 100644 --- /dev/null +++ b/test/OpenTelemetry/ConfigurationSpec.hs @@ -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) diff --git a/test/OpenTelemetry/ContextInSpanSpec.hs b/test/OpenTelemetry/ContextInSpanSpec.hs new file mode 100644 --- /dev/null +++ b/test/OpenTelemetry/ContextInSpanSpec.hs @@ -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 diff --git a/test/OpenTelemetry/ContextSpec.hs b/test/OpenTelemetry/ContextSpec.hs --- a/test/OpenTelemetry/ContextSpec.hs +++ b/test/OpenTelemetry/ContextSpec.hs @@ -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 diff --git a/test/OpenTelemetry/LogSpec.hs b/test/OpenTelemetry/LogSpec.hs new file mode 100644 --- /dev/null +++ b/test/OpenTelemetry/LogSpec.hs @@ -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 + } diff --git a/test/OpenTelemetry/MeterProviderSpec.hs b/test/OpenTelemetry/MeterProviderSpec.hs new file mode 100644 --- /dev/null +++ b/test/OpenTelemetry/MeterProviderSpec.hs @@ -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" diff --git a/test/OpenTelemetry/MetricReaderSpec.hs b/test/OpenTelemetry/MetricReaderSpec.hs new file mode 100644 --- /dev/null +++ b/test/OpenTelemetry/MetricReaderSpec.hs @@ -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) diff --git a/test/OpenTelemetry/Resource/DetectorSpec.hs b/test/OpenTelemetry/Resource/DetectorSpec.hs new file mode 100644 --- /dev/null +++ b/test/OpenTelemetry/Resource/DetectorSpec.hs @@ -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"] diff --git a/test/OpenTelemetry/ResourceSpec.hs b/test/OpenTelemetry/ResourceSpec.hs --- a/test/OpenTelemetry/ResourceSpec.hs +++ b/test/OpenTelemetry/ResourceSpec.hs @@ -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 diff --git a/test/OpenTelemetry/Trace/CallStackSpec.hs b/test/OpenTelemetry/Trace/CallStackSpec.hs new file mode 100644 --- /dev/null +++ b/test/OpenTelemetry/Trace/CallStackSpec.hs @@ -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 @\"\"@. +-} +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 #-} diff --git a/test/OpenTelemetry/TraceSpec.hs b/test/OpenTelemetry/TraceSpec.hs --- a/test/OpenTelemetry/TraceSpec.hs +++ b/test/OpenTelemetry/TraceSpec.hs @@ -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 ()) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 " + exitWith (ExitFailure 1)