{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DataKinds #-}
module OpenTelemetry.Trace 
  ( 
  -- * 'TracerProvider' operations
    TracerProvider
  , initializeGlobalTracerProvider
  , initializeTracerProvider
  , getTracerProviderInitializationOptions
  , shutdownTracerProvider
  -- ** Getting / setting the global 'TracerProvider'
  , getGlobalTracerProvider
  , setGlobalTracerProvider
  -- ** Alternative 'TracerProvider' initialization
  , createTracerProvider
  , TracerProviderOptions(..)
  , emptyTracerProviderOptions
  , detectBuiltInResources
  -- * 'Tracer' operations
  , Tracer
  , tracerName
  , getTracer
  , TracerOptions(..)
  , tracerOptions
  , HasTracer(..)
  , InstrumentationLibrary(..)
  -- * 'Span' operations
  , Span
  , createSpan
  , createSpanWithoutCallStack
  , defaultSpanArguments
  , SpanArguments(..)
  , updateName
  , addAttribute 
  , addAttributes
  , spanGetAttributes
  , ToAttribute(..)
  , ToPrimitiveAttribute(..)
  , Attribute(..)
  , PrimitiveAttribute(..)
  , SpanKind(..)
  , Link(..)
  , Event
  , NewEvent(..)
  , addEvent
  , recordException
  , setStatus
  , SpanStatus(..)
  , SpanContext(..)
  , endSpan
  -- TODO, don't remember if this is okay with the spec or not
  , ImmutableSpan(..)
  ) where

import OpenTelemetry.Trace.Core
import OpenTelemetry.Resource
import Data.Maybe (fromMaybe)
import Data.Either (partitionEithers)
import qualified Data.Text as T
import OpenTelemetry.Context (Context)
import Network.HTTP.Types.Header
import OpenTelemetry.Propagator.W3CTraceContext (w3cTraceContextPropagator)
import OpenTelemetry.Propagator.W3CBaggage (w3cBaggagePropagator)
import OpenTelemetry.Propagator (Propagator)
import System.Environment (lookupEnv)
import OpenTelemetry.Trace.Sampler (Sampler, alwaysOn, alwaysOff, traceIdRatioBased, parentBased, parentBasedOptions)
import Text.Read (readMaybe)
import OpenTelemetry.Exporter (Exporter)
import OpenTelemetry.Processor.Batch (BatchTimeoutConfig (..), batchTimeoutConfig, batchProcessor)
import OpenTelemetry.Attributes (AttributeLimits(..), defaultAttributeLimits)
import OpenTelemetry.Baggage (decodeBaggageHeader)
import qualified Data.ByteString.Char8 as B
import qualified OpenTelemetry.Baggage as Baggage
import qualified Data.HashMap.Strict as H
import Data.Text.Encoding (decodeUtf8)
import OpenTelemetry.Exporter.OTLP (loadExporterEnvironmentVariables, otlpExporter)
import OpenTelemetry.Processor (Processor)
import OpenTelemetry.Resource.Service.Detector (detectService)
import OpenTelemetry.Resource.Process.Detector (detectProcess, detectProcessRuntime)
import OpenTelemetry.Resource.OperatingSystem.Detector (detectOperatingSystem)
import OpenTelemetry.Resource.Host.Detector (detectHost)
import OpenTelemetry.Resource.Telemetry.Detector (detectTelemetry)
import OpenTelemetry.Trace.Id.Generator.Default (defaultIdGenerator)

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", [Char] -> Propagator Context RequestHeaders RequestHeaders
forall a. HasCallStack => [Char] -> a
error [Char]
"B3 not yet implemented")
  , (Text
"b3multi", [Char] -> Propagator Context RequestHeaders RequestHeaders
forall a. HasCallStack => [Char] -> a
error [Char]
"B3 multi not yet implemented")
  , (Text
"jaeger", [Char] -> Propagator Context RequestHeaders RequestHeaders
forall a. HasCallStack => [Char] -> a
error [Char]
"Jaeger not yet implemented")
  ]

-- TODO, actually implement a registry systme
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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure TracerProvider
t

initializeTracerProvider :: IO TracerProvider
initializeTracerProvider :: IO TracerProvider
initializeTracerProvider = do
  ([Processor]
processors, TracerProviderOptions
opts) <- IO ([Processor], TracerProviderOptions)
getTracerProviderInitializationOptions
  [Processor] -> TracerProviderOptions -> IO TracerProvider
forall (m :: * -> *).
MonadIO m =>
[Processor] -> TracerProviderOptions -> m TracerProvider
createTracerProvider [Processor]
processors TracerProviderOptions
opts

getTracerProviderInitializationOptions :: IO ([Processor], TracerProviderOptions)
getTracerProviderInitializationOptions :: IO ([Processor], TracerProviderOptions)
getTracerProviderInitializationOptions  = 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
  [Exporter]
exporters <- IO [Exporter]
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 'Nothing
allRs = Resource 'Nothing
builtInRs Resource 'Nothing -> Resource 'Nothing -> Resource 'Nothing
forall a. Semigroup a => a -> a -> a
<> Resource 'Nothing
envVarRs
  [Processor]
processors <- case [Exporter]
exporters of
    [] -> do
      [Processor] -> IO [Processor]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Exporter
e:[Exporter]
_ -> do
      Processor -> [Processor]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Processor -> [Processor]) -> IO Processor -> IO [Processor]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BatchTimeoutConfig -> Exporter -> IO Processor
