{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
module OpenTelemetry.Trace (
TracerProvider,
initializeGlobalTracerProvider,
initializeTracerProvider,
getTracerProviderInitializationOptions,
getTracerProviderInitializationOptions',
shutdownTracerProvider,
getGlobalTracerProvider,
setGlobalTracerProvider,
Tracer,
tracerName,
getTracer,
makeTracer,
TracerOptions (..),
tracerOptions,
HasTracer (..),
InstrumentationLibrary (..),
Span,
inSpan,
defaultSpanArguments,
SpanArguments (..),
SpanKind (..),
NewLink (..),
inSpan',
updateName,
addAttribute,
addAttributes,
recordException,
setStatus,
SpanStatus (..),
NewEvent (..),
addEvent,
inSpan'',
createTracerProvider,
TracerProviderOptions (..),
emptyTracerProviderOptions,
detectBuiltInResources,
detectSampler,
createSpan,
createSpanWithoutCallStack,
endSpan,
spanGetAttributes,
ToAttribute (..),
ToPrimitiveAttribute (..),
Attribute (..),
PrimitiveAttribute (..),
Link,
Event,
SpanContext (..),
ImmutableSpan (..),
) where
import qualified Data.ByteString.Char8 as B
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 OpenTelemetry.Attributes (AttributeLimits (..), defaultAttributeLimits)
import OpenTelemetry.Baggage (decodeBaggageHeader)
import qualified OpenTelemetry.Baggage as Baggage
import OpenTelemetry.Context (Context)
import OpenTelemetry.Exporter.OTLP.Span (loadExporterEnvironmentVariables, otlpExporter)
import OpenTelemetry.Exporter.Span (SpanExporter)
import OpenTelemetry.Processor.Batch.Span (BatchTimeoutConfig (..), batchProcessor, batchTimeoutConfig)
import OpenTelemetry.Processor.Span (SpanProcessor)
import OpenTelemetry.Propagator (Propagator)
import OpenTelemetry.Propagator.B3 (b3MultiTraceContextPropagator, b3TraceContextPropagator)
import OpenTelemetry.Propagator.Datadog (datadogTraceContextPropagator)
import OpenTelemetry.Propagator.W3CBaggage (w3cBaggagePropagator)
import OpenTelemetry.Propagator.W3CTraceContext (w3cTraceContextPropagator)
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 OpenTelemetry.Trace.Core
import OpenTelemetry.Trace.Id.Generator.Default (defaultIdGenerator)
import OpenTelemetry.Trace.Sampler (Sampler, alwaysOff, alwaysOn, parentBased, parentBasedOptions, traceIdRatioBased)
import System.Environment (lookupEnv)
import Text.Read (readMaybe)
knownPropagators :: [(T.Text, Propagator Context RequestHeaders ResponseHeaders)]
knownPropagators :: [(Text, Propagator Context RequestHeaders RequestHeaders)]
knownPropagators =
[ (Text
"tracecontext", Propagator Context RequestHeaders RequestHeaders
w3cTraceContextPropagator)
, (Text
"baggage", Propagator Context RequestHeaders RequestHeaders
w3cBaggagePropagator)
, (Text
"b3", Propagator Context RequestHeaders RequestHeaders
b3TraceContextPropagator)
, (Text
"b3multi", Propagator Context RequestHeaders RequestHeaders
b3MultiTraceContextPropagator)
, (Text
"datadog", Propagator Context RequestHeaders RequestHeaders
datadogTraceContextPropagator)
, (Text
"jaeger", [Char] -> Propagator Context RequestHeaders RequestHeaders
forall a. HasCallStack => [Char] -> a
error [Char]
"Jaeger not yet implemented")
]
readRegisteredPropagators :: IO [(T.Text, Propagator Context RequestHeaders ResponseHeaders)]
readRegisteredPropagators :: IO [(Text, Propagator Context RequestHeaders RequestHeaders)]
readRegisteredPropagators = [(Text, Propagator Context RequestHeaders RequestHeaders)]
-> IO [(Text, Propagator Context RequestHeaders RequestHeaders)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Text, Propagator Context RequestHeaders RequestHeaders)]
knownPropagators
initializeGlobalTracerProvider :: IO TracerProvider
initializeGlobalTracerProvider :: IO TracerProvider
initializeGlobalTracerProvider = do
TracerProvider
t <- IO TracerProvider
initializeTracerProvider
TracerProvider -> IO ()
forall (m :: * -> *). MonadIO m => TracerProvider -> m ()
setGlobalTracerProvider TracerProvider
t
TracerProvider -> IO TracerProvider
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TracerProvider
t
initializeTracerProvider :: IO TracerProvider
initializeTracerProvider :: IO TracerProvider
initializeTracerProvider = do
([SpanProcessor]
processors, TracerProviderOptions
opts) <- IO ([SpanProcessor], TracerProviderOptions)
getTracerProviderInitializationOptions
[SpanProcessor] -> TracerProviderOptions -> IO TracerProvider
forall (m :: * -> *).
MonadIO m =>
[SpanProcessor] -> TracerProviderOptions -> m TracerProvider
createTracerProvider [SpanProcessor]
processors TracerProviderOptions
opts
getTracerProviderInitializationOptions :: IO ([SpanProcessor], TracerProviderOptions)
getTracerProviderInitializationOptions :: IO ([SpanProcessor], TracerProviderOptions)
getTracerProviderInitializationOptions = Resource 'Nothing -> IO ([SpanProcessor], TracerProviderOptions)
forall (any :: Maybe Symbol).
(ResourceMerge 'Nothing any ~ 'Nothing) =>
Resource any -> IO ([SpanProcessor], TracerProviderOptions)
getTracerProviderInitializationOptions' (Resource 'Nothing
forall a. Monoid a => a
mempty :: Resource 'Nothing)
getTracerProviderInitializationOptions' :: (ResourceMerge 'Nothing any ~ 'Nothing) => Resource any -> IO ([SpanProcessor], TracerProviderOptions)
getTracerProviderInitializationOptions' :: forall (any :: Maybe Symbol).
(ResourceMerge 'Nothing any ~ 'Nothing) =>
Resource any -> IO ([SpanProcessor], TracerProviderOptions)
getTracerProviderInitializationOptions' Resource any
rs = do
Sampler
sampler <- IO Sampler
detectSampler
AttributeLimits
attrLimits <- IO AttributeLimits
detectAttributeLimits
SpanLimits
spanLimits <- IO SpanLimits
detectSpanLimits
Propagator Context RequestHeaders RequestHeaders
propagators <- IO (Propagator Context RequestHeaders RequestHeaders)
detectPropagators
BatchTimeoutConfig
processorConf <- IO BatchTimeoutConfig
detectBatchProcessorConfig
[SpanExporter]
exporters <- IO [SpanExporter]
detectExporters
Resource 'Nothing
builtInRs <- IO (Resource 'Nothing)
detectBuiltInResources
Resource 'Nothing
envVarRs <- [Maybe (Text, Attribute)] -> Resource 'Nothing
forall (r :: Maybe Symbol). [Maybe (Text, Attribute)] -> Resource r
mkResource ([Maybe (Text, Attribute)] -> Resource 'Nothing)
-> ([(Text, Attribute)] -> [Maybe (Text, Attribute)])
-> [(Text, Attribute)]
-> Resource 'Nothing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Attribute) -> Maybe (Text, Attribute))
-> [(Text, Attribute)] -> [Maybe (Text, Attribute)]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Attribute) -> Maybe (Text, Attribute)
forall a. a -> Maybe a
Just ([(Text, Attribute)] -> Resource 'Nothing)
-> IO [(Text, Attribute)] -> IO (Resource 'Nothing)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(Text, Attribute)]
detectResourceAttributes
let allRs :: Resource (ResourceMerge 'Nothing any)
allRs = Resource 'Nothing
-> Resource any -> Resource (ResourceMerge 'Nothing any)
forall (old :: Maybe Symbol) (new :: Maybe Symbol).
Resource old -> Resource new -> Resource (ResourceMerge old new)
mergeResources (Resource 'Nothing
builtInRs Resource 'Nothing -> Resource 'Nothing -> Resource 'Nothing
forall a. Semigroup a => a -> a -> a
<> Resource 'Nothing
envVarRs) Resource any
rs
[SpanProcessor]
processors <- case [SpanExporter]
exporters of
[] -> do
[SpanProcessor] -> IO [SpanProcessor]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
SpanExporter
e : [SpanExporter]
_ -> do
SpanProcessor -> [SpanProcessor]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SpanProcessor -> [SpanProcessor])
-> IO SpanProcessor -> IO [SpanProcessor]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BatchTimeoutConfig -> SpanExporter -> IO SpanProcessor
forall (m :: * -> *).
MonadIO m =>
BatchTimeoutConfig -> SpanExporter -> m SpanProcessor
batchProcessor BatchTimeoutConfig
processorConf SpanExporter
e
let providerOpts :: TracerProviderOptions
providerOpts =
TracerProviderOptions
emptyTracerProviderOptions
{ tracerProviderOptionsIdGenerator = defaultIdGenerator
, tracerProviderOptionsSampler = sampler
, tracerProviderOptionsAttributeLimits = attrLimits
, tracerProviderOptionsSpanLimits = spanLimits
, tracerProviderOptionsPropagators = propagators
, tracerProviderOptionsResources = materializeResources allRs
}
([SpanProcessor], TracerProviderOptions)
-> IO ([SpanProcessor], TracerProviderOptions)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([SpanProcessor]
processors, TracerProviderOptions
providerOpts)
detectPropagators :: IO (Propagator Context RequestHeaders ResponseHeaders)
detectPropagators :: IO (Propagator Context RequestHeaders RequestHeaders)
detectPropagators = do
[(Text, Propagator Context RequestHeaders RequestHeaders)]
registeredPropagators <- IO [(Text, Propagator Context RequestHeaders RequestHeaders)]
readRegisteredPropagators
Maybe [Text]
propagatorsInEnv <- ([Char] -> [Text]) -> Maybe [Char] -> Maybe [Text]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"," (Text -> [Text]) -> ([Char] -> Text) -> [Char] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack) (Maybe [Char] -> Maybe [Text])
-> IO (Maybe [Char]) -> IO (Maybe [Text])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"OTEL_PROPAGATORS"
if Maybe [Text]
propagatorsInEnv Maybe [Text] -> Maybe [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just [Text
"none"]
then Propagator Context RequestHeaders RequestHeaders
-> IO (Propagator Context RequestHeaders RequestHeaders)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Propagator Context RequestHeaders RequestHeaders
forall a. Monoid a => a
mempty
else do
let envPropagators :: [Text]
envPropagators = [Text] -> Maybe [Text] -> [Text]
forall a. a -> Maybe a -> a
fromMaybe [Text
"tracecontext", Text
"baggage"] Maybe [Text]
propagatorsInEnv
propagatorsAndRegistryEntry :: [Either Text (Propagator Context RequestHeaders RequestHeaders)]
propagatorsAndRegistryEntry = (Text
-> Either Text (Propagator Context RequestHeaders RequestHeaders))
-> [Text]
-> [Either Text (Propagator Context RequestHeaders RequestHeaders)]
forall a b. (a -> b) -> [a] -> [b]
map (\Text
k -> Either Text (Propagator Context RequestHeaders RequestHeaders)
-> (Propagator Context RequestHeaders RequestHeaders
-> Either Text (Propagator Context RequestHeaders RequestHeaders))
-> Maybe (Propagator Context RequestHeaders RequestHeaders)
-> Either Text (Propagator Context RequestHeaders RequestHeaders)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text
-> Either Text (Propagator Context RequestHeaders RequestHeaders)
forall a b. a -> Either a b
Left Text
k) Propagator Context RequestHeaders RequestHeaders
-> Either Text (Propagator Context RequestHeaders RequestHeaders)
forall a b. b -> Either a b
Right (Maybe (Propagator Context RequestHeaders RequestHeaders)
-> Either Text (Propagator Context RequestHeaders RequestHeaders))
-> Maybe (Propagator Context RequestHeaders RequestHeaders)
-> Either Text (Propagator Context RequestHeaders RequestHeaders)
forall a b. (a -> b) -> a -> b
$ Text
-> [(Text, Propagator Context RequestHeaders RequestHeaders)]
-> Maybe (Propagator Context RequestHeaders RequestHeaders)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
k [(Text, Propagator Context RequestHeaders RequestHeaders)]
registeredPropagators) [Text]
envPropagators
([Text]
_notFound, [Propagator Context RequestHeaders RequestHeaders]
propagators) = [Either Text (Propagator Context RequestHeaders RequestHeaders)]
-> ([Text], [Propagator Context RequestHeaders RequestHeaders])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either Text (Propagator Context RequestHeaders RequestHeaders)]
propagatorsAndRegistryEntry
Propagator Context RequestHeaders RequestHeaders
-> IO (Propagator Context RequestHeaders RequestHeaders)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Propagator Context RequestHeaders RequestHeaders
-> IO (Propagator Context RequestHeaders RequestHeaders))
-> Propagator Context RequestHeaders RequestHeaders
-> IO (Propagator Context RequestHeaders RequestHeaders)
forall a b. (a -> b) -> a -> b
$ [Propagator Context RequestHeaders RequestHeaders]
-> Propagator Context RequestHeaders RequestHeaders
forall a. Monoid a => [a] -> a
mconcat [Propagator Context RequestHeaders RequestHeaders]
propagators
knownSamplers :: [(T.Text, Maybe T.Text -> Maybe Sampler)]
knownSamplers :: [(Text, Maybe Text -> Maybe Sampler)]
knownSamplers =
[ (Text
"always_on", Maybe Sampler -> Maybe Text -> Maybe Sampler
forall a b. a -> b -> a
const (Maybe Sampler -> Maybe Text -> Maybe Sampler)
-> Maybe Sampler -> Maybe Text -> Maybe Sampler
forall a b. (a -> b) -> a -> b
$ Sampler -> Maybe Sampler
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sampler
alwaysOn)
, (Text
"always_off", Maybe Sampler -> Maybe Text -> Maybe Sampler
forall a b. a -> b -> a
const (Maybe Sampler -> Maybe Text -> Maybe Sampler)
-> Maybe Sampler -> Maybe Text -> Maybe Sampler
forall a b. (a -> b) -> a -> b
$ Sampler -> Maybe Sampler
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sampler
alwaysOff)
,
( Text
"traceidratio"
, \case
Maybe Text
Nothing -> Maybe Sampler
forall a. Maybe a
Nothing
Just Text
val -> case [Char] -> Maybe Double
forall a. Read a => [Char] -> Maybe a
readMaybe (Text -> [Char]
T.unpack Text
val) of
Maybe Double
Nothing -> Maybe Sampler
forall a. Maybe a
Nothing
Just Double
ratioVal -> Sampler -> Maybe Sampler
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sampler -> Maybe Sampler) -> Sampler -> Maybe Sampler
forall a b. (a -> b) -> a -> b
$ Double -> Sampler
traceIdRatioBased Double
ratioVal
)
, (Text
"parentbased_always_on", Maybe Sampler -> Maybe Text -> Maybe Sampler
forall a b. a -> b -> a
const (Maybe Sampler -> Maybe Text -> Maybe Sampler)
-> Maybe Sampler -> Maybe Text -> Maybe Sampler
forall a b. (a -> b) -> a -> b
$ Sampler -> Maybe Sampler
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sampler -> Maybe Sampler) -> Sampler -> Maybe Sampler
forall a b. (a -> b) -> a -> b
$ ParentBasedOptions -> Sampler
parentBased (ParentBasedOptions -> Sampler) -> ParentBasedOptions -> Sampler
forall a b. (a -> b) -> a -> b
$ Sampler -> ParentBasedOptions
parentBasedOptions Sampler
alwaysOn)
, (Text
"parentbased_always_off", Maybe Sampler -> Maybe Text -> Maybe Sampler
forall a b. a -> b -> a
const (Maybe Sampler -> Maybe Text -> Maybe Sampler)
-> Maybe Sampler -> Maybe Text -> Maybe Sampler
forall a b. (a -> b) -> a -> b
$ Sampler -> Maybe Sampler
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sampler -> Maybe Sampler) -> Sampler -> Maybe Sampler
forall a b. (a -> b) -> a -> b
$ ParentBasedOptions -> Sampler
parentBased (ParentBasedOptions -> Sampler) -> ParentBasedOptions -> Sampler
forall a b. (a -> b) -> a -> b
$ Sampler -> ParentBasedOptions
parentBasedOptions Sampler
alwaysOff)
,
( Text
"parentbased_traceidratio"
, \case
Maybe Text
Nothing -> Maybe Sampler
forall a. Maybe a
Nothing
Just Text
val -> case [Char] -> Maybe Double
forall a. Read a => [Char] -> Maybe a
readMaybe (Text -> [Char]
T.unpack Text
val) of
Maybe Double
Nothing -> Maybe Sampler
forall a. Maybe a
Nothing
Just Double
ratioVal -> Sampler -> Maybe Sampler
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sampler -> Maybe Sampler) -> Sampler -> Maybe Sampler
forall a b. (a -> b) -> a -> b
$ ParentBasedOptions -> Sampler
parentBased (ParentBasedOptions -> Sampler) -> ParentBasedOptions -> Sampler
forall a b. (a -> b) -> a -> b
$ Sampler -> ParentBasedOptions
parentBasedOptions (Sampler -> ParentBasedOptions) -> Sampler -> ParentBasedOptions
forall a b. (a -> b) -> a -> b
$ Double -> Sampler
traceIdRatioBased Double
ratioVal
)
]
detectSampler :: IO Sampler
detectSampler :: IO Sampler
detectSampler = do
Maybe [Char]
envSampler <- [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"OTEL_TRACES_SAMPLER"
Maybe [Char]
envArg <- [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"OTEL_TRACES_SAMPLER_ARG"
let sampler :: Sampler
sampler = Sampler -> Maybe Sampler -> Sampler
forall a. a -> Maybe a -> a
fromMaybe (ParentBasedOptions -> Sampler
parentBased (ParentBasedOptions -> Sampler) -> ParentBasedOptions -> Sampler
forall a b. (a -> b) -> a -> b
$ Sampler -> ParentBasedOptions
parentBasedOptions Sampler
alwaysOn) (Maybe Sampler -> Sampler) -> Maybe Sampler -> Sampler
forall a b. (a -> b) -> a -> b
$ do
[Char]
samplerName <- Maybe [Char]
envSampler
Maybe Text -> Maybe Sampler
samplerConstructor <- Text
-> [(Text, Maybe Text -> Maybe Sampler)]
-> Maybe (Maybe Text -> Maybe Sampler)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ([Char] -> Text
T.pack [Char]
samplerName) [(Text, Maybe Text -> Maybe Sampler)]
knownSamplers
Maybe Text -> Maybe Sampler
samplerConstructor ([Char] -> Text
T.pack ([Char] -> Text) -> Maybe [Char] -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [Char]
envArg)
Sampler -> IO Sampler
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sampler
sampler
detectBatchProcessorConfig :: IO BatchTimeoutConfig
detectBatchProcessorConfig :: IO BatchTimeoutConfig
detectBatchProcessorConfig =
Int -> Int -> Int -> Int -> BatchTimeoutConfig
BatchTimeoutConfig
(Int -> Int -> Int -> Int -> BatchTimeoutConfig)
-> IO Int -> IO (Int -> Int -> Int -> BatchTimeoutConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Int -> IO Int
forall a. Read a => [Char] -> a -> IO a
readEnvDefault [Char]
"OTEL_BSP_MAX_QUEUE_SIZE" (BatchTimeoutConfig -> Int
maxQueueSize BatchTimeoutConfig
batchTimeoutConfig)
IO (Int -> Int -> Int -> BatchTimeoutConfig)
-> IO Int -> IO (Int -> Int -> BatchTimeoutConfig)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> Int -> IO Int
forall a. Read a => [Char] -> a -> IO a
readEnvDefault [Char]
"OTEL_BSP_SCHEDULE_DELAY" (BatchTimeoutConfig -> Int
scheduledDelayMillis BatchTimeoutConfig
batchTimeoutConfig)
IO (Int -> Int -> BatchTimeoutConfig)
-> IO Int -> IO (Int -> BatchTimeoutConfig)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> Int -> IO Int
forall a. Read a => [Char] -> a -> IO a
readEnvDefault [Char]
"OTEL_BSP_EXPORT_TIMEOUT" (BatchTimeoutConfig -> Int
exportTimeoutMillis BatchTimeoutConfig
batchTimeoutConfig)
IO (Int -> BatchTimeoutConfig) -> IO Int -> IO BatchTimeoutConfig
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> Int -> IO Int
forall a. Read a => [Char] -> a -> IO a
readEnvDefault [Char]
"OTEL_BSP_MAX_EXPORT_BATCH_SIZE" (BatchTimeoutConfig -> Int
maxExportBatchSize BatchTimeoutConfig
batchTimeoutConfig)
detectAttributeLimits :: IO AttributeLimits
detectAttributeLimits :: IO AttributeLimits
detectAttributeLimits =
Maybe Int -> Maybe Int -> AttributeLimits
AttributeLimits
(Maybe Int -> Maybe Int -> AttributeLimits)
-> IO (Maybe Int) -> IO (Maybe Int -> AttributeLimits)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Maybe Int -> IO (Maybe Int)
forall a. Read a => [Char] -> a -> IO a
readEnvDefault [Char]
"OTEL_ATTRIBUTE_COUNT_LIMIT" (AttributeLimits -> Maybe Int
attributeCountLimit AttributeLimits
defaultAttributeLimits)
IO (Maybe Int -> AttributeLimits)
-> IO (Maybe Int) -> IO AttributeLimits
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Maybe [Char] -> ([Char] -> Maybe Int) -> Maybe Int
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> Maybe Int
forall a. Read a => [Char] -> Maybe a
readMaybe) (Maybe [Char] -> Maybe Int) -> IO (Maybe [Char]) -> IO (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"OTEL_ATTRIBUTE_VALUE_LENGTH_LIMIT")
detectSpanLimits :: IO SpanLimits
detectSpanLimits :: IO SpanLimits
detectSpanLimits =
Maybe Int
-> Maybe Int
-> Maybe Int
-> Maybe Int
-> Maybe Int
-> Maybe Int
-> SpanLimits
SpanLimits
(Maybe Int
-> Maybe Int
-> Maybe Int
-> Maybe Int
-> Maybe Int
-> Maybe Int
-> SpanLimits)
-> IO (Maybe Int)
-> IO
(Maybe Int
-> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> SpanLimits)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe Int)
forall a. Read a => [Char] -> IO (Maybe a)
readEnv [Char]
"OTEL_SPAN_ATTRIBUTE_VALUE_LENGTH_LIMIT"
IO
(Maybe Int
-> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> SpanLimits)
-> IO (Maybe Int)
-> IO
(Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> SpanLimits)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> IO (Maybe Int)
forall a. Read a => [Char] -> IO (Maybe a)
readEnv [Char]
"OTEL_SPAN_ATTRIBUTE_COUNT_LIMIT"
IO (Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> SpanLimits)
-> IO (Maybe Int)
-> IO (Maybe Int -> Maybe Int -> Maybe Int -> SpanLimits)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> IO (Maybe Int)
forall a. Read a => [Char] -> IO (Maybe a)
readEnv [Char]
"OTEL_SPAN_EVENT_COUNT_LIMIT"
IO (Maybe Int -> Maybe Int -> Maybe Int -> SpanLimits)
-> IO (Maybe Int) -> IO (Maybe Int -> Maybe Int -> SpanLimits)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> IO (Maybe Int)
forall a. Read a => [Char] -> IO (Maybe a)
readEnv [Char]
"OTEL_SPAN_LINK_COUNT_LIMIT"
IO (Maybe Int -> Maybe Int -> SpanLimits)
-> IO (Maybe Int) -> IO (Maybe Int -> SpanLimits)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> IO (Maybe Int)
forall a. Read a => [Char] -> IO (Maybe a)
readEnv [Char]
"OTEL_EVENT_ATTRIBUTE_COUNT_LIMIT"
IO (Maybe Int -> SpanLimits) -> IO (Maybe Int) -> IO SpanLimits
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> IO (Maybe Int)
forall a. Read a => [Char] -> IO (Maybe a)
readEnv [Char]
"OTEL_LINK_ATTRIBUTE_COUNT_LIMIT"
knownExporters :: [(T.Text, IO SpanExporter)]
knownExporters :: [(Text, IO SpanExporter)]
knownExporters =
[
( Text
"otlp"
, do
OTLPExporterConfig
otlpConfig <- IO OTLPExporterConfig
forall (m :: * -> *). MonadIO m => m OTLPExporterConfig
loadExporterEnvironmentVariables
OTLPExporterConfig -> IO SpanExporter
forall (m :: * -> *).
MonadIO m =>
OTLPExporterConfig -> m SpanExporter
otlpExporter OTLPExporterConfig
otlpConfig
)
, (Text
"jaeger", [Char] -> IO SpanExporter
forall a. HasCallStack => [Char] -> a
error [Char]
"Jaeger exporter not implemented")
, (Text
"zipkin", [Char] -> IO SpanExporter
forall a. HasCallStack => [Char] -> a
error [Char]
"Zipkin exporter not implemented")
]
detectExporters :: IO [SpanExporter]
detectExporters :: IO [SpanExporter]
detectExporters = do
Maybe [Text]
exportersInEnv <- ([Char] -> [Text]) -> Maybe [Char] -> Maybe [Text]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"," (Text -> [Text]) -> ([Char] -> Text) -> [Char] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack) (Maybe [Char] -> Maybe [Text])
-> IO (Maybe [Char]) -> IO (Maybe [Text])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"OTEL_TRACES_EXPORTER"
if Maybe [Text]
exportersInEnv Maybe [Text] -> Maybe [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just [Text
"none"]
then [SpanExporter] -> IO [SpanExporter]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
else do
let envExporters :: [Text]
envExporters = [Text] -> Maybe [Text] -> [Text]
forall a. a -> Maybe a -> a
fromMaybe [Text
"otlp"] Maybe [Text]
exportersInEnv
exportersAndRegistryEntry :: [Either Text (IO SpanExporter)]
exportersAndRegistryEntry = (Text -> Either Text (IO SpanExporter))
-> [Text] -> [Either Text (IO SpanExporter)]
forall a b. (a -> b) -> [a] -> [b]
map (\Text
k -> Either Text (IO SpanExporter)
-> (IO SpanExporter -> Either Text (IO SpanExporter))
-> Maybe (IO SpanExporter)
-> Either Text (IO SpanExporter)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text (IO SpanExporter)
forall a b. a -> Either a b
Left Text
k) IO SpanExporter -> Either Text (IO SpanExporter)
forall a b. b -> Either a b
Right (Maybe (IO SpanExporter) -> Either Text (IO SpanExporter))
-> Maybe (IO SpanExporter) -> Either Text (IO SpanExporter)
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, IO SpanExporter)] -> Maybe (IO SpanExporter)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
k [(Text, IO SpanExporter)]
knownExporters) [Text]
envExporters
([Text]
_notFound, [IO SpanExporter]
exporterIntializers) = [Either Text (IO SpanExporter)] -> ([Text], [IO SpanExporter])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either Text (IO SpanExporter)]
exportersAndRegistryEntry
[IO SpanExporter] -> IO [SpanExporter]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [IO SpanExporter]
exporterIntializers
detectResourceAttributes :: IO [(T.Text, Attribute)]
detectResourceAttributes :: IO [(Text, Attribute)]
detectResourceAttributes = do
Maybe [Char]
mEnv <- [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"OTEL_RESOURCE_ATTRIBUTES"
case Maybe [Char]
mEnv of
Maybe [Char]
Nothing -> [(Text, Attribute)] -> IO [(Text, Attribute)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
Just [Char]
envVar -> case ByteString -> Either [Char] Baggage
decodeBaggageHeader (ByteString -> Either [Char] Baggage)
-> ByteString -> Either [Char] Baggage
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
B.pack [Char]
envVar of
Left [Char]
err -> do
[Char] -> IO ()
putStrLn [Char]
err
[(Text, Attribute)] -> IO [(Text, Attribute)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
Right Baggage
ok ->
[(Text, Attribute)] -> IO [(Text, Attribute)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Text, Attribute)] -> IO [(Text, Attribute)])
-> [(Text, Attribute)] -> IO [(Text, Attribute)]
forall a b. (a -> b) -> a -> b
$
((Token, Element) -> (Text, Attribute))
-> [(Token, Element)] -> [(Text, Attribute)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Token
k, Element
v) -> (ByteString -> Text
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Token -> ByteString
Baggage.tokenValue Token
k, Text -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ Element -> Text
Baggage.value Element
v)) ([(Token, Element)] -> [(Text, Attribute)])
-> [(Token, Element)] -> [(Text, Attribute)]
forall a b. (a -> b) -> a -> b
$
HashMap Token Element -> [(Token, Element)]
forall k v. HashMap k v -> [(k, v)]
H.toList (HashMap Token Element -> [(Token, Element)])
-> HashMap Token Element -> [(Token, Element)]
forall a b. (a -> b) -> a -> b
$
Baggage -> HashMap Token Element
Baggage.values Baggage
ok
readEnvDefault :: forall a. (Read a) => String -> a -> IO a
readEnvDefault :: forall a. Read a => [Char] -> a -> IO a
readEnvDefault [Char]
k a
defaultValue =
a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
defaultValue (Maybe a -> a) -> (Maybe [Char] -> Maybe a) -> Maybe [Char] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe [Char] -> ([Char] -> Maybe a) -> Maybe a
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> Maybe a
forall a. Read a => [Char] -> Maybe a
readMaybe) (Maybe [Char] -> a) -> IO (Maybe [Char]) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
k
readEnv :: forall a. (Read a) => String -> IO (Maybe a)
readEnv :: forall a. Read a => [Char] -> IO (Maybe a)
readEnv [Char]
k = (Maybe [Char] -> ([Char] -> Maybe a) -> Maybe a
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> Maybe a
forall a. Read a => [Char] -> Maybe a
readMaybe) (Maybe [Char] -> Maybe a) -> IO (Maybe [Char]) -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
k
detectBuiltInResources :: IO (Resource 'Nothing)
detectBuiltInResources :: IO (Resource 'Nothing)
detectBuiltInResources = do
Service
svc <- IO Service
detectService
Process
processInfo <- IO Process
detectProcess
OperatingSystem
osInfo <- IO OperatingSystem
detectOperatingSystem
Host
host <- IO Host
detectHost
let rs :: Resource
(ResourceMerge
(ResourceMerge
(ResourceMerge
(ResourceMerge (ResourceMerge 'Nothing 'Nothing) 'Nothing)
'Nothing)
'Nothing)
'Nothing)
rs =
Service -> Resource (ResourceSchema Service)
forall a. ToResource a => a -> Resource (ResourceSchema a)
toResource Service
svc
Resource 'Nothing
-> Resource 'Nothing -> Resource (ResourceMerge 'Nothing 'Nothing)
forall (old :: Maybe Symbol) (new :: Maybe Symbol).
Resource old -> Resource new -> Resource (ResourceMerge old new)
`mergeResources` Telemetry -> Resource (ResourceSchema Telemetry)
forall a. ToResource a => a -> Resource (ResourceSchema a)
toResource Telemetry
detectTelemetry
Resource (ResourceMerge 'Nothing 'Nothing)
-> Resource 'Nothing
-> Resource
(ResourceMerge (ResourceMerge 'Nothing 'Nothing) 'Nothing)
forall (old :: Maybe Symbol) (new :: Maybe Symbol).
Resource old -> Resource new -> Resource (ResourceMerge old new)
`mergeResources` ProcessRuntime -> Resource (ResourceSchema ProcessRuntime)
forall a. ToResource a => a -> Resource (ResourceSchema a)
toResource ProcessRuntime
detectProcessRuntime
Resource (ResourceMerge (ResourceMerge 'Nothing 'Nothing) 'Nothing)
-> Resource 'Nothing
-> Resource
(ResourceMerge
(ResourceMerge (ResourceMerge 'Nothing 'Nothing) 'Nothing)
'Nothing)
forall (old :: Maybe Symbol) (new :: Maybe Symbol).
Resource old -> Resource new -> Resource (ResourceMerge old new)
`mergeResources` Process -> Resource (ResourceSchema Process)
forall a. ToResource a => a -> Resource (ResourceSchema a)
toResource Process
processInfo
Resource
(ResourceMerge
(ResourceMerge (ResourceMerge 'Nothing 'Nothing) 'Nothing)
'Nothing)
-> Resource 'Nothing
-> Resource
(ResourceMerge
(ResourceMerge
(ResourceMerge (ResourceMerge 'Nothing 'Nothing) 'Nothing)
'Nothing)
'Nothing)
forall (old :: Maybe Symbol) (new :: Maybe Symbol).
Resource old -> Resource new -> Resource (ResourceMerge old new)
`mergeResources` OperatingSystem -> Resource (ResourceSchema OperatingSystem)
forall a. ToResource a => a -> Resource (ResourceSchema a)
toResource OperatingSystem
osInfo
Resource
(ResourceMerge
(ResourceMerge
(ResourceMerge (ResourceMerge 'Nothing 'Nothing) 'Nothing)
'Nothing)
'Nothing)
-> Resource 'Nothing
-> Resource
(ResourceMerge
(ResourceMerge
(ResourceMerge
(ResourceMerge (ResourceMerge 'Nothing 'Nothing) 'Nothing)
'Nothing)
'Nothing)
'Nothing)
forall (old :: Maybe Symbol) (new :: Maybe Symbol).
Resource old -> Resource new -> Resource (ResourceMerge old new)
`mergeResources` Host -> Resource (ResourceSchema Host)
forall a. ToResource a => a -> Resource (ResourceSchema a)
toResource Host
host
Resource 'Nothing -> IO (Resource 'Nothing)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Resource 'Nothing
Resource
(ResourceMerge
(ResourceMerge
(ResourceMerge
(ResourceMerge (ResourceMerge 'Nothing 'Nothing) 'Nothing)
'Nothing)
'Nothing)
'Nothing)
rs