packages feed

hs-opentelemetry-api 0.0.3.8 → 0.1.0.0

raw patch · 18 files changed

+402/−271 lines, 18 files

Files

ChangeLog.md view
@@ -1,5 +1,11 @@ # Changelog for hs-opentelemetry-api +## Unreleased changes++## 0.1.0.0++- Use `HashMap Text Attribute` instead of `[(Text, Attribute)]` as attributes+ ## 0.0.3.6  - GHC 9.4 support@@ -23,5 +29,3 @@ ## 0.0.1.0  - Initial release--## Unreleased changes
hs-opentelemetry-api.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:               hs-opentelemetry-api-version:            0.0.3.8+version:            0.1.0.0 synopsis:           OpenTelemetry API for use by libraries for direct instrumentation or wrapper packages. description:        Please see the README on GitHub at <https://github.com/iand675/hs-opentelemetry/tree/main/api#readme> category:           OpenTelemetry, Telemetry, Monitoring, Observability, Metrics@@ -32,6 +32,8 @@       OpenTelemetry.Common       OpenTelemetry.Context       OpenTelemetry.Context.ThreadLocal+      OpenTelemetry.Contrib.CarryOns+      OpenTelemetry.Contrib.SpanTraversals       OpenTelemetry.Exporter       OpenTelemetry.Internal.Trace.Id       OpenTelemetry.Logging.Core@@ -96,6 +98,7 @@   type: exitcode-stdio-1.0   main-is: Spec.hs   other-modules:+      OpenTelemetry.BaggageSpec       OpenTelemetry.Trace.SamplerSpec       OpenTelemetry.Trace.TraceFlagsSpec       Paths_hs_opentelemetry_api
src/OpenTelemetry/Attributes.hs view
@@ -7,10 +7,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE StrictData #-} -------------------------------------------------------------------------------------------------------------------------------------------------------------- {- |  Module      :  OpenTelemetry.Attributes  Copyright   :  (c) Ian Duncan, 2021@@ -49,15 +45,14 @@   unsafeMergeAttributesIgnoringLimits, ) where -import Data.Data+import Data.Data (Data) import qualified Data.HashMap.Strict as H-import Data.Hashable+import Data.Hashable (Hashable) import Data.Int (Int64)-import Data.List (foldl')-import Data.String+import Data.String (IsString (..)) import Data.Text (Text) import qualified Data.Text as T-import GHC.Generics+import GHC.Generics (Generic)   {- | Default attribute limits used in the global attribute limit configuration if no environment variables are set.@@ -87,7 +82,7 @@ emptyAttributes = Attributes mempty 0 0  -addAttribute :: ToAttribute a => AttributeLimits -> Attributes -> Text -> a -> Attributes+addAttribute :: (ToAttribute a) => AttributeLimits -> Attributes -> Text -> a -> Attributes addAttribute AttributeLimits {..} Attributes {..} !k !v = case attributeCountLimit of   Nothing -> Attributes newAttrs newCount attributesDropped   Just limit_ ->@@ -95,29 +90,34 @@       then Attributes attributes attributesCount (attributesDropped + 1)       else Attributes newAttrs newCount attributesDropped   where-    newAttrs = H.insert k (limitLengths $ toAttribute v) attributes-    newCount =-      if H.member k attributes-        then attributesCount-        else attributesCount + 1--    limitPrimAttr limit_ (TextAttribute t) = TextAttribute (T.take limit_ t)-    limitPrimAttr _ attr = attr--    limitLengths attr = case attributeLengthLimit of-      Nothing -> attr-      Just limit_ -> case attr of-        AttributeValue val -> AttributeValue $ limitPrimAttr limit_ val-        AttributeArray arr -> AttributeArray $ fmap (limitPrimAttr limit_) arr+    newAttrs = H.insert k (maybe id limitLengths attributeCountLimit $ toAttribute v) attributes+    newCount = H.size newAttrs {-# INLINE addAttribute #-}  -addAttributes :: ToAttribute a => AttributeLimits -> Attributes -> [(Text, a)] -> Attributes--- TODO, this could be done more efficiently-addAttributes limits = foldl' (\(!attrs') (!k, !v) -> addAttribute limits attrs' k v)+addAttributes :: (ToAttribute a) => AttributeLimits -> Attributes -> H.HashMap Text a -> Attributes+addAttributes AttributeLimits {..} Attributes {..} attrs = case attributeCountLimit of+  Nothing -> Attributes newAttrs newCount attributesDropped+  Just limit_ ->+    if newCount > limit_+      then Attributes attributes attributesCount (attributesDropped + H.size attrs)+      else Attributes newAttrs newCount attributesDropped+  where+    newAttrs = H.union attributes $ H.map toAttribute attrs+    newCount = H.size newAttrs {-# INLINE addAttributes #-}  +limitPrimAttr :: Int -> PrimitiveAttribute -> PrimitiveAttribute+limitPrimAttr limit (TextAttribute t) = TextAttribute (T.take limit t)+limitPrimAttr _ attr = attr+++limitLengths :: Int -> Attribute -> Attribute+limitLengths limit (AttributeValue val) = AttributeValue $ limitPrimAttr limit val+limitLengths limit (AttributeArray arr) = AttributeArray $ fmap (limitPrimAttr limit) arr++ getAttributes :: Attributes -> (Int, H.HashMap Text Attribute) getAttributes Attributes {..} = (attributesCount, attributes) @@ -203,7 +203,7 @@ -} class ToAttribute a where   toAttribute :: a -> Attribute-  default toAttribute :: ToPrimitiveAttribute a => a -> Attribute+  default toAttribute :: (ToPrimitiveAttribute a) => a -> Attribute   toAttribute = AttributeValue . toPrimitiveAttribute  @@ -254,7 +254,7 @@   toAttribute = id  -instance ToPrimitiveAttribute a => ToAttribute [a] where+instance (ToPrimitiveAttribute a) => ToAttribute [a] where   toAttribute = AttributeArray . map toPrimitiveAttribute
src/OpenTelemetry/Baggage.hs view
@@ -134,7 +134,7 @@   -- Ripped from file-embed-0.0.13-bsToExp :: Monad m => ByteString -> m Exp+bsToExp :: (Monad m) => ByteString -> m Exp #if MIN_VERSION_template_haskell(2, 5, 0) bsToExp bs =     return $ ConE 'Token@@ -249,7 +249,7 @@           ]     tokenP :: P.Parser Token     tokenP = Token <$> P.takeWhile1 (`C.member` tokenCharacters)-    valP = decodeUtf8 <$> P.takeWhile (`C.member` valueSet)+    valP = decodeUtf8 . urlDecode False <$> P.takeWhile (`C.member` valueSet)     propertyP :: P.Parser Property     propertyP = do       key <- tokenP@@ -266,13 +266,13 @@ empty = Baggage H.empty  -insert ::-  -- | The name for which to set the value-  Token ->-  -- | The value to set. Use 'element' to construct a well-formed element value.-  Element ->-  Baggage ->-  Baggage+insert+  :: Token+  -- ^ The name for which to set the value+  -> Element+  -- ^ The value to set. Use 'element' to construct a well-formed element value.+  -> Baggage+  -> Baggage insert k v (Baggage c) = Baggage (H.insert k v c)
src/OpenTelemetry/Context.hs view
@@ -53,7 +53,7 @@ import Prelude hiding (lookup)  -newKey :: MonadIO m => Text -> m (Key a)+newKey :: (MonadIO m) => Text -> m (Key a) newKey n = liftIO (Key n <$> V.newKey)
src/OpenTelemetry/Context/ThreadLocal.hs view
@@ -84,7 +84,7 @@   @since 0.0.1.0 -}-getContext :: MonadIO m => m Context+getContext :: (MonadIO m) => m Context getContext = fromMaybe empty <$> lookupContext  @@ -92,7 +92,7 @@   @since 0.0.1.0 -}-lookupContext :: MonadIO m => m (Maybe Context)+lookupContext :: (MonadIO m) => m (Maybe Context) lookupContext = lookup threadContextMap  @@ -100,7 +100,7 @@   @since 0.0.1.0 -}-lookupContextOnThread :: MonadIO m => ThreadId -> m (Maybe Context)+lookupContextOnThread :: (MonadIO m) => ThreadId -> m (Maybe Context) lookupContextOnThread = lookupOnThread threadContextMap  @@ -108,7 +108,7 @@   @since 0.0.1.0 -}-attachContext :: MonadIO m => Context -> m (Maybe Context)+attachContext :: (MonadIO m) => Context -> m (Maybe Context) attachContext = attach threadContextMap  @@ -116,7 +116,7 @@   @since 0.0.1.0 -}-attachContextOnThread :: MonadIO m => ThreadId -> Context -> m (Maybe Context)+attachContextOnThread :: (MonadIO m) => ThreadId -> Context -> m (Maybe Context) attachContextOnThread = attachOnThread threadContextMap  @@ -129,7 +129,7 @@   @since 0.0.1.0 -}-detachContext :: MonadIO m => m (Maybe Context)+detachContext :: (MonadIO m) => m (Maybe Context) detachContext = detach threadContextMap  @@ -142,7 +142,7 @@   @since 0.0.1.0 -}-detachContextFromThread :: MonadIO m => ThreadId -> m (Maybe Context)+detachContextFromThread :: (MonadIO m) => ThreadId -> m (Maybe Context) detachContextFromThread = detachFromThread threadContextMap  @@ -153,7 +153,7 @@   @since 0.0.1.0 -}-adjustContext :: MonadIO m => (Context -> Context) -> m ()+adjustContext :: (MonadIO m) => (Context -> Context) -> m () adjustContext f = update threadContextMap $ \mctx ->   (pure $ f $ fromMaybe empty mctx, ()) @@ -165,6 +165,6 @@   @since 0.0.1.0 -}-adjustContextOnThread :: MonadIO m => ThreadId -> (Context -> Context) -> m ()+adjustContextOnThread :: (MonadIO m) => ThreadId -> (Context -> Context) -> m () adjustContextOnThread tid f = updateOnThread threadContextMap tid $ \mctx ->   (pure $ f $ fromMaybe empty mctx, ())
+ src/OpenTelemetry/Contrib/CarryOns.hs view
@@ -0,0 +1,60 @@+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 = unsafePerformIO $ newKey "carryOn"+{-# NOINLINE carryOnKey #-}+++alterCarryOns :: (MonadIO m) => (H.HashMap Text Attribute -> H.HashMap Text Attribute) -> m ()+alterCarryOns f = adjustContext $ \ctxt ->+  Context.insert carryOnKey (f $ fromMaybe mempty $ Context.lookup carryOnKey ctxt) 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 p =+  Processor+    { processorOnStart = processorOnStart p+    , processorOnEnd = \spanRef -> do+        ctxt <- getContext+        let carryOns = fromMaybe mempty $ Context.lookup carryOnKey ctxt+        if H.null carryOns+          then 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.+            modifyIORef' spanRef $ \is ->+              is+                { spanAttributes =+                    OpenTelemetry.Attributes.addAttributes+                      (tracerProviderAttributeLimits $ tracerProvider $ spanTracer is)+                      (spanAttributes is)+                      carryOns+                }+        processorOnEnd p spanRef+    , processorShutdown = processorShutdown p+    , processorForceFlush = processorForceFlush p+    }
+ src/OpenTelemetry/Contrib/SpanTraversals.hs view
@@ -0,0 +1,28 @@+module OpenTelemetry.Contrib.SpanTraversals (+  alterSpansUpwards,+  IterationInstruction (..),+) where++import Control.Monad.IO.Class+import Data.IORef+import OpenTelemetry.Internal.Trace.Types+++data IterationInstruction a = Continue a | Halt+++{- | Alter traces upwards from the provides span to the highest available mutable span. Only mutable spans may be altered.++ The step value indicates whether the desired topmost span has been reached or not. This function will continue to iterate+ upwards until either a span that cannot be mutated has been reached, or there are no more parent spans remaining.+-}+alterSpansUpwards :: (MonadIO m) => Span -> st -> (st -> ImmutableSpan -> (IterationInstruction st, ImmutableSpan)) -> m st+alterSpansUpwards (Span immutableSpanRef) st f = liftIO $ do+  (step, a') <- atomicModifyIORef' immutableSpanRef (\a -> let (step, a') = f st a in (a', (step, a')))+  case step of+    Continue st' -> case spanParent a' of+      Nothing -> return st'+      Just s -> alterSpansUpwards s st' f+    Halt -> return st+alterSpansUpwards (FrozenSpan _) st _ = return st+alterSpansUpwards (Dropped _) st _ = return st
src/OpenTelemetry/Internal/Trace/Id.hs view
@@ -53,9 +53,12 @@   isTrue#,   or#,  )++ #if MIN_VERSION_base(4,17,0) import GHC.Exts (word64ToWord#) #endif+ import GHC.Generics (Generic) import OpenTelemetry.Trace.Id.Generator (   IdGenerator (generateSpanIdBytes, generateTraceIdBytes),@@ -105,7 +108,7 @@   @since 0.1.0.0 -}-newTraceId :: MonadIO m => IdGenerator -> m TraceId+newTraceId :: (MonadIO m) => IdGenerator -> m TraceId newTraceId gen = liftIO (TraceId . toShort <$> generateTraceIdBytes gen)  @@ -195,7 +198,7 @@   @since 0.1.0.0 -}-newSpanId :: MonadIO m => IdGenerator -> m SpanId+newSpanId :: (MonadIO m) => IdGenerator -> m SpanId newSpanId gen = liftIO (SpanId . toShort <$> generateSpanIdBytes gen)
src/OpenTelemetry/Internal/Trace/Types.hs view
@@ -12,6 +12,7 @@ import Control.Monad.IO.Class import Data.Bits import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as H import Data.Hashable (Hashable) import Data.IORef (IORef, readIORef) import Data.String (IsString (..))@@ -179,7 +180,7 @@ data NewLink = NewLink   { linkContext :: !SpanContext   -- ^ @SpanContext@ of the @Span@ to link to.-  , linkAttributes :: [(Text, Attribute)]+  , linkAttributes :: H.HashMap Text Attribute   -- ^ Zero or more Attributes further describing the link.   }   deriving (Show)@@ -220,7 +221,7 @@   { kind :: SpanKind   -- ^ The kind of the span. See 'SpanKind's documentation for the semantics   -- of the various values that may be specified.-  , attributes :: [(Text, Attribute)]+  , attributes :: H.HashMap Text Attribute   -- ^ An initial set of attributes that may be set on initial 'Span' creation.   -- These attributes are provided to 'Processor's, so they may be useful in some   -- scenarios where calling `addAttribute` or `addAttributes` is too late.@@ -467,7 +468,7 @@ data NewEvent = NewEvent   { newEventName :: Text   -- ^ The name of an event. Ideally this should be a relatively unique, but low cardinality value.-  , newEventAttributes :: [(Text, Attribute)]+  , newEventAttributes :: H.HashMap Text Attribute   -- ^ Additional context or metadata related to the event, (stack traces, callsites, etc.).   , newEventTimestamp :: Maybe Timestamp   -- ^ The time that the event occurred.@@ -518,7 +519,7 @@ data Sampler = Sampler   { getDescription :: Text   -- ^ Returns the sampler name or short description with the configuration. This may be displayed on debug pages or in the logs.-  , shouldSample :: Context -> TraceId -> Text -> SpanArguments -> IO (SamplingResult, [(Text, Attribute)], TraceState)+  , shouldSample :: Context -> TraceId -> Text -> SpanArguments -> IO (SamplingResult, H.HashMap Text Attribute, TraceState)   }  @@ -544,7 +545,7 @@     Nothing  -type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t+type Lens s t a b = forall f. (Functor f) => (a -> f b) -> s -> f t   type Lens' s a = Lens s s a a@@ -553,7 +554,7 @@ {- | When sending tracing information across process boundaries,  the @SpanContext@ is used to serialize the relevant information. -}-getSpanContext :: MonadIO m => Span -> m SpanContext+getSpanContext :: (MonadIO m) => Span -> m SpanContext getSpanContext (Span s) = liftIO (spanContext <$> readIORef s) getSpanContext (FrozenSpan c) = pure c getSpanContext (Dropped c) = pure c
src/OpenTelemetry/Propagator.hs view
@@ -63,23 +63,23 @@  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. -}-extract ::-  (MonadIO m) =>-  Propagator context i o ->-  -- | The carrier that holds the propagation fields. For example, an incoming message or HTTP request.-  i ->-  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.-  m context+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 (Propagator _ extractor _) i = liftIO . extractor i   -- | Injects the value into a carrier. For example, into the headers of an HTTP request.-inject ::-  (MonadIO m) =>-  Propagator context i o ->-  context ->-  -- | The carrier that holds the propagation fields. For example, an outgoing message or HTTP request.-  o ->-  m o+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 (Propagator _ _ injector) c = liftIO . injector c
src/OpenTelemetry/Resource.hs view
@@ -80,14 +80,14 @@ {- | Utility function to convert a required resource attribute  into the format needed for 'mkResource'. -}-(.=) :: ToAttribute a => Text -> a -> Maybe (Text, Attribute)+(.=) :: (ToAttribute a) => Text -> a -> Maybe (Text, Attribute) k .= v = Just (k, toAttribute v)   {- | Utility function to convert an optional resource attribute  into the format needed for 'mkResource'. -}-(.=?) :: ToAttribute a => Text -> Maybe a -> Maybe (Text, Attribute)+(.=?) :: (ToAttribute a) => Text -> Maybe a -> Maybe (Text, Attribute) k .=? mv = (\k' v -> (k', toAttribute v)) k <$> mv  @@ -135,12 +135,12 @@   @since 0.0.1.0 -}-mergeResources ::-  -- | the old resource-  Resource old ->-  -- | the updating resource whose attributes take precedence-  Resource new ->-  Resource (ResourceMerge old new)+mergeResources+  :: Resource old+  -- ^ the old resource+  -> Resource new+  -- ^ the updating resource whose attributes take precedence+  -> Resource (ResourceMerge old new) mergeResources (Resource l) (Resource r) = Resource (unsafeMergeAttributesIgnoringLimits l r)  @@ -167,7 +167,7 @@   materializeResources (Resource attrs) = MaterializedResources Nothing attrs  -instance KnownSymbol s => MaterializeResource ('Just s) where+instance (KnownSymbol s) => MaterializeResource ('Just s) where   materializeResources (Resource attrs) = MaterializedResources (Just $ symbolVal (Proxy @s)) attrs
src/OpenTelemetry/Trace/Core.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}@@ -130,6 +131,9 @@   timestampNanoseconds,   unsafeReadSpan,   whenSpanIsRecording,+  ownCodeAttributes,+  callerAttributes,+  addAttributesToSpanArguments,    -- * Limits   SpanLimits (..),@@ -145,6 +149,7 @@ import Control.Monad.IO.Class import Control.Monad.IO.Unlift import Data.Coerce+import qualified Data.HashMap.Strict as H import Data.IORef import Data.Maybe (fromMaybe, isJust, isNothing) import Data.Text (Text)@@ -185,53 +190,38 @@   @since 0.0.1.0 -}-createSpan ::-  (MonadIO m, HasCallStack) =>-  -- | 'Tracer' to create the span from. Associated 'Processor's and 'Exporter's will be+createSpan+  :: (MonadIO m, HasCallStack)+  => Tracer+  -- ^ 'Tracer' to create the span from. Associated 'Processor's and 'Exporter's will be   -- used for the lifecycle of the created 'Span'-  Tracer ->-  -- | Context, potentially containing a parent span. If no existing parent (or context) exists,+  -> Context+  -- ^ Context, potentially containing a parent span. If no existing parent (or context) exists,   -- you can use 'OpenTelemetry.Context.empty'.-  Context ->-  -- | Span name-  Text ->-  -- | Additional span information-  SpanArguments ->-  -- | The created span.-  m Span-createSpan t c n args = do-  createSpanWithoutCallStack t c n $ case getCallStack callStack of-    [] -> args-    (_, loc) : rest ->-      let addFunction = case rest of-            (fn, _) : _ -> (("code.function", toAttribute $ T.pack fn) :)-            [] -> id-       in args-            { attributes =-                addFunction $-                  ("code.namespace", toAttribute $ T.pack $ srcLocModule loc)-                    : ("code.filepath", toAttribute $ T.pack $ srcLocFile loc)-                    : ("code.lineno", toAttribute $ srcLocStartLine loc)-                    : ("code.package", toAttribute $ T.pack $ srcLocPackage loc)-                    : attributes args-            }+  -> Text+  -- ^ Span name+  -> SpanArguments+  -- ^ Additional span information+  -> m Span+  -- ^ The created span.+createSpan t ctxt n args = createSpanWithoutCallStack t ctxt n (args {attributes = H.union (attributes args) callerAttributes})   -- | The same thing as 'createSpan', except that it does not have a 'HasCallStack' constraint.-createSpanWithoutCallStack ::-  MonadIO m =>-  -- | 'Tracer' to create the span from. Associated 'Processor's and 'Exporter's will be+createSpanWithoutCallStack+  :: (MonadIO m)+  => Tracer+  -- ^ 'Tracer' to create the span from. Associated 'Processor's and 'Exporter's will be   -- used for the lifecycle of the created 'Span'-  Tracer ->-  -- | Context, potentially containing a parent span. If no existing parent (or context) exists,+  -> Context+  -- ^ Context, potentially containing a parent span. If no existing parent (or context) exists,   -- you can use 'OpenTelemetry.Context.empty'.-  Context ->-  -- | Span name-  Text ->-  -- | Additional span information-  SpanArguments ->-  -- | The created span.-  m Span+  -> Text+  -- ^ Span name+  -> SpanArguments+  -- ^ Additional span information+  -> m Span+  -- ^ The created span. createSpanWithoutCallStack t ctxt n args@SpanArguments {..} = liftIO $ do   sId <- newSpanId $ tracerProviderIdGenerator $ tracerProvider t   let parent = lookupSpan ctxt@@ -283,7 +273,7 @@                         A.addAttributes                           (limitBy t spanAttributeCountLimit)                           emptyAttributes-                          (concat [additionalInfo, attrs, attributes])+                          (H.unions [additionalInfo, attrs, attributes])                     , spanLinks =                         let limitedLinks = fromMaybe 128 (linkCountLimit $ tracerProviderSpanLimits $ tracerProvider t)                          in frozenBoundedCollection limitedLinks $ fmap freezeLink links@@ -313,72 +303,86 @@         }  +ownCodeAttributes :: (HasCallStack) => H.HashMap Text Attribute+ownCodeAttributes = case getCallStack callStack of+  _ : caller : _ -> srcAttributes caller+  _ -> mempty+++callerAttributes :: (HasCallStack) => H.HashMap Text Attribute+callerAttributes = case getCallStack callStack of+  _ : _ : caller : _ -> srcAttributes caller+  _ -> mempty+++srcAttributes :: (String, SrcLoc) -> H.HashMap Text Attribute+srcAttributes (fn, loc) = H.fromList+  [ ("code.function", toAttribute $ T.pack fn)+  , ("code.namespace", toAttribute $ T.pack $ srcLocModule loc)+  , ("code.filepath", toAttribute $ T.pack $ srcLocFile loc)+  , ("code.lineno", toAttribute $ srcLocStartLine loc)+  , ("code.package", toAttribute $ T.pack $ srcLocPackage loc)+  ]+++{- | Attributes are added to the end of the span argument list, so will be discarded+ if the number of attributes in the span exceeds the limit.+-}+addAttributesToSpanArguments :: H.HashMap Text Attribute -> SpanArguments -> SpanArguments+addAttributesToSpanArguments attrs args = args {attributes = H.union (attributes args) attrs}++ {- | The simplest function for annotating code with trace information.   @since 0.0.1.0 -}-inSpan ::-  (MonadUnliftIO m, HasCallStack) =>-  Tracer ->-  -- | The name of the span. This may be updated later via 'updateName'-  Text ->-  -- | Additional options for creating the span, such as 'SpanKind',+inSpan+  :: (MonadUnliftIO m, HasCallStack)+  => Tracer+  -> Text+  -- ^ The name of the span. This may be updated later via 'updateName'+  -> SpanArguments+  -- ^ Additional options for creating the span, such as 'SpanKind',   -- span links, starting attributes, etc.-  SpanArguments ->-  -- | The action to perform. 'inSpan' will record the time spent on the+  -> m a+  -- ^ The action to perform. 'inSpan' will record the time spent on the   -- action without forcing strict evaluation of the result. Any uncaught   -- exceptions will be recorded and rethrown.-  m a ->-  m a-inSpan t n args m = inSpan'' t callStack n args (const m)+  -> m a+inSpan t n args m = inSpan'' t n (args {attributes = H.union (attributes args) callerAttributes}) (const m)  -inSpan' ::-  (MonadUnliftIO m, HasCallStack) =>-  Tracer ->-  -- | The name of the span. This may be updated later via 'updateName'-  Text ->-  SpanArguments ->-  (Span -> m a) ->-  m a-inSpan' t = inSpan'' t callStack+inSpan'+  :: (MonadUnliftIO m, HasCallStack)+  => Tracer+  -> Text+  -- ^ The name of the span. This may be updated later via 'updateName'+  -> SpanArguments+  -> (Span -> m a)+  -> m a+inSpan' t n args = inSpan'' t n (args {attributes = H.union (attributes args) callerAttributes})  -inSpan'' ::-  (MonadUnliftIO m, HasCallStack) =>-  Tracer ->-  -- | Record the location of the span in the codebase using the provided-  -- callstack for source location info.-  CallStack ->-  -- | The name of the span. This may be updated later via 'updateName'-  Text ->-  SpanArguments ->-  (Span -> m a) ->-  m a-inSpan'' t cs n args f = do+inSpan''+  :: (MonadUnliftIO m, HasCallStack)+  => Tracer+  -> Text+  -- ^ The name of the span. This may be updated later via 'updateName'+  -> SpanArguments+  -> (Span -> m a)+  -> m a+inSpan'' t n args f = do   bracketError     ( liftIO $ do         ctx <- getContext         s <- createSpanWithoutCallStack t ctx n args         adjustContext (insertSpan s)-        whenSpanIsRecording s $ do-          case getCallStack cs of-            [] -> pure ()-            (fn, loc) : _ -> do-              OpenTelemetry.Trace.Core.addAttributes-                s-                [ ("code.function", toAttribute $ T.pack fn)-                , ("code.namespace", toAttribute $ T.pack $ srcLocModule loc)-                , ("code.filepath", toAttribute $ T.pack $ srcLocFile loc)-                , ("code.lineno", toAttribute $ srcLocStartLine loc)-                , ("code.package", toAttribute $ T.pack $ srcLocPackage loc)-                ]         pure (lookupSpan ctx, s)     )     ( \e (parent, s) -> liftIO $ do         forM_ e $ \(SomeException inner) -> do           setStatus s $ Error $ T.pack $ displayException inner-          recordException s [] Nothing inner+          recordException s [("exception.escaped", toAttribute True)] Nothing inner         endSpan s Nothing         adjustContext $ \ctx ->           maybe (removeSpan ctx) (`insertSpan` ctx) parent@@ -392,7 +396,7 @@  created by this process, the span will return True until endSpan  is called. -}-isRecording :: MonadIO m => Span -> m Bool+isRecording :: (MonadIO m) => Span -> m Bool isRecording (Span s) = liftIO (isNothing . spanEnd <$> readIORef s) isRecording (FrozenSpan _) = pure True isRecording (Dropped _) = pure False@@ -418,15 +422,15 @@  @since 0.0.1.0 -}-addAttribute ::-  (MonadIO m, A.ToAttribute a) =>-  -- | Span to add the attribute to-  Span ->-  -- | Attribute name-  Text ->-  -- | Attribute value-  a ->-  m ()+addAttribute+  :: (MonadIO m, A.ToAttribute a)+  => Span+  -- ^ Span to add the attribute to+  -> Text+  -- ^ Attribute name+  -> a+  -- ^ Attribute value+  -> m () addAttribute (Span s) k v = liftIO $ modifyIORef' s $ \(!i) ->   i     { spanAttributes =@@ -446,7 +450,7 @@   @since 0.0.1.0 -}-addAttributes :: MonadIO m => Span -> [(Text, A.Attribute)] -> m ()+addAttributes :: (MonadIO m) => Span -> H.HashMap Text A.Attribute -> m () addAttributes (Span s) attrs = liftIO $ modifyIORef' s $ \(!i) ->   i     { spanAttributes =@@ -463,7 +467,7 @@   @since 0.0.1.0 -}-addEvent :: MonadIO m => Span -> NewEvent -> m ()+addEvent :: (MonadIO m) => Span -> NewEvent -> m () addEvent (Span s) NewEvent {..} = liftIO $ do   t <- maybe getTimestamp pure newEventTimestamp   modifyIORef' s $ \(!i) ->@@ -490,18 +494,27 @@   @since 0.0.1.0 -}-setStatus :: MonadIO m => Span -> SpanStatus -> m ()+setStatus :: (MonadIO m) => Span -> SpanStatus -> m () setStatus (Span s) st = liftIO $ modifyIORef' s $ \(!i) ->   i-    { spanStatus =-        if st > spanStatus i-          then st-          else spanStatus i+    { spanStatus = max st (spanStatus i)     } setStatus (FrozenSpan _) _ = pure () setStatus (Dropped _) _ = pure ()  +alterFlags :: (MonadIO m) => Span -> (TraceFlags -> TraceFlags) -> m ()+alterFlags (Span s) f = liftIO $ modifyIORef' s $ \(!i) ->+  i+    { spanContext =+        (spanContext i)+          { traceFlags = f $ traceFlags $ spanContext i+          }+    }+alterFlags (FrozenSpan _) _ = pure ()+alterFlags (Dropped _) _ = pure ()++ {- | Updates the Span name. Upon this update, any sampling behavior based on Span name will depend on the implementation. @@ -511,12 +524,12 @@  @since 0.0.1.0 -}-updateName ::-  MonadIO m =>-  Span ->-  -- | The new span name, which supersedes whatever was passed in when the Span was started-  Text ->-  m ()+updateName+  :: (MonadIO m)+  => Span+  -> Text+  -- ^ The new span name, which supersedes whatever was passed in when the Span was started+  -> m () updateName (Span s) n = liftIO $ modifyIORef' s $ \(!i) -> i {spanName = n} updateName (FrozenSpan _) _ = pure () updateName (Dropped _) _ = pure ()@@ -532,12 +545,12 @@  @since 0.0.1.0 -}-endSpan ::-  MonadIO m =>-  Span ->-  -- | Optional @Timestamp@ signalling the end time of the span. If not provided, the current time will be used.-  Maybe Timestamp ->-  m ()+endSpan+  :: (MonadIO m)+  => Span+  -> Maybe Timestamp+  -- ^ Optional @Timestamp@ signalling the end time of the span. If not provided, the current time will be used.+  -> m () endSpan (Span s) mts = liftIO $ do   ts <- maybe getTimestamp pure mts   (alreadyFinished, frozenS) <- atomicModifyIORef' s $ \(!i) ->@@ -558,7 +571,7 @@   @since 0.0.1.0 -}-recordException :: (MonadIO m, Exception e) => Span -> [(Text, Attribute)] -> Maybe Timestamp -> e -> m ()+recordException :: (MonadIO m, Exception e) => Span -> H.HashMap Text Attribute -> Maybe Timestamp -> e -> m () recordException s attrs ts e = liftIO $ do   cs <- whoCreated e   let message = T.pack $ show e@@ -566,11 +579,12 @@     NewEvent       { newEventName = "exception"       , newEventAttributes =-          attrs-            ++ [ ("exception.type", A.toAttribute $ T.pack $ show $ typeOf e)-               , ("exception.message", A.toAttribute message)-               , ("exception.stacktrace", A.toAttribute $ T.unlines $ map T.pack cs)-               ]+          H.union+            attrs+            [ ("exception.type", A.toAttribute $ T.pack $ show $ typeOf e)+            , ("exception.message", A.toAttribute message)+            , ("exception.stacktrace", A.toAttribute $ T.unlines $ map T.pack cs)+            ]       , newEventTimestamp = ts       } @@ -588,7 +602,7 @@ When extracting a SpanContext through the Propagators API, isRemote MUST return @True@, whereas for the SpanContext of any child spans it MUST return @False@. -}-spanIsRemote :: MonadIO m => Span -> m Bool+spanIsRemote :: (MonadIO m) => Span -> m Bool spanIsRemote (Span s) = liftIO $ do   i <- readIORef s   pure $ Types.isRemote $ Types.spanContext i@@ -599,7 +613,7 @@ {- | Really only intended for tests, this function does not conform  to semantic versioning . -}-unsafeReadSpan :: MonadIO m => Span -> m ImmutableSpan+unsafeReadSpan :: (MonadIO m) => Span -> m ImmutableSpan unsafeReadSpan = \case   Span ref -> liftIO $ readIORef ref   FrozenSpan _s -> error "This span is from another process"@@ -614,7 +628,7 @@  using it to copy / otherwise use the data to further enrich  instrumentation. -}-spanGetAttributes :: MonadIO m => Span -> m A.Attributes+spanGetAttributes :: (MonadIO m) => Span -> m A.Attributes spanGetAttributes = \case   Span ref -> do     s <- liftIO $ readIORef ref@@ -632,15 +646,15 @@   @since 0.0.1.0 -}-getTimestamp :: MonadIO m => m Timestamp+getTimestamp :: (MonadIO m) => m Timestamp getTimestamp = liftIO $ coerce @(IO TimeSpec) @(IO Timestamp) $ getTime Realtime  -limitBy ::-  Tracer ->-  -- | Attribute count-  (SpanLimits -> Maybe Int) ->-  AttributeLimits+limitBy+  :: Tracer+  -> (SpanLimits -> Maybe Int)+  -- ^ Attribute count+  -> AttributeLimits limitBy t countF =   AttributeLimits     { attributeCountLimit = countLimit@@ -700,7 +714,7 @@   You should generally use 'getGlobalTracerProvider' for most applications. -}-createTracerProvider :: MonadIO m => [Processor] -> TracerProviderOptions -> m TracerProvider+createTracerProvider :: (MonadIO m) => [Processor] -> TracerProviderOptions -> m TracerProvider createTracerProvider ps opts = liftIO $ do   let g = tracerProviderOptionsIdGenerator opts   pure $@@ -723,7 +737,7 @@   @since 0.0.1.0 -}-getGlobalTracerProvider :: MonadIO m => m TracerProvider+getGlobalTracerProvider :: (MonadIO m) => m TracerProvider getGlobalTracerProvider = liftIO $ readIORef globalTracer  @@ -735,7 +749,7 @@   @since 0.0.1.0 -}-setGlobalTracerProvider :: MonadIO m => TracerProvider -> m ()+setGlobalTracerProvider :: (MonadIO m) => TracerProvider -> m () setGlobalTracerProvider = liftIO . writeIORef globalTracer  @@ -777,7 +791,7 @@ makeTracer tp n TracerOptions {} = Tracer n tp  -getTracer :: MonadIO m => TracerProvider -> InstrumentationLibrary -> TracerOptions -> m Tracer+getTracer :: (MonadIO m) => TracerProvider -> InstrumentationLibrary -> TracerOptions -> m Tracer getTracer tp n TracerOptions {} = liftIO $ do   pure $ Tracer n tp {-# DEPRECATED getTracer "use makeTracer" #-}@@ -817,7 +831,7 @@   @since 0.0.1.0 -}-shutdownTracerProvider :: MonadIO m => TracerProvider -> m ()+shutdownTracerProvider :: (MonadIO m) => TracerProvider -> m () shutdownTracerProvider TracerProvider {..} = liftIO $ do   asyncShutdownResults <- forM tracerProviderProcessors $ \processor -> do     processorShutdown processor@@ -827,13 +841,13 @@ {- | This method provides a way for provider to immediately export all spans that have not yet  been exported for all the internal processors. -}-forceFlushTracerProvider ::-  MonadIO m =>-  TracerProvider ->-  -- | Optional timeout in microseconds, defaults to 5,000,000 (5s)-  Maybe Int ->-  -- | Result that denotes whether the flush action succeeded, failed, or timed out.-  m FlushResult+forceFlushTracerProvider+  :: (MonadIO m)+  => TracerProvider+  -> Maybe Int+  -- ^ Optional timeout in microseconds, defaults to 5,000,000 (5s)+  -> m FlushResult+  -- ^ Result that denotes whether the flush action succeeded, failed, or timed out. forceFlushTracerProvider TracerProvider {..} mtimeout = liftIO $ do   jobs <- forM tracerProviderProcessors $ \processor -> async $ do     processorForceFlush processor@@ -856,7 +870,7 @@ {- | Utility function to only perform costly attribute annotations  for spans that are actually -}-whenSpanIsRecording :: MonadIO m => Span -> m () -> m ()+whenSpanIsRecording :: (MonadIO m) => Span -> m () -> m () whenSpanIsRecording (Span ref) m = do   span_ <- liftIO $ readIORef ref   case spanEnd span_ of
src/OpenTelemetry/Trace/Monad.hs view
@@ -46,48 +46,49 @@   Span,   SpanArguments (..),   Tracer,+  addAttributesToSpanArguments,+  callerAttributes,   inSpan'',  )   -- | This is generally scoped by Monad stack to do different things-class Monad m => MonadTracer m where+class (Monad m) => MonadTracer m where   getTracer :: m Tracer  -inSpan ::-  (MonadUnliftIO m, MonadTracer m, HasCallStack) =>-  Text ->-  SpanArguments ->-  m a ->-  m a-inSpan n args m = OpenTelemetry.Trace.Monad.inSpan'' callStack n args (const m)+inSpan+  :: (MonadUnliftIO m, MonadTracer m, HasCallStack)+  => Text+  -> SpanArguments+  -> m a+  -> m a+inSpan n args m = OpenTelemetry.Trace.Monad.inSpan'' n (addAttributesToSpanArguments callerAttributes args) (const m)  -inSpan' ::-  (MonadUnliftIO m, MonadTracer m, HasCallStack) =>-  Text ->-  SpanArguments ->-  (Span -> m a) ->-  m a-inSpan' = OpenTelemetry.Trace.Monad.inSpan'' callStack+inSpan'+  :: (MonadUnliftIO m, MonadTracer m, HasCallStack)+  => Text+  -> SpanArguments+  -> (Span -> m a)+  -> m a+inSpan' n args f = OpenTelemetry.Trace.Monad.inSpan'' n (addAttributesToSpanArguments callerAttributes args) f  -inSpan'' ::-  (MonadUnliftIO m, MonadTracer m, HasCallStack) =>-  CallStack ->-  Text ->-  SpanArguments ->-  (Span -> m a) ->-  m a-inSpan'' cs n args f = do+inSpan''+  :: (MonadUnliftIO m, MonadTracer m, HasCallStack)+  => Text+  -> SpanArguments+  -> (Span -> m a)+  -> m a+inSpan'' n args f = do   t <- getTracer-  OpenTelemetry.Trace.Core.inSpan'' t cs n args f+  OpenTelemetry.Trace.Core.inSpan'' t n args f  -instance MonadTracer m => MonadTracer (IdentityT m) where+instance (MonadTracer m) => MonadTracer (IdentityT m) where   getTracer = lift getTracer  -instance {-# OVERLAPPABLE #-} MonadTracer m => MonadTracer (ReaderT r m) where+instance {-# OVERLAPPABLE #-} (MonadTracer m) => MonadTracer (ReaderT r m) where   getTracer = lift getTracer
src/OpenTelemetry/Trace/Sampler.hs view
@@ -1,6 +1,4 @@-------------------------------------------------------------------------------------------------------------------------------------------------------------+{-# LANGUAGE OverloadedLists #-}  {- |  Module      :  OpenTelemetry.Trace.Sampler@@ -146,10 +144,10 @@   @since 0.1.0.0 -}-parentBasedOptions ::-  -- | Root sampler-  Sampler ->-  ParentBasedOptions+parentBasedOptions+  :: Sampler+  -- ^ Root sampler+  -> ParentBasedOptions parentBasedOptions root =   ParentBasedOptions     { rootSampler = root
src/OpenTelemetry/Util.hs view
@@ -51,11 +51,11 @@ import Foreign.C (CInt (..)) import GHC.Base (Addr#) import GHC.Conc (ThreadId (ThreadId))+import GHC.Exts (unsafeCoerce#) import GHC.Generics import VectorBuilder.Builder (Builder) import qualified VectorBuilder.Builder as Builder import qualified VectorBuilder.Vector as Builder-import Unsafe.Coerce (unsafeCoerce#)   {- | Useful for annotating which constructor in an ADT was chosen@@ -71,7 +71,7 @@   genericConstrName :: f x -> String  -instance HasConstructor f => HasConstructor (D1 c f) where+instance (HasConstructor f) => HasConstructor (D1 c f) where   genericConstrName (M1 x) = genericConstrName x  @@ -80,11 +80,13 @@   genericConstrName (R1 r) = genericConstrName r  -instance Constructor c => HasConstructor (C1 c f) where+instance (Constructor c) => HasConstructor (C1 c f) where   genericConstrName = conName + foreign import ccall unsafe "rts_getThreadId" c_getThreadId :: Addr# -> CInt + -- | Get an int representation of a thread id getThreadId :: ThreadId -> Int getThreadId (ThreadId tid#) = fromIntegral $ c_getThreadId (unsafeCoerce# tid#)@@ -98,7 +100,7 @@   }  -instance forall a. Show a => Show (AppendOnlyBoundedCollection a) where+instance forall a. (Show a) => Show (AppendOnlyBoundedCollection a) where   showsPrec d AppendOnlyBoundedCollection {collection = c, maxSize = m, dropped = r} =     let vec = Builder.build c :: V.Vector a      in showParen (d > 10) $@@ -112,10 +114,10 @@   -- | Initialize a bounded collection that admits a maximum size-emptyAppendOnlyBoundedCollection ::-  -- | Maximum size-  Int ->-  AppendOnlyBoundedCollection a+emptyAppendOnlyBoundedCollection+  :: Int+  -- ^ Maximum size+  -> AppendOnlyBoundedCollection a emptyAppendOnlyBoundedCollection s = AppendOnlyBoundedCollection mempty s 0  @@ -145,7 +147,7 @@   deriving (Show)  -frozenBoundedCollection :: Foldable f => Int -> f a -> FrozenBoundedCollection a+frozenBoundedCollection :: (Foldable f) => Int -> f a -> FrozenBoundedCollection a frozenBoundedCollection maxSize_ coll = FrozenBoundedCollection (V.fromListN maxSize_ $ toList coll) (collLength - maxSize_)   where     collLength = length coll@@ -164,7 +166,7 @@   @since 0.1.0.0 -}-bracketError :: MonadUnliftIO m => m a -> (Maybe SomeException -> a -> m b) -> (a -> m c) -> m c+bracketError :: (MonadUnliftIO m) => m a -> (Maybe SomeException -> a -> m b) -> (a -> m c) -> m c bracketError before after thing = withRunInIO $ \run -> EUnsafe.mask $ \restore -> do   x <- run before   res1 <- EUnsafe.try $ restore $ run $ thing x
+ test/OpenTelemetry/BaggageSpec.hs view
@@ -0,0 +1,15 @@+module OpenTelemetry.BaggageSpec where++import qualified Data.HashMap.Strict as HashMap+import OpenTelemetry.Baggage+import Test.Hspec+++spec :: Spec+spec = describe "Baggage" $ do+  it "decodes simple header" $ do+    let baggage = values <$> decodeBaggageHeader "x-api-key=asdf"+    HashMap.mapKeys tokenValue <$> baggage `shouldBe` Right (HashMap.fromList [("x-api-key", Element {value = "asdf", properties = []})])+  it "decodes percent encoded header" $ do+    let baggage = values <$> decodeBaggageHeader "Authorization=Basic%20asdf"+    HashMap.mapKeys tokenValue <$> baggage `shouldBe` Right (HashMap.fromList [("Authorization", Element {value = "Basic asdf", properties = []})])
test/Spec.hs view
@@ -9,10 +9,11 @@ import Data.Maybe (isJust) import qualified Data.Vector as V import OpenTelemetry.Attributes (lookupAttribute)-import OpenTelemetry.Context-import OpenTelemetry.Trace.Core -- Specs +import qualified OpenTelemetry.BaggageSpec as Baggage+import OpenTelemetry.Context+import OpenTelemetry.Trace.Core import qualified OpenTelemetry.Trace.SamplerSpec as Sampler import qualified OpenTelemetry.Trace.TraceFlagsSpec as TraceFlags import OpenTelemetry.Util@@ -50,5 +51,6 @@   -- describe "inSpan" $ do   --   it "records exceptions" $ do   --     exceptionTest+  Baggage.spec   Sampler.spec   TraceFlags.spec