module OpenTelemetry.Contrib.CarryOns (
  alterCarryOns,
  withCarryOnProcessor,
) where

import Control.Monad.IO.Class
import qualified Data.HashMap.Strict as H
import Data.IORef (modifyIORef')
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import OpenTelemetry.Attributes
import OpenTelemetry.Context
import qualified OpenTelemetry.Context as Context
import OpenTelemetry.Context.ThreadLocal
import OpenTelemetry.Internal.Trace.Types
import OpenTelemetry.Trace.Core
import System.IO.Unsafe (unsafePerformIO)


carryOnKey :: Key (H.HashMap Text Attribute)
carryOnKey :: Key (HashMap Text Attribute)
carryOnKey = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => Text -> m (Key a)
newKey Text
"carryOn"
{-# NOINLINE carryOnKey #-}


alterCarryOns :: (MonadIO m) => (H.HashMap Text Attribute -> H.HashMap Text Attribute) -> m ()
alterCarryOns :: forall (m :: * -> *).
MonadIO m =>
(HashMap Text Attribute -> HashMap Text Attribute) -> m ()
alterCarryOns HashMap Text Attribute -> HashMap Text Attribute
f = forall (m :: * -> *). MonadIO m => (Context -> Context) -> m ()
adjustContext forall a b. (a -> b) -> a -> b
$ \Context
ctxt ->
  forall a. Key a -> a -> Context -> Context
Context.insert Key (HashMap Text Attribute)
carryOnKey (HashMap Text Attribute -> HashMap Text Attribute
f forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ forall a. Key a -> Context -> Maybe a
Context.lookup Key (HashMap Text Attribute)
carryOnKey Context
ctxt) Context
ctxt


{- |
"Carry ons" are extra attributes that are added to every span that is completed for within a thread's context.
This helps us propagate attributes across a trace without having to manually add them to every span.

Be cautious about adding too many additional attributes via carry ons. The attributes are added to every span,
and will be discarded if the span has attributes that exceed the configured attribute limits for the configured
'TracerProvider'.
-}
withCarryOnProcessor :: Processor -> Processor
withCarryOnProcessor :: Processor -> Processor
withCarryOnProcessor Processor
p =
  Processor
    { processorOnStart :: IORef ImmutableSpan -> Context -> IO ()
processorOnStart = Processor -> IORef ImmutableSpan -> Context -> IO ()
processorOnStart Processor
p
    , processorOnEnd :: IORef ImmutableSpan -> IO ()
processorOnEnd = \IORef ImmutableSpan
spanRef -> do
        Context
ctxt <- forall (m :: * -> *). MonadIO m => m Context
getContext
        let carryOns :: HashMap Text Attribute
carryOns = forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ forall a. Key a -> Context -> Maybe a
Context.lookup Key (HashMap Text Attribute)
carryOnKey Context
ctxt
        if forall k v. HashMap k v -> Bool
H.null HashMap Text Attribute
carryOns
          then forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          else do
            -- I doubt we need atomicity at this point. Hopefully people aren't trying to modify the same span after it has ended from multiple threads.
            forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef ImmutableSpan
spanRef forall a b. (a -> b) -> a -> b
$ \ImmutableSpan
is ->
              ImmutableSpan
is
                { spanAttributes :: Attributes
spanAttributes =
                    forall a.
ToAttribute a =>
AttributeLimits -> Attributes -> HashMap Text a -> Attributes
OpenTelemetry.Attributes.addAttributes
                      (TracerProvider -> AttributeLimits
tracerProviderAttributeLimits forall a b. (a -> b) -> a -> b
$ Tracer -> TracerProvider
tracerProvider forall a b. (a -> b) -> a -> b
$ ImmutableSpan -> Tracer
spanTracer ImmutableSpan
is)
                      (ImmutableSpan -> Attributes
spanAttributes ImmutableSpan
is)
                      HashMap Text Attribute
carryOns
                }
        Processor -> IORef ImmutableSpan -> IO ()
processorOnEnd Processor
p IORef ImmutableSpan
spanRef
    , processorShutdown :: IO (Async ShutdownResult)
processorShutdown = Processor -> IO (Async ShutdownResult)
processorShutdown Processor
p
    , processorForceFlush :: IO ()
processorForceFlush = Processor -> IO ()
processorForceFlush Processor
p
    }