packages feed

hs-opentelemetry-api 0.2.0.0 → 0.3.0.0

raw patch · 16 files changed

+505/−178 lines, 16 files

Files

ChangeLog.md view
@@ -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.
hs-opentelemetry-api.cabal view
@@ -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 <https://github.com/iand675/hs-opentelemetry/tree/main/api#readme> 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
src/OpenTelemetry/Attributes.hs view
@@ -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
+ src/OpenTelemetry/Attributes/Attribute.hs view
@@ -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
+ src/OpenTelemetry/Attributes/Key.hs view
@@ -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
+ src/OpenTelemetry/Attributes/Map.hs view
@@ -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
src/OpenTelemetry/Contrib/CarryOns.hs view
@@ -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
src/OpenTelemetry/Internal/Trace/Types.hs view
@@ -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)   }
src/OpenTelemetry/LogAttributes.hs view
@@ -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
src/OpenTelemetry/Propagator.hs view
@@ -31,7 +31,7 @@  import Control.Monad import Control.Monad.IO.Class-import Data.Text+import Data.Text (Text)   {- |
src/OpenTelemetry/Resource/Service.hs view
@@ -16,7 +16,7 @@ -} module OpenTelemetry.Resource.Service where -import Data.Text+import Data.Text (Text) import OpenTelemetry.Resource
src/OpenTelemetry/Trace/Core.hs view
@@ -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 "<unknown>" <> 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 "<unknown>" <> 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
src/OpenTelemetry/Trace/Monad.hs view
@@ -29,7 +29,7 @@   -- , updateName   -- , addAttribute   -- , addAttributes-  -- , getAttributes+  -- , getAttributeMap   -- , addEvent   -- , NewEvent (..)   -- Fundamental monad instances
src/OpenTelemetry/Trace/Sampler.hs view
@@ -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
src/OpenTelemetry/Trace/TraceState.hs view
@@ -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'
test/OpenTelemetry/Logs/CoreSpec.hs view
@@ -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")