forall (m :: * -> *).
MonadIO m =>
BatchTimeoutConfig -> Exporter -> m Processor
batchProcessor BatchTimeoutConfig
processorConf Exporter
e
  let providerOpts :: TracerProviderOptions
providerOpts = TracerProviderOptions
emptyTracerProviderOptions
        { tracerProviderOptionsIdGenerator :: IdGenerator
tracerProviderOptionsIdGenerator = IdGenerator
defaultIdGenerator
        , tracerProviderOptionsSampler :: Sampler
tracerProviderOptionsSampler = Sampler
sampler
        , tracerProviderOptionsAttributeLimits :: AttributeLimits
tracerProviderOptionsAttributeLimits = AttributeLimits
attrLimits
        , tracerProviderOptionsSpanLimits :: SpanLimits
tracerProviderOptionsSpanLimits = SpanLimits
spanLimits
        , tracerProviderOptionsPropagators :: Propagator Context RequestHeaders RequestHeaders
tracerProviderOptionsPropagators = Propagator Context RequestHeaders RequestHeaders
propagators
        , tracerProviderOptionsResources :: MaterializedResources
tracerProviderOptionsResources = Resource 'Nothing -> MaterializedResources
forall (schema :: Maybe Symbol).
MaterializeResource schema =>
Resource schema -> MaterializedResources
materializeResources Resource 'Nothing
allRs
        }
  ([Processor], TracerProviderOptions)
-> IO ([Processor], TracerProviderOptions)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Processor]
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 (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
      -- TODO log warn notFound
      Propagator Context RequestHeaders RequestHeaders
-> IO (Propagator Context RequestHeaders RequestHeaders)
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 (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 (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 (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 (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 (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 (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
  )
  ]

-- TODO MUST log invalid arg
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 (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 (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 (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 (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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Maybe [Char] -> ([Char] -> Maybe Int) -> Maybe Int
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 (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 (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 (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 (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 (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 Exporter)]
knownExporters :: [(Text, IO Exporter)]
knownExporters =
  [ (Text
"otlp", do
      OTLPExporterConfig
otlpConfig <- IO OTLPExporterConfig
forall (m :: * -> *). MonadIO m => m OTLPExporterConfig
loadExporterEnvironmentVariables
      OTLPExporterConfig -> IO Exporter
forall (m :: * -> *). MonadIO m => OTLPExporterConfig -> m Exporter
otlpExporter OTLPExporterConfig
otlpConfig
    )
  , (Text
"jaeger", [Char] -> IO Exporter
forall a. HasCallStack => [Char] -> a
error [Char]
"Jaeger exporter not implemented")
  , (Text
"zipkin", [Char] -> IO Exporter
forall a. HasCallStack => [Char] -> a
error [Char]
"Zipkin exporter not implemented")
  ]

-- TODO, rename Exporter to Exporter
-- TODO, support multiple exporters
detectExporters :: IO [Exporter]
detectExporters :: IO [Exporter]
detectExporters = do
  Maybe [Text]
exportersInEnv <- ([Char] -> [Text]) -> Maybe [Char] -> Maybe [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 [Exporter] -> IO [Exporter]
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 Exporter)]
exportersAndRegistryEntry = (Text -> Either Text (IO Exporter))
-> [Text] -> [Either Text (IO Exporter)]
forall a b. (a -> b) -> [a] -> [b]
map (\Text
k -> Either Text (IO Exporter)
-> (IO Exporter -> Either Text (IO Exporter))
-> Maybe (IO Exporter)
-> Either Text (IO Exporter)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text (IO Exporter)
forall a b. a -> Either a b
Left Text
k) IO Exporter -> Either Text (IO Exporter)
forall a b. b -> Either a b
Right (Maybe (IO Exporter) -> Either Text (IO Exporter))
-> Maybe (IO Exporter) -> Either Text (IO Exporter)
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, IO Exporter)] -> Maybe (IO Exporter)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
k [(Text, IO Exporter)]
knownExporters) [Text]
envExporters
          ([Text]
_notFound, [IO Exporter]
exporterIntializers) = [Either Text (IO Exporter)] -> ([Text], [IO Exporter])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either Text (IO Exporter)]
exportersAndRegistryEntry
      -- TODO, notFound logging
      [IO Exporter] -> IO [Exporter]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [IO Exporter]
exporterIntializers

    -- -- detectMetricsExporterSelection :: _
    -- -- TODO other metrics stuff

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 (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
        -- TODO logError
        [Char] -> IO ()
putStrLn [Char]
err
        [(Text, Attribute)] -> IO [(Text, Attribute)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      Right Baggage
ok ->
        [(Text, Attribute)] -> IO [(Text, Attribute)]
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 :: [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 (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 :: [Char] -> IO (Maybe a)
readEnv [Char]
k = (Maybe [Char] -> ([Char] -> Maybe a) -> Maybe a
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 '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 'Nothing
-> Resource 'Nothing -> Resource (ResourceMerge '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 'Nothing
-> Resource 'Nothing -> Resource (ResourceMerge '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 'Nothing
-> Resource 'Nothing -> Resource (ResourceMerge '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 'Nothing
-> Resource 'Nothing -> Resource (ResourceMerge '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 (f :: * -> *) a. Applicative f => a -> f a
pure Resource 'Nothing
rs