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
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
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
}