{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

{- |
Module      :  OpenTelemetry.Propagator
Copyright   :  (c) Ian Duncan, 2021-2026
License     :  BSD-3
Description :  Context propagation across process boundaries
Stability   :  experimental

= Overview

Propagators serialize and deserialize 'Context' (trace state and baggage)
into carrier formats like HTTP headers. This is how distributed tracing
works across service boundaries.

= Built-in propagators

The SDK registers these propagators automatically:

* __W3C TraceContext__ (@traceparent@ header) -- default
* __W3C Baggage__ (@baggage@ header) -- default
* __B3__ (Zipkin single and multi-header)
* __Jaeger__ (@uber-trace-id@ header)
* __Datadog__ (@x-datadog-trace-id@ headers)
* __AWS X-Ray__ (@X-Amzn-Trace-Id@ header)

Configure via @OTEL_PROPAGATORS@:

> export OTEL_PROPAGATORS=tracecontext,baggage,b3

= Usage in instrumentation

If you are writing instrumentation for a transport (HTTP, gRPC, messaging),
use the global propagator to inject\/extract context:

@
import OpenTelemetry.Propagator
import OpenTelemetry.Context.ThreadLocal

-- Injecting (outbound request):
propagator <- getGlobalTextMapPropagator
ctx <- getContext
headers <- inject propagator ctx request

-- Extracting (inbound request):
propagator <- getGlobalTextMapPropagator
ctx <- extract propagator request =<< getContext
tok <- attachContext ctx
-- ... later, restore previous context:
detachContext tok
@

= Custom propagators

Implement the 'Propagator' record with 'propagatorFields', 'extractor',
and 'injector' fields. Propagators are composable via their 'Monoid'
instance (extracts and injects run in sequence).

= Spec reference

<https://opentelemetry.io/docs/specs/otel/context/api-propagators/>
-}
module OpenTelemetry.Propagator (
  -- * Propagator
  Propagator (..),
  propagatorNames,
  extract,
  inject,

  -- * TextMap carrier
  TextMap,
  emptyTextMap,
  textMapInsert,
  textMapLookup,
  textMapDelete,
  textMapKeys,
  textMapToList,
  textMapFromList,

  -- * TextMapPropagator
  TextMapPropagator,

  -- * Global TextMapPropagator
  getGlobalTextMapPropagator,
  setGlobalTextMapPropagator,
) where

import Control.Exception (SomeException, catch)
import Control.Monad.IO.Class
import qualified Data.HashMap.Strict as H
import Data.IORef
import qualified Data.List as List
import Data.Text (Text)
import qualified Data.Text as T
import OpenTelemetry.Context.Types (Context)
import OpenTelemetry.Internal.Logging (otelLogWarning)
import System.IO.Unsafe (unsafePerformIO)


{- |
A carrier is the medium used by Propagators to read values from and write values to.
Each specific Propagator type defines its expected carrier type, such as a string map or a byte array.

@since 0.0.1.0
-}
data Propagator context inboundCarrier outboundCarrier = Propagator
  { forall context inboundCarrier outboundCarrier.
Propagator context inboundCarrier outboundCarrier -> [Text]
propagatorFields :: [Text]
  {- ^ The predefined propagation fields. For a TextMapPropagator these are
  the header names the propagator reads and writes (e.g. @["traceparent", "tracestate"]@).
  If your carrier is reused, you should delete these fields before calling 'inject'.
  -}
  , forall context inboundCarrier outboundCarrier.
Propagator context inboundCarrier outboundCarrier
-> inboundCarrier -> context -> IO context
extractor :: inboundCarrier -> context -> IO context
  , forall context inboundCarrier outboundCarrier.
Propagator context inboundCarrier outboundCarrier
-> context -> outboundCarrier -> IO outboundCarrier
injector :: context -> outboundCarrier -> IO outboundCarrier
  }


instance Semigroup (Propagator c i o) where
  (Propagator [Text]
lFields i -> c -> IO c
lExtract c -> o -> IO o
lInject) <> :: Propagator c i o -> Propagator c i o -> Propagator c i o
<> (Propagator [Text]
rFields i -> c -> IO c
rExtract c -> o -> IO o
rInject) =
    Propagator
      { propagatorFields :: [Text]
propagatorFields = [Text]
lFields [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
rFields
      , extractor :: i -> c -> IO c
extractor = \i
i c
ctx -> do
          ctx' <-
            i -> c -> IO c
lExtract i
i c
ctx IO c -> (SomeException -> IO c) -> IO c
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
e :: SomeException) -> do
              String -> IO ()
otelLogWarning (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Propagator extract failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall a. Show a => a -> String
show SomeException
e
              c -> IO c
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure c
ctx
          rExtract i ctx' `catch` \(SomeException
e :: SomeException) -> do
            String -> IO ()
otelLogWarning (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Propagator extract failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall a. Show a => a -> String
show SomeException
e
            c -> IO c
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure c
ctx'
      , injector :: c -> o -> IO o
injector = \c
c o
carrier -> do
          carrier' <-
            c -> o -> IO o
lInject c
c o
carrier IO o -> (SomeException -> IO o) -> IO o
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
e :: SomeException) -> do
              String -> IO ()
otelLogWarning (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Propagator inject failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall a. Show a => a -> String
show SomeException
e
              o -> IO o
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure o
carrier
          rInject c carrier' `catch` \(SomeException
e :: SomeException) -> do
            String -> IO ()
otelLogWarning (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Propagator inject failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall a. Show a => a -> String
show SomeException
e
            o -> IO o
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure o
carrier'
      }


instance Monoid (Propagator c i o) where
  mempty :: Propagator c i o
mempty = [Text] -> (i -> c -> IO c) -> (c -> o -> IO o) -> Propagator c i o
forall context inboundCarrier outboundCarrier.
[Text]
-> (inboundCarrier -> context -> IO context)
-> (context -> outboundCarrier -> IO outboundCarrier)
-> Propagator context inboundCarrier outboundCarrier
Propagator [Text]
forall a. Monoid a => a
mempty (\i
_ c
c -> c -> IO c
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure c
c) (\c
_ o
p -> o -> IO o
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure o
p)


{- | A case-insensitive text map used as the carrier for context propagation.
Keys are compared case-insensitively but their original casing is preserved,
matching the behavior required by HTTP header semantics.

Instrumentation code converts between transport-specific representations
(e.g. HTTP headers) and 'TextMap' at the boundary.

@since 0.4.0.0
-}
data TextMap = TextMap
  { TextMap -> HashMap Text Text
tmLookup :: !(H.HashMap Text Text)
  -- ^ Lowercase key -> value (for O(1) case-insensitive lookup)
  , TextMap -> HashMap Text Text
tmOriginal :: !(H.HashMap Text Text)
  -- ^ Lowercase key -> original-cased key (to preserve casing on output)
  }
  deriving (Int -> TextMap -> String -> String
[TextMap] -> String -> String
TextMap -> String
(Int -> TextMap -> String -> String)
-> (TextMap -> String)
-> ([TextMap] -> String -> String)
-> Show TextMap
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> TextMap -> String -> String
showsPrec :: Int -> TextMap -> String -> String
$cshow :: TextMap -> String
show :: TextMap -> String
$cshowList :: [TextMap] -> String -> String
showList :: [TextMap] -> String -> String
Show, TextMap -> TextMap -> Bool
(TextMap -> TextMap -> Bool)
-> (TextMap -> TextMap -> Bool) -> Eq TextMap
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TextMap -> TextMap -> Bool
== :: TextMap -> TextMap -> Bool
$c/= :: TextMap -> TextMap -> Bool
/= :: TextMap -> TextMap -> Bool
Eq)


-- | @since 0.4.0.0
emptyTextMap :: TextMap
emptyTextMap :: TextMap
emptyTextMap = HashMap Text Text -> HashMap Text Text -> TextMap
TextMap HashMap Text Text
forall k v. HashMap k v
H.empty HashMap Text Text
forall k v. HashMap k v
H.empty
{-# INLINE emptyTextMap #-}


-- | @since 0.4.0.0
textMapInsert :: Text -> Text -> TextMap -> TextMap
textMapInsert :: Text -> Text -> TextMap -> TextMap
textMapInsert Text
k Text
v (TextMap HashMap Text Text
lk HashMap Text Text
orig) =
  let lk' :: Text
lk' = Text -> Text
T.toLower Text
k
  in HashMap Text Text -> HashMap Text Text -> TextMap
TextMap (Text -> Text -> HashMap Text Text -> HashMap Text Text
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
H.insert Text
lk' Text
v HashMap Text Text
lk) (Text -> Text -> HashMap Text Text -> HashMap Text Text
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
H.insert Text
lk' Text
k HashMap Text Text
orig)
{-# INLINE textMapInsert #-}


-- | @since 0.4.0.0
textMapLookup :: Text -> TextMap -> Maybe Text
textMapLookup :: Text -> TextMap -> Maybe Text
textMapLookup Text
k (TextMap HashMap Text Text
lk HashMap Text Text
_) = Text -> HashMap Text Text -> Maybe Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup (Text -> Text
T.toLower Text
k) HashMap Text Text
lk
{-# INLINE textMapLookup #-}


-- | @since 0.4.0.0
textMapDelete :: Text -> TextMap -> TextMap
textMapDelete :: Text -> TextMap -> TextMap
textMapDelete Text
k (TextMap HashMap Text Text
lk HashMap Text Text
orig) =
  let lk' :: Text
lk' = Text -> Text
T.toLower Text
k
  in HashMap Text Text -> HashMap Text Text -> TextMap
TextMap (Text -> HashMap Text Text -> HashMap Text Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
H.delete Text
lk' HashMap Text Text
lk) (Text -> HashMap Text Text -> HashMap Text Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
H.delete Text
lk' HashMap Text Text
orig)
{-# INLINE textMapDelete #-}


-- | @since 0.4.0.0
textMapKeys :: TextMap -> [Text]
textMapKeys :: TextMap -> [Text]
textMapKeys (TextMap HashMap Text Text
_ HashMap Text Text
orig) = HashMap Text Text -> [Text]
forall k v. HashMap k v -> [v]
H.elems HashMap Text Text
orig
{-# INLINE textMapKeys #-}


-- | @since 0.4.0.0
textMapToList :: TextMap -> [(Text, Text)]
textMapToList :: TextMap -> [(Text, Text)]
textMapToList (TextMap HashMap Text Text
lk HashMap Text Text
orig) =
  ([(Text, Text)] -> Text -> Text -> [(Text, Text)])
-> [(Text, Text)] -> HashMap Text Text -> [(Text, Text)]
forall a k v. (a -> k -> v -> a) -> a -> HashMap k v -> a
H.foldlWithKey'
    ( \[(Text, Text)]
acc Text
lk' Text
v -> case Text -> HashMap Text Text -> Maybe Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Text
lk' HashMap Text Text
orig of
        Just Text
origKey -> (Text
origKey, Text
v) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
acc
        Maybe Text
Nothing -> (Text
lk', Text
v) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
acc
    )
    []
    HashMap Text Text
lk
{-# INLINE textMapToList #-}


-- | @since 0.4.0.0
textMapFromList :: [(Text, Text)] -> TextMap
textMapFromList :: [(Text, Text)] -> TextMap
textMapFromList = (TextMap -> (Text, Text) -> TextMap)
-> TextMap -> [(Text, Text)] -> TextMap
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (\TextMap
tm (Text
k, Text
v) -> Text -> Text -> TextMap -> TextMap
textMapInsert Text
k Text
v TextMap
tm) TextMap
emptyTextMap


{- | A 'TextMapPropagator' is a 'Propagator' specialized for text-based
carriers. This is the only propagator type defined by the OpenTelemetry
specification.

Instrumentation libraries convert between transport-specific formats
(e.g. HTTP headers, gRPC metadata, environment variables) and 'TextMap'
at the boundary, then pass the 'TextMap' to the propagator.

@since 0.4.0.0
-}
type TextMapPropagator = Propagator Context TextMap TextMap


-- Per spec: "The OpenTelemetry API MUST use no-op propagators unless
-- explicitly configured otherwise." mempty is the no-op propagator.
globalTextMapPropagator :: IORef TextMapPropagator
globalTextMapPropagator :: IORef TextMapPropagator
globalTextMapPropagator = IO (IORef TextMapPropagator) -> IORef TextMapPropagator
forall a. IO a -> a
unsafePerformIO (IO (IORef TextMapPropagator) -> IORef TextMapPropagator)
-> IO (IORef TextMapPropagator) -> IORef TextMapPropagator
forall a b. (a -> b) -> a -> b
$ TextMapPropagator -> IO (IORef TextMapPropagator)
forall a. a -> IO (IORef a)
newIORef TextMapPropagator
forall a. Monoid a => a
mempty
{-# NOINLINE globalTextMapPropagator #-}


{- | Get the globally configured 'TextMapPropagator'.

Returns a no-op propagator until the SDK sets one via
'setGlobalTextMapPropagator' (typically driven by @OTEL_PROPAGATORS@).

@since 0.4.0.0
-}
getGlobalTextMapPropagator :: IO TextMapPropagator
getGlobalTextMapPropagator :: IO TextMapPropagator
getGlobalTextMapPropagator = IORef TextMapPropagator -> IO TextMapPropagator
forall a. IORef a -> IO a
readIORef IORef TextMapPropagator
globalTextMapPropagator


{- | Set the global 'TextMapPropagator'.

Called by the SDK during initialization. Instrumentation libraries
should use 'getGlobalTextMapPropagator' rather than accessing the
'TracerProvider' propagator directly.

@since 0.4.0.0
-}
setGlobalTextMapPropagator :: TextMapPropagator -> IO ()
setGlobalTextMapPropagator :: TextMapPropagator -> IO ()
setGlobalTextMapPropagator = IORef TextMapPropagator -> TextMapPropagator -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef TextMapPropagator
globalTextMapPropagator


{- |
Extracts the value from an incoming request. For example, from the headers of an HTTP request.

If a value can not be parsed from the carrier, for a cross-cutting concern, the implementation MUST NOT throw an exception and MUST NOT store a new value in the Context, in order to preserve any previously existing valid value.

@since 0.0.1.0
-}
extract
  :: (MonadIO m)
  => Propagator context i o
  -> i
  -- ^ The carrier that holds the propagation fields. For example, an incoming message or HTTP request.
  -> context
  -> m context
  -- ^ a new Context derived from the Context passed as argument, containing the extracted value, which can be a SpanContext, Baggage or another cross-cutting concern context.
extract :: forall (m :: * -> *) context i o.
MonadIO m =>
Propagator context i o -> i -> context -> m context
extract (Propagator [Text]
_ i -> context -> IO context
extractor_ context -> o -> IO o
_) i
i context
ctx =
  IO context -> m context
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO context -> m context) -> IO context -> m context
forall a b. (a -> b) -> a -> b
$
    i -> context -> IO context
extractor_ i
i context
ctx IO context -> (SomeException -> IO context) -> IO context
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
e :: SomeException) -> do
      String -> IO ()
otelLogWarning (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Propagator extract failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall a. Show a => a -> String
show SomeException
e
      context -> IO context
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure context
ctx


{- | Deprecated alias for 'propagatorFields'.

@since 0.0.1.0
-}
propagatorNames :: Propagator context i o -> [Text]
propagatorNames :: forall context inboundCarrier outboundCarrier.
Propagator context inboundCarrier outboundCarrier -> [Text]
propagatorNames = Propagator context i o -> [Text]
forall context inboundCarrier outboundCarrier.
Propagator context inboundCarrier outboundCarrier -> [Text]
propagatorFields
{-# DEPRECATED propagatorNames "Use propagatorFields instead. propagatorNames will be removed in a future release." #-}


{- | Injects the value into a carrier. For example, into the headers of an HTTP request.

@since 0.0.1.0
-}
inject
  :: (MonadIO m)
  => Propagator context i o
  -> context
  -> o
  -- ^ The carrier that holds the propagation fields. For example, an outgoing message or HTTP request.
  -> m o
inject :: forall (m :: * -> *) context i o.
MonadIO m =>
Propagator context i o -> context -> o -> m o
inject (Propagator [Text]
_ i -> context -> IO context
_ context -> o -> IO o
injector_) context
c o
carrier =
  IO o -> m o
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO o -> m o) -> IO o -> m o
forall a b. (a -> b) -> a -> b
$
    context -> o -> IO o
injector_ context
c o
carrier IO o -> (SomeException -> IO o) -> IO o
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
e :: SomeException) -> do
      String -> IO ()
otelLogWarning (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Propagator inject failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall a. Show a => a -> String
show SomeException
e
      o -> IO o
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure o
carrier