diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,15 @@ # Changelog for hs-opentelemetry-api +## Unreleased + +## 0.3.0.0 + +- Export `fromList` from `OpenTelemetry.Trace.TraceState` for creating TraceState from key-value pairs + +## 0.2.1.0 + +- defined and exported `toImmutableSpan` and `FrozenOrDropped` from `OpenTelemetry.Trace.Core` + ## 0.2.0.0 - `callerAttributes` and `ownCodeAttributes` now work properly if the call stack has been frozen. Hence most @@ -8,9 +18,9 @@ - Fixed precedence order of resource merge (#156). - Added the ability to add links to spans after creation (#152). - Correctly compute attribute length limits (#151). -- Add helper for reading boolean environment variables correctly (#11). +- Add helper for reading boolean environment variables correctly (#153). - Initial scaffolding for logging support. Renamed `Processor` to `SpanProcessor`. -- Export `FlushResult` (#960 +- Export `FlushResult` (#96) - Use `HashMap Text Attribute` instead of `[(Text, Attribute)]` as attributes - Improved conformance with semantic conventions. diff --git a/hs-opentelemetry-api.cabal b/hs-opentelemetry-api.cabal --- a/hs-opentelemetry-api.cabal +++ b/hs-opentelemetry-api.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack name: hs-opentelemetry-api -version: 0.2.0.0 +version: 0.3.0.0 synopsis: OpenTelemetry API for use by libraries for direct instrumentation or wrapper packages. description: Please see the README on GitHub at category: OpenTelemetry, Telemetry, Monitoring, Observability, Metrics @@ -28,6 +28,9 @@ library exposed-modules: OpenTelemetry.Attributes + OpenTelemetry.Attributes.Attribute + OpenTelemetry.Attributes.Key + OpenTelemetry.Attributes.Map OpenTelemetry.Baggage OpenTelemetry.Common OpenTelemetry.Context diff --git a/src/OpenTelemetry/Attributes.hs b/src/OpenTelemetry/Attributes.hs --- a/src/OpenTelemetry/Attributes.hs +++ b/src/OpenTelemetry/Attributes.hs @@ -25,16 +25,25 @@ - Attribute values expressing a numerical value of zero, an empty string, or an empty array are considered meaningful and MUST be stored and passed on to processors / exporters. -} module OpenTelemetry.Attributes ( - Attributes (attributesDropped), + Attributes, emptyAttributes, addAttribute, + addAttributeByKey, addAttributes, - getAttributes, lookupAttribute, + lookupAttributeByKey, + getAttributeMap, + getCount, + getDropped, Attribute (..), ToAttribute (..), + FromAttribute (..), PrimitiveAttribute (..), ToPrimitiveAttribute (..), + FromPrimitiveAttribute (..), + Map.AttributeMap, + AttributeKey (..), + module Key, -- * Attribute limits AttributeLimits (..), @@ -48,12 +57,13 @@ import Data.Data (Data) import qualified Data.HashMap.Strict as H import Data.Hashable (Hashable) -import Data.Int (Int64) -import Data.String (IsString (..)) import Data.Text (Text) import qualified Data.Text as T import GHC.Generics (Generic) import qualified Language.Haskell.TH.Syntax as TH +import OpenTelemetry.Attributes.Attribute (Attribute (..), FromAttribute (..), FromPrimitiveAttribute (..), PrimitiveAttribute (..), ToAttribute (..), ToPrimitiveAttribute (..)) +import OpenTelemetry.Attributes.Key as Key +import qualified OpenTelemetry.Attributes.Map as Map {- | Default attribute limits used in the global attribute limit configuration if no environment variables are set. @@ -72,7 +82,7 @@ data Attributes = Attributes - { attributes :: !(H.HashMap Text Attribute) + { attributeMap :: !Map.AttributeMap , attributesCount :: {-# UNPACK #-} !Int , attributesDropped :: {-# UNPACK #-} !Int } @@ -91,23 +101,27 @@ Nothing -> Attributes newAttrs newCount attributesDropped Just limit_ -> if newCount > limit_ - then Attributes attributes attributesCount (attributesDropped + 1) + then Attributes attributeMap attributesCount (attributesDropped + 1) else Attributes newAttrs newCount attributesDropped where - newAttrs = H.insert k (maybe id limitLengths attributeLengthLimit $ toAttribute v) attributes + newAttrs = H.insert k (maybe id limitLengths attributeLengthLimit $ toAttribute v) attributeMap newCount = H.size newAttrs {-# INLINE addAttribute #-} +addAttributeByKey :: (ToAttribute a) => AttributeLimits -> Attributes -> AttributeKey a -> a -> Attributes +addAttributeByKey limits attrs (AttributeKey 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) + then Attributes attributeMap attributesCount (attributesDropped + H.size attrs) else Attributes newAttrs newCount attributesDropped where - newAttrs = H.union attributes $ H.map (maybe id limitLengths attributeLengthLimit . toAttribute) attrs + newAttrs = H.union attributeMap $ H.map (maybe id limitLengths attributeLengthLimit . toAttribute) attrs newCount = H.size newAttrs {-# INLINE addAttributes #-} @@ -122,14 +136,26 @@ limitLengths limit (AttributeArray arr) = AttributeArray $ fmap (limitPrimAttr limit) arr -getAttributes :: Attributes -> (Int, H.HashMap Text Attribute) -getAttributes Attributes {..} = (attributesCount, attributes) +getAttributeMap :: Attributes -> Map.AttributeMap +getAttributeMap Attributes {..} = attributeMap +getCount :: Attributes -> Int +getCount Attributes {..} = attributesCount + + +getDropped :: Attributes -> Int +getDropped Attributes {..} = attributesDropped + + lookupAttribute :: Attributes -> Text -> Maybe Attribute -lookupAttribute Attributes {..} k = H.lookup k attributes +lookupAttribute Attributes {..} k = H.lookup k attributeMap +lookupAttributeByKey :: FromAttribute a => Attributes -> AttributeKey a -> Maybe a +lookupAttributeByKey Attributes {..} k = Map.lookupByKey k attributeMap + + {- | It is possible when adding attributes that a programming error might cause too many attributes to be added to an event. Thus, 'Attributes' use the limits set here as a safeguard against excessive memory consumption. @@ -145,128 +171,11 @@ deriving anyclass (Hashable) --- | Convert a Haskell value to a 'PrimitiveAttribute' value. -class ToPrimitiveAttribute a where - toPrimitiveAttribute :: a -> PrimitiveAttribute - - -{- | An attribute represents user-provided metadata about a span, link, or event. - - Telemetry tools may use this data to support high-cardinality querying, visualization - in waterfall diagrams, trace sampling decisions, and more. --} -data Attribute - = -- | An attribute representing a single primitive value - AttributeValue PrimitiveAttribute - | -- | An attribute representing an array of primitive values. - -- - -- All values in the array MUST be of the same primitive attribute type. - AttributeArray [PrimitiveAttribute] - deriving stock (Read, Show, Eq, Ord, Data, Generic, TH.Lift) - deriving anyclass (Hashable) - - -{- | Create a `TextAttribute` from the string value. - - @since 0.0.2.1 --} -instance IsString PrimitiveAttribute where - fromString = TextAttribute . fromString - - -{- | Create a `TextAttribute` from the string value. - - @since 0.0.2.1 --} -instance IsString Attribute where - fromString = AttributeValue . fromString - - -data PrimitiveAttribute - = TextAttribute Text - | BoolAttribute Bool - | DoubleAttribute Double - | IntAttribute Int64 - deriving stock (Read, Show, Eq, Ord, Data, Generic, TH.Lift) - deriving anyclass (Hashable) - - -{- | Convert a Haskell value to an 'Attribute' value. - - For most values, you can define an instance of 'ToPrimitiveAttribute' and use the default 'toAttribute' implementation: - - @ - - data Foo = Foo - - instance ToPrimitiveAttribute Foo where - toPrimitiveAttribute Foo = TextAttribute "Foo" - instance ToAttribute foo - - @ --} -class ToAttribute a where - toAttribute :: a -> Attribute - default toAttribute :: (ToPrimitiveAttribute a) => a -> Attribute - toAttribute = AttributeValue . toPrimitiveAttribute - - -instance ToPrimitiveAttribute PrimitiveAttribute where - toPrimitiveAttribute = id - - -instance ToAttribute PrimitiveAttribute where - toAttribute = AttributeValue - - -instance ToPrimitiveAttribute Text where - toPrimitiveAttribute = TextAttribute - - -instance ToAttribute Text - - -instance ToPrimitiveAttribute Bool where - toPrimitiveAttribute = BoolAttribute - - -instance ToAttribute Bool - - -instance ToPrimitiveAttribute Double where - toPrimitiveAttribute = DoubleAttribute - - -instance ToAttribute Double - - -instance ToPrimitiveAttribute Int64 where - toPrimitiveAttribute = IntAttribute - - -instance ToAttribute Int64 - - -instance ToPrimitiveAttribute Int where - toPrimitiveAttribute = IntAttribute . fromIntegral - - -instance ToAttribute Int - - -instance ToAttribute Attribute where - toAttribute = id - - -instance (ToPrimitiveAttribute a) => ToAttribute [a] where - toAttribute = AttributeArray . map toPrimitiveAttribute - - -- | Left-biased merge. unsafeMergeAttributesIgnoringLimits :: Attributes -> Attributes -> Attributes unsafeMergeAttributesIgnoringLimits left right = Attributes hm c d where - hm = attributes left <> attributes right + hm = attributeMap left <> attributeMap right c = H.size hm d = attributesDropped left + attributesDropped right diff --git a/src/OpenTelemetry/Attributes/Attribute.hs b/src/OpenTelemetry/Attributes/Attribute.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/Attributes/Attribute.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeFamilies #-} + +{- | +Module : OpenTelemetry.Attributes.Attribute +Copyright : (c) Ian Duncan, 2021 +License : BSD-3 +Description : Metadata values +Maintainer : Ian Duncan +Stability : experimental +Portability : non-portable (GHC extensions) +-} +module OpenTelemetry.Attributes.Attribute ( + Attribute (..), + ToAttribute (..), + FromAttribute (..), + PrimitiveAttribute (..), + ToPrimitiveAttribute (..), + FromPrimitiveAttribute (..), +) where + +import Data.Data (Data) +import Data.Hashable (Hashable) +import Data.Int (Int64) +import qualified Data.List as L +import Data.String (IsString (..)) +import Data.Text (Text) +import GHC.Generics (Generic) +import qualified Language.Haskell.TH.Syntax as TH +import Prelude hiding (lookup, map) + + +-- | Convert a Haskell value to a 'PrimitiveAttribute' value. +class ToPrimitiveAttribute a where + toPrimitiveAttribute :: a -> PrimitiveAttribute + + +class FromPrimitiveAttribute a where + fromPrimitiveAttribute :: PrimitiveAttribute -> Maybe a + + +{- | An attribute represents user-provided metadata about a span, link, or event. + + Telemetry tools may use this data to support high-cardinality querying, visualization + in waterfall diagrams, trace sampling decisions, and more. +-} +data Attribute + = -- | An attribute representing a single primitive value + AttributeValue PrimitiveAttribute + | -- | An attribute representing an array of primitive values. + -- + -- All values in the array MUST be of the same primitive attribute type. + AttributeArray [PrimitiveAttribute] + deriving stock (Read, Show, Eq, Ord, Data, Generic, TH.Lift) + deriving anyclass (Hashable) + + +{- | Create a `TextAttribute` from the string value. + + @since 0.0.2.1 +-} +instance IsString PrimitiveAttribute where + fromString = TextAttribute . fromString + + +{- | Create a `TextAttribute` from the string value. + + @since 0.0.2.1 +-} +instance IsString Attribute where + fromString = AttributeValue . fromString + + +data PrimitiveAttribute + = TextAttribute Text + | BoolAttribute Bool + | DoubleAttribute Double + | IntAttribute Int64 + deriving stock (Read, Show, Eq, Ord, Data, Generic, TH.Lift) + deriving anyclass (Hashable) + + +{- | Convert a Haskell value to an 'Attribute' value. + + For most values, you can define an instance of 'ToPrimitiveAttribute' and use the default 'toAttribute' implementation: + + @ + + data Foo = Foo + + instance ToPrimitiveAttribute Foo where + toPrimitiveAttribute Foo = TextAttribute "Foo" + instance ToAttribute foo + + @ +-} +class ToAttribute a where + toAttribute :: a -> Attribute + default toAttribute :: (ToPrimitiveAttribute a) => a -> Attribute + toAttribute = AttributeValue . toPrimitiveAttribute + + +class FromAttribute a where + fromAttribute :: Attribute -> Maybe a + default fromAttribute :: (FromPrimitiveAttribute a) => Attribute -> Maybe a + fromAttribute (AttributeValue v) = fromPrimitiveAttribute v + fromAttribute _ = Nothing + + +instance ToPrimitiveAttribute PrimitiveAttribute where + toPrimitiveAttribute = id + + +instance FromPrimitiveAttribute PrimitiveAttribute where + fromPrimitiveAttribute = Just + + +instance ToAttribute PrimitiveAttribute where + toAttribute = AttributeValue + + +instance FromAttribute PrimitiveAttribute where + fromAttribute (AttributeValue v) = Just v + fromAttribute _ = Nothing + + +instance ToPrimitiveAttribute Text where + toPrimitiveAttribute = TextAttribute + + +instance FromPrimitiveAttribute Text where + fromPrimitiveAttribute (TextAttribute v) = Just v + fromPrimitiveAttribute _ = Nothing + + +instance ToAttribute Text + + +instance FromAttribute Text + + +instance ToPrimitiveAttribute Bool where + toPrimitiveAttribute = BoolAttribute + + +instance FromPrimitiveAttribute Bool where + fromPrimitiveAttribute (BoolAttribute v) = Just v + fromPrimitiveAttribute _ = Nothing + + +instance ToAttribute Bool + + +instance FromAttribute Bool + + +instance ToPrimitiveAttribute Double where + toPrimitiveAttribute = DoubleAttribute + + +instance FromPrimitiveAttribute Double where + fromPrimitiveAttribute (DoubleAttribute v) = Just v + fromPrimitiveAttribute _ = Nothing + + +instance ToAttribute Double + + +instance FromAttribute Double + + +instance ToPrimitiveAttribute Int64 where + toPrimitiveAttribute = IntAttribute + + +instance FromPrimitiveAttribute Int64 where + fromPrimitiveAttribute (IntAttribute v) = Just v + fromPrimitiveAttribute _ = Nothing + + +instance ToAttribute Int64 + + +instance FromAttribute Int64 + + +instance ToPrimitiveAttribute Int where + toPrimitiveAttribute = IntAttribute . fromIntegral + + +instance FromPrimitiveAttribute Int where + fromPrimitiveAttribute (IntAttribute v) = Just $ fromIntegral v + fromPrimitiveAttribute _ = Nothing + + +instance ToAttribute Int + + +instance FromAttribute Int + + +instance ToAttribute Attribute where + toAttribute = id + + +instance FromAttribute Attribute where + fromAttribute = Just + + +instance (ToPrimitiveAttribute a) => ToAttribute [a] where + toAttribute = AttributeArray . L.map toPrimitiveAttribute + + +instance (FromPrimitiveAttribute a) => FromAttribute [a] where + fromAttribute (AttributeArray arr) = traverse fromPrimitiveAttribute arr + fromAttribute _ = Nothing diff --git a/src/OpenTelemetry/Attributes/Key.hs b/src/OpenTelemetry/Attributes/Key.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/Attributes/Key.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} + +{- | +Module : OpenTelemetry.Attributes.Key +Copyright : (c) Ian Duncan, 2021 +License : BSD-3 +Description : Names for key-value pair metadata +Maintainer : Ian Duncan +Stability : experimental +Portability : non-portable (GHC extensions) +-} +module OpenTelemetry.Attributes.Key ( + AttributeKey (..), + forget, +) where + +import Data.String (IsString (..)) +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) +import OpenTelemetry.Attributes.Attribute (Attribute) + + +{- | A 'AttributeKey' is a name for an attribute. The type parameter sets the type of the +attribute the key should be associated with. This is useful for standardising +attribute keys, since we can define both the key and the type of value it is +intended to record. + +For example, we might define: + +@ +-- See https://opentelemetry.io/docs/specs/semconv/attributes-registry/server/ +serverPortKey :: AttributeKey Int +serverPortKey = "server.port" +@ +-} +newtype AttributeKey a = AttributeKey {unkey :: Text} deriving stock (Show, Eq, Ord, Generic) + + +-- | Raise an error if the string is empty. +instance IsString (AttributeKey a) where + fromString "" = error "AttributeKey cannot be empty" + fromString s = AttributeKey $ T.pack s + + +forget :: AttributeKey a -> AttributeKey Attribute +forget = AttributeKey . unkey diff --git a/src/OpenTelemetry/Attributes/Map.hs b/src/OpenTelemetry/Attributes/Map.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/Attributes/Map.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeFamilies #-} + +{- | +Module : OpenTelemetry.Attributes.Map +Copyright : (c) Ian Duncan, 2021 +License : BSD-3 +Description : Key-value pair metadata without limits +Maintainer : Ian Duncan +Stability : experimental +Portability : non-portable (GHC extensions) +-} +module OpenTelemetry.Attributes.Map ( + AttributeMap, + insertByKey, + insertAttributeByKey, + lookupByKey, + lookupAttributeByKey, + module H, +) where + +import Data.HashMap.Strict as H +import Data.Text (Text) +import OpenTelemetry.Attributes.Attribute ( + Attribute, + FromAttribute (fromAttribute), + ToAttribute (toAttribute), + ) +import OpenTelemetry.Attributes.Key ( + AttributeKey (AttributeKey), + ) +import Prelude hiding (lookup, map) + + +type AttributeMap = H.HashMap Text Attribute + + +insertByKey :: ToAttribute a => AttributeKey a -> a -> AttributeMap -> AttributeMap +insertByKey (AttributeKey !k) !v = H.insert k $ toAttribute v + + +insertAttributeByKey :: AttributeKey a -> Attribute -> AttributeMap -> AttributeMap +insertAttributeByKey (AttributeKey !k) !v = H.insert k v + + +lookupByKey :: FromAttribute a => AttributeKey a -> AttributeMap -> Maybe a +lookupByKey (AttributeKey k) attributes = H.lookup k attributes >>= fromAttribute + + +lookupAttributeByKey :: AttributeKey a -> AttributeMap -> Maybe Attribute +lookupAttributeByKey (AttributeKey k) = H.lookup k diff --git a/src/OpenTelemetry/Contrib/CarryOns.hs b/src/OpenTelemetry/Contrib/CarryOns.hs --- a/src/OpenTelemetry/Contrib/CarryOns.hs +++ b/src/OpenTelemetry/Contrib/CarryOns.hs @@ -8,7 +8,8 @@ import Data.IORef (modifyIORef') import Data.Maybe (fromMaybe) import Data.Text (Text) -import OpenTelemetry.Attributes +import qualified OpenTelemetry.Attributes as Attributes +import OpenTelemetry.Attributes.Map (AttributeMap) import OpenTelemetry.Context import qualified OpenTelemetry.Context as Context import OpenTelemetry.Context.ThreadLocal @@ -16,12 +17,12 @@ import System.IO.Unsafe (unsafePerformIO) -carryOnKey :: Key (H.HashMap Text Attribute) +carryOnKey :: Key AttributeMap carryOnKey = unsafePerformIO $ newKey "carryOn" {-# NOINLINE carryOnKey #-} -alterCarryOns :: (MonadIO m) => (H.HashMap Text Attribute -> H.HashMap Text Attribute) -> m () +alterCarryOns :: (MonadIO m) => (AttributeMap -> AttributeMap) -> m () alterCarryOns f = adjustContext $ \ctxt -> Context.insert carryOnKey (f $ fromMaybe mempty $ Context.lookup carryOnKey ctxt) ctxt @@ -48,7 +49,7 @@ modifyIORef' spanRef $ \is -> is { spanAttributes = - OpenTelemetry.Attributes.addAttributes + Attributes.addAttributes (tracerProviderAttributeLimits $ tracerProvider $ spanTracer is) (spanAttributes is) carryOns diff --git a/src/OpenTelemetry/Internal/Trace/Types.hs b/src/OpenTelemetry/Internal/Trace/Types.hs --- a/src/OpenTelemetry/Internal/Trace/Types.hs +++ b/src/OpenTelemetry/Internal/Trace/Types.hs @@ -16,7 +16,7 @@ import Data.Text (Text) import Data.Vector (Vector) import Data.Word (Word8) -import Network.HTTP.Types (RequestHeaders, ResponseHeaders) +import Network.HTTP.Types (RequestHeaders) import OpenTelemetry.Attributes import OpenTelemetry.Common import OpenTelemetry.Context.Types @@ -73,7 +73,7 @@ , tracerProviderResources :: !MaterializedResources , tracerProviderAttributeLimits :: !AttributeLimits , tracerProviderSpanLimits :: !SpanLimits - , tracerProviderPropagators :: !(Propagator Context RequestHeaders ResponseHeaders) + , tracerProviderPropagators :: !(Propagator Context RequestHeaders RequestHeaders) } @@ -122,7 +122,7 @@ data NewLink = NewLink { linkContext :: !SpanContext -- ^ @SpanContext@ of the @Span@ to link to. - , linkAttributes :: H.HashMap Text Attribute + , linkAttributes :: AttributeMap -- ^ Zero or more Attributes further describing the link. } deriving (Show) @@ -163,7 +163,7 @@ { kind :: SpanKind -- ^ The kind of the span. See 'SpanKind's documentation for the semantics -- of the various values that may be specified. - , attributes :: H.HashMap Text Attribute + , attributes :: AttributeMap -- ^ 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. @@ -306,6 +306,17 @@ showsPrec d (Dropped ctx) = showParen (d > 10) $ showString "Dropped " . showsPrec 11 ctx +data FrozenOrDropped = SpanFrozen | SpanDropped deriving (Show, Eq) + + +-- | Extracts the values from a @Span@ if it is still mutable. Returns a @Left@ with @FrozenOrDropped@ if the @Span@ is frozen or dropped. +toImmutableSpan :: MonadIO m => Span -> m (Either FrozenOrDropped ImmutableSpan) +toImmutableSpan s = case s of + Span ioref -> Right <$> liftIO (readIORef ioref) + FrozenSpan _ctx -> pure $ Left SpanFrozen + Dropped _ctx -> pure $ Left SpanDropped + + {- | TraceFlags with the @sampled@ flag not set. This means that it is up to the sampling configuration to decide whether or not to sample the trace. -} @@ -397,7 +408,7 @@ data NewEvent = NewEvent { newEventName :: Text -- ^ The name of an event. Ideally this should be a relatively unique, but low cardinality value. - , newEventAttributes :: H.HashMap Text Attribute + , newEventAttributes :: AttributeMap -- ^ Additional context or metadata related to the event, (stack traces, callsites, etc.). , newEventTimestamp :: Maybe Timestamp -- ^ The time that the event occurred. @@ -448,7 +459,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, H.HashMap Text Attribute, TraceState) + , shouldSample :: Context -> TraceId -> Text -> SpanArguments -> IO (SamplingResult, AttributeMap, TraceState) } diff --git a/src/OpenTelemetry/LogAttributes.hs b/src/OpenTelemetry/LogAttributes.hs --- a/src/OpenTelemetry/LogAttributes.hs +++ b/src/OpenTelemetry/LogAttributes.hs @@ -7,7 +7,7 @@ emptyAttributes, addAttribute, addAttributes, - getAttributes, + getAttributeMap, lookupAttribute, AnyValue (..), ToValue (..), @@ -66,8 +66,8 @@ {-# INLINE addAttributes #-} -getAttributes :: LogAttributes -> (Int, H.HashMap Text AnyValue) -getAttributes LogAttributes {..} = (attributesCount, attributes) +getAttributeMap :: LogAttributes -> (Int, H.HashMap Text AnyValue) +getAttributeMap LogAttributes {..} = (attributesCount, attributes) lookupAttribute :: LogAttributes -> Text -> Maybe AnyValue diff --git a/src/OpenTelemetry/Propagator.hs b/src/OpenTelemetry/Propagator.hs --- a/src/OpenTelemetry/Propagator.hs +++ b/src/OpenTelemetry/Propagator.hs @@ -31,7 +31,7 @@ import Control.Monad import Control.Monad.IO.Class -import Data.Text +import Data.Text (Text) {- | diff --git a/src/OpenTelemetry/Resource/Service.hs b/src/OpenTelemetry/Resource/Service.hs --- a/src/OpenTelemetry/Resource/Service.hs +++ b/src/OpenTelemetry/Resource/Service.hs @@ -16,7 +16,7 @@ -} module OpenTelemetry.Resource.Service where -import Data.Text +import Data.Text (Text) import OpenTelemetry.Resource diff --git a/src/OpenTelemetry/Trace/Core.hs b/src/OpenTelemetry/Trace/Core.hs --- a/src/OpenTelemetry/Trace/Core.hs +++ b/src/OpenTelemetry/Trace/Core.hs @@ -72,6 +72,8 @@ -- * Span operations Span, + toImmutableSpan, + FrozenOrDropped (..), ImmutableSpan (..), SpanContext (..), -- | W3c Trace flags @@ -209,7 +211,9 @@ -- ^ Additional span information -> m Span -- ^ The created span. -createSpan t ctxt n args = createSpanWithoutCallStack t ctxt n (args {attributes = H.union (attributes args) callerAttributes}) + -- Try and infer source code information unless the user has set any of the attributes already, which + -- we take as an indication that our automatic strategy won't work well. +createSpan t ctxt n args = createSpanWithoutCallStack t ctxt n (addAttributesToSpanArgumentsIfNonePresent callerAttributes args) -- | The same thing as 'createSpan', except that it does not have a 'HasCallStack' constraint. @@ -289,7 +293,7 @@ , spanTracer = t } - when (A.attributesDropped (spanAttributes is) > 0) $ void logDroppedAttributes + when (A.getDropped (spanAttributes is) > 0) $ void logDroppedAttributes s <- newIORef is eResult <- try $ mapM_ (\processor -> spanProcessorOnStart processor s ctxt) $ tracerProviderProcessors $ tracerProvider t @@ -304,33 +308,65 @@ RecordAndSample -> mkRecordingSpan -ownCodeAttributes :: (HasCallStack) => H.HashMap Text Attribute +{- | +Creates source code attributes describing the caller of the current function. You should use this if you are getting +source code attributes from inside a function that is creating a span. + +Note: this will return nothing if the call stack is frozen. +-} +ownCodeAttributes :: (HasCallStack) => AttributeMap ownCodeAttributes = case getCallStack callStack of -- The call stack is (probably) not frozen and the top entry is our call. Assume we have a full call stack -- and look one further step up for our own code. - (("ownCodeAttributes", _) : ownCode : _) -> srcAttributes ownCode + (("ownCodeAttributes", ownCodeCalledAt) : (ownFunction, _ownFunctionCalledAt) : _) -> + -- The source location attributes for the call to 'ownCode' will do well enough to identify the function + fnAttributes ownFunction <> srcLocAttributes ownCodeCalledAt + (("ownCodeAttributes", ownCodeCalledAt) : _) -> + -- We couldn't determine the calling function, but we should still be able to see the call location + fnAttributes "" <> srcLocAttributes ownCodeCalledAt -- The call stack doesn't look like we expect, potentially frozen or empty. In this case we can't - -- really do much, so give up. + -- really do much, so give up. (see discussion below in 'callerAttributes') _ -> mempty -callerAttributes :: (HasCallStack) => H.HashMap Text Attribute +{- | +Creates source code attributes describing where the current function is called. You should use this if +you are getting source code attributes from inside a "span creation" function. + +Note: this will return nothing if the call stack is frozen. +-} +callerAttributes :: (HasCallStack) => AttributeMap callerAttributes = case getCallStack callStack of -- The call stack is (probably) not frozen and the top entry is our call. Assume we have a full call stack -- and look two further steps up for the caller. - (("callerAttributes", _) : _ : caller : _) -> srcAttributes caller - -- The call stack doesn't look like we expect. Guess that it got frozen, and so the most - -- useful thing to do is to assume that the "caller" is the top of the frozen call stack - (caller : _) -> srcAttributes caller - -- Empty call stack + (("callerAttributes", _callerAttributesCalledAt) : (_ownFunction, ownFunctionCalledAt) : (callerFunction, _) : _) -> + fnAttributes callerFunction <> srcLocAttributes ownFunctionCalledAt + (("callerAttributes", _callerAttributesCalledAt) : (_ownFunction, ownFunctionCalledAt) : _) -> + -- We couldn't determine the calling function, but we should still be able to see the call location + fnAttributes "" <> srcLocAttributes ownFunctionCalledAt + -- The call stack doesn't look like we expect. It could be empty (in which case we can't do anything), or frozen + -- + -- If it's frozen, there are at least two ways we could interpret it: + -- 1. The "current function" is the top of the call stack. This is likely if the call stack got frozen in a + -- helper function. + -- 2. The "caller" is the top of the call stack. This is likely if the call stack got frozen further up. + -- + -- This means we really don't know what is going on, so we can't pick something that will work in all + -- circumstances. So we do nothing, and rely on the user to set these themselves. _ -> mempty -srcAttributes :: (String, SrcLoc) -> H.HashMap Text Attribute -srcAttributes (fn, loc) = +fnAttributes :: String -> AttributeMap +fnAttributes fn = H.fromList [ ("code.function", toAttribute $ T.pack fn) - , ("code.namespace", toAttribute $ T.pack $ srcLocModule loc) + ] + + +srcLocAttributes :: SrcLoc -> AttributeMap +srcLocAttributes loc = + H.fromList + [ ("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) @@ -340,10 +376,18 @@ {- | 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 :: AttributeMap -> SpanArguments -> SpanArguments addAttributesToSpanArguments attrs args = args {attributes = H.union (attributes args) attrs} +-- | Add the given attributes to the span arguments, but only if *none* of them are present already. +addAttributesToSpanArgumentsIfNonePresent :: AttributeMap -> SpanArguments -> SpanArguments +addAttributesToSpanArgumentsIfNonePresent attrs args | shouldAddAttrs = addAttributesToSpanArguments attrs args + where + shouldAddAttrs = H.null $ H.intersection attrs (attributes args) +addAttributesToSpanArgumentsIfNonePresent _ args = args + + {- | The simplest function for annotating code with trace information. @since 0.0.1.0 @@ -361,7 +405,9 @@ -- action without forcing strict evaluation of the result. Any uncaught -- exceptions will be recorded and rethrown. -> m a -inSpan t n args m = inSpan'' t n (args {attributes = H.union (attributes args) callerAttributes}) (const m) +-- Try and infer source code information unless the user has set any of the attributes already, which +-- we take as an indication that our automatic strategy won't work well. +inSpan t n args m = inSpan'' t n (addAttributesToSpanArgumentsIfNonePresent callerAttributes args) (const m) inSpan' @@ -372,7 +418,9 @@ -> SpanArguments -> (Span -> m a) -> m a -inSpan' t n args = inSpan'' t n (args {attributes = H.union (attributes args) callerAttributes}) +-- Try and infer source code information unless the user has set any of the attributes already, which +-- we take as an indication that our automatic strategy won't work well. +inSpan' t n args = inSpan'' t n (addAttributesToSpanArgumentsIfNonePresent callerAttributes args) inSpan'' @@ -599,7 +647,7 @@ @since 0.0.1.0 -} -recordException :: (MonadIO m, Exception e) => Span -> H.HashMap Text Attribute -> Maybe Timestamp -> e -> m () +recordException :: (MonadIO m, Exception e) => Span -> AttributeMap -> Maybe Timestamp -> e -> m () recordException s attrs ts e = liftIO $ do cs <- whoCreated e let message = T.pack $ show e @@ -642,10 +690,12 @@ to semantic versioning . -} unsafeReadSpan :: (MonadIO m) => Span -> m ImmutableSpan -unsafeReadSpan = \case - Span ref -> liftIO $ readIORef ref - FrozenSpan _s -> error "This span is from another process" - Dropped _s -> error "This span was dropped" +unsafeReadSpan s = + toImmutableSpan s >>= \case + Right span -> pure span + Left frozenOrDropped -> case frozenOrDropped of + SpanFrozen -> error "This span is from another process" + SpanDropped -> error "This span was dropped" wrapSpanContext :: SpanContext -> Span @@ -715,7 +765,7 @@ , tracerProviderOptionsResources :: MaterializedResources , tracerProviderOptionsAttributeLimits :: AttributeLimits , tracerProviderOptionsSpanLimits :: SpanLimits - , tracerProviderOptionsPropagators :: Propagator Context RequestHeaders ResponseHeaders + , tracerProviderOptionsPropagators :: Propagator Context RequestHeaders RequestHeaders } @@ -782,7 +832,7 @@ getTracerProviderResources = tracerProviderResources -getTracerProviderPropagators :: TracerProvider -> Propagator Context RequestHeaders ResponseHeaders +getTracerProviderPropagators :: TracerProvider -> Propagator Context RequestHeaders RequestHeaders getTracerProviderPropagators = tracerProviderPropagators diff --git a/src/OpenTelemetry/Trace/Monad.hs b/src/OpenTelemetry/Trace/Monad.hs --- a/src/OpenTelemetry/Trace/Monad.hs +++ b/src/OpenTelemetry/Trace/Monad.hs @@ -29,7 +29,7 @@ -- , updateName -- , addAttribute -- , addAttributes - -- , getAttributes + -- , getAttributeMap -- , addEvent -- , NewEvent (..) -- Fundamental monad instances diff --git a/src/OpenTelemetry/Trace/Sampler.hs b/src/OpenTelemetry/Trace/Sampler.hs --- a/src/OpenTelemetry/Trace/Sampler.hs +++ b/src/OpenTelemetry/Trace/Sampler.hs @@ -36,7 +36,7 @@ import Data.Bits import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L -import Data.Text +import qualified Data.Text as T import Data.Word (Word64) import OpenTelemetry.Attributes (toAttribute) import OpenTelemetry.Context @@ -100,7 +100,7 @@ traceIdUpperBound = floor (fraction * fromIntegral ((1 :: Word64) `shiftL` 63)) :: Word64 sampler = Sampler - { getDescription = "TraceIdRatioBased{" <> pack (show fraction) <> "}" + { getDescription = "TraceIdRatioBased{" <> T.pack (show fraction) <> "}" , shouldSample = \ctxt tid _ _ -> do mspanCtxt <- sequence (getSpanContext <$> lookupSpan ctxt) let x = runGet getWord64be (L.fromStrict $ B.take 8 $ traceIdBytes tid) `shiftR` 1 diff --git a/src/OpenTelemetry/Trace/TraceState.hs b/src/OpenTelemetry/Trace/TraceState.hs --- a/src/OpenTelemetry/Trace/TraceState.hs +++ b/src/OpenTelemetry/Trace/TraceState.hs @@ -23,6 +23,7 @@ Key (..), Value (..), empty, + fromList, insert, update, delete, @@ -50,6 +51,14 @@ -- | An empty 'TraceState' key-value pair dictionary empty :: TraceState empty = TraceState [] + + +{- | Create a 'TraceState' from a list of key-value pairs + + O(1) +-} +fromList :: [(Key, Value)] -> TraceState +fromList = TraceState {- | Add a key-value pair to a 'TraceState' diff --git a/test/OpenTelemetry/Logs/CoreSpec.hs b/test/OpenTelemetry/Logs/CoreSpec.hs --- a/test/OpenTelemetry/Logs/CoreSpec.hs +++ b/test/OpenTelemetry/Logs/CoreSpec.hs @@ -64,7 +64,7 @@ addAttribute lr "anotherThing" ("another thing" :: LA.AnyValue) - (_, attrs) <- LA.getAttributes <$> logRecordGetAttributes lr + (_, attrs) <- LA.getAttributeMap <$> logRecordGetAttributes lr attrs `shouldBe` H.fromList [ ("anotherThing", "another thing") @@ -82,7 +82,7 @@ , ("twoThing", "the second another thing") ] - (_, attrs) <- LA.getAttributes <$> logRecordGetAttributes lr + (_, attrs) <- LA.getAttributeMap <$> logRecordGetAttributes lr attrs `shouldBe` H.fromList [ ("anotherThing", "another thing")