hs-opentelemetry-api 0.0.3.6 → 0.0.3.7
raw patch · 38 files changed
+2974/−2273 lines, 38 filesdep +transformersdep ~thread-utils-contextsetup-changed
Dependencies added: transformers
Dependency ranges changed: thread-utils-context
Files
- Setup.hs +2/−0
- hs-opentelemetry-api.cabal +19/−16
- src/OpenTelemetry/Attributes.hs +146/−94
- src/OpenTelemetry/Baggage.hs +128/−97
- src/OpenTelemetry/Common.hs +3/−1
- src/OpenTelemetry/Context.hs +59/−39
- src/OpenTelemetry/Context/ThreadLocal.hs +125/−79
- src/OpenTelemetry/Context/Types.hs +15/−9
- src/OpenTelemetry/Exporter.hs +20/−17
- src/OpenTelemetry/Internal/Trace/Id.hs +272/−0
- src/OpenTelemetry/Internal/Trace/Types.hs +200/−141
- src/OpenTelemetry/Logging/Core.hs +22/−17
- src/OpenTelemetry/Processor.hs +27/−23
- src/OpenTelemetry/Propagator.hs +53/−39
- src/OpenTelemetry/Resource.hs +132/−99
- src/OpenTelemetry/Resource/Cloud.hs +30/−25
- src/OpenTelemetry/Resource/Container.hs +24/−17
- src/OpenTelemetry/Resource/DeploymentEnvironment.hs +27/−19
- src/OpenTelemetry/Resource/Device.hs +14/−11
- src/OpenTelemetry/Resource/FaaS.hs +26/−19
- src/OpenTelemetry/Resource/Host.hs +30/−23
- src/OpenTelemetry/Resource/Kubernetes.hs +92/−54
- src/OpenTelemetry/Resource/OperatingSystem.hs +26/−18
- src/OpenTelemetry/Resource/Process.hs +38/−28
- src/OpenTelemetry/Resource/Service.hs +24/−17
- src/OpenTelemetry/Resource/Telemetry.hs +25/−19
- src/OpenTelemetry/Resource/Webengine.hs +14/−11
- src/OpenTelemetry/Trace/Core.hs +870/−771
- src/OpenTelemetry/Trace/Id.hs +45/−215
- src/OpenTelemetry/Trace/Id/Generator.hs +27/−22
- src/OpenTelemetry/Trace/Id/Generator/Dummy.hs +6/−4
- src/OpenTelemetry/Trace/Monad.hs +65/−47
- src/OpenTelemetry/Trace/Sampler.hs +156/−131
- src/OpenTelemetry/Trace/TraceState.hs +56/−41
- src/OpenTelemetry/Util.hs +86/−52
- test/OpenTelemetry/Trace/SamplerSpec.hs +51/−46
- test/OpenTelemetry/Trace/TraceFlagsSpec.hs +1/−0
- test/Spec.hs +18/−12
Setup.hs view
@@ -1,2 +1,4 @@ import Distribution.Simple++ main = defaultMain
hs-opentelemetry-api.cabal view
@@ -1,22 +1,22 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4.+-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack -name: hs-opentelemetry-api-version: 0.0.3.6-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-homepage: https://github.com/iand675/hs-opentelemetry#readme-bug-reports: https://github.com/iand675/hs-opentelemetry/issues-author: Ian Duncan-maintainer: ian@iankduncan.com-copyright: 2021 Ian Duncan-license: BSD3-license-file: LICENSE-build-type: Simple+name: hs-opentelemetry-api+version: 0.0.3.7+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+homepage: https://github.com/iand675/hs-opentelemetry#readme+bug-reports: https://github.com/iand675/hs-opentelemetry/issues+author: Ian Duncan, Jade Lovelace+maintainer: ian@iankduncan.com+copyright: 2023 Ian Duncan, Mercury Technologies+license: BSD3+license-file: LICENSE+build-type: Simple extra-source-files: README.md ChangeLog.md@@ -33,6 +33,7 @@ OpenTelemetry.Context OpenTelemetry.Context.ThreadLocal OpenTelemetry.Exporter+ OpenTelemetry.Internal.Trace.Id OpenTelemetry.Logging.Core OpenTelemetry.Processor OpenTelemetry.Propagator@@ -82,7 +83,8 @@ , mtl , template-haskell , text- , thread-utils-context ==0.2.*+ , thread-utils-context ==0.3.*+ , transformers , unliftio-core , unordered-containers , vault@@ -121,7 +123,8 @@ , mtl , template-haskell , text- , thread-utils-context ==0.2.*+ , thread-utils-context ==0.3.*+ , transformers , unliftio-core , unordered-containers , vault
src/OpenTelemetry/Attributes.hs view
@@ -1,67 +1,80 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE StrictData #-}+ -------------------------------------------------------------------------------- |--- Module : OpenTelemetry.Attributes--- Copyright : (c) Ian Duncan, 2021--- License : BSD-3--- Description : Key-value pair metadata used in 'OpenTelemetry.Trace.Span's, 'OpenTelemetry.Trace.Link's, and 'OpenTelemetry.Trace.Event's--- Maintainer : Ian Duncan--- Stability : experimental--- Portability : non-portable (GHC extensions)------ An Attribute is a key-value pair, which MUST have the following properties:--- --- - The attribute key MUST be a non-null and non-empty string.--- - The attribute value is either:--- - A primitive type: string, boolean, double precision floating point (IEEE 754-1985) or signed 64 bit integer.--- - An array of primitive type values. The array MUST be homogeneous, i.e., it MUST NOT contain values of different types. For protocols that do not natively support array values such values SHOULD be represented as JSON strings.--- - 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- , emptyAttributes- , addAttribute- , addAttributes- , getAttributes- , lookupAttribute- , Attribute (..)- , ToAttribute (..)- , PrimitiveAttribute (..)- , ToPrimitiveAttribute (..)++{- |+ Module : OpenTelemetry.Attributes+ Copyright : (c) Ian Duncan, 2021+ License : BSD-3+ Description : Key-value pair metadata used in 'OpenTelemetry.Trace.Span's, 'OpenTelemetry.Trace.Link's, and 'OpenTelemetry.Trace.Event's+ Maintainer : Ian Duncan+ Stability : experimental+ Portability : non-portable (GHC extensions)++ An Attribute is a key-value pair, which MUST have the following properties:++ - The attribute key MUST be a non-null and non-empty string.+ - The attribute value is either:+ - A primitive type: string, boolean, double precision floating point (IEEE 754-1985) or signed 64 bit integer.+ - An array of primitive type values. The array MUST be homogeneous, i.e., it MUST NOT contain values of different types. For protocols that do not natively support array values such values SHOULD be represented as JSON strings.+ - 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,+ emptyAttributes,+ addAttribute,+ addAttributes,+ getAttributes,+ lookupAttribute,+ Attribute (..),+ ToAttribute (..),+ PrimitiveAttribute (..),+ ToPrimitiveAttribute (..),+ -- * Attribute limits- , AttributeLimits (..)- , defaultAttributeLimits+ AttributeLimits (..),+ defaultAttributeLimits,+ -- * Unsafe utilities- , unsafeAttributesFromListIgnoringLimits- , unsafeMergeAttributesIgnoringLimits - ) where-import Data.Int ( Int64 )-import Data.Text ( Text )-import qualified Data.HashMap.Strict as H-import qualified Data.Text as T-import GHC.Generics+ unsafeAttributesFromListIgnoringLimits,+ unsafeMergeAttributesIgnoringLimits,+) where+ import Data.Data+import qualified Data.HashMap.Strict as H import Data.Hashable+import Data.Int (Int64)+import Data.List (foldl') import Data.String+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Generics --- | Default attribute limits used in the global attribute limit configuration if no environment variables are set.------ Values:------ - 'attributeCountLimit': @Just 128@--- - 'attributeLengthLimit': or @Nothing@++{- | Default attribute limits used in the global attribute limit configuration if no environment variables are set.++ Values:++ - 'attributeCountLimit': @Just 128@+ - 'attributeLengthLimit': or @Nothing@+-} defaultAttributeLimits :: AttributeLimits-defaultAttributeLimits = AttributeLimits- { attributeCountLimit = Just 128- , attributeLengthLimit = Nothing- }+defaultAttributeLimits =+ AttributeLimits+ { attributeCountLimit = Just 128+ , attributeLengthLimit = Nothing+ } + data Attributes = Attributes { attributes :: !(H.HashMap Text Attribute) , attributesCount :: {-# UNPACK #-} !Int@@ -69,20 +82,24 @@ } deriving stock (Show, Eq) + emptyAttributes :: Attributes emptyAttributes = Attributes mempty 0 0 + addAttribute :: ToAttribute a => AttributeLimits -> Attributes -> Text -> a -> Attributes-addAttribute AttributeLimits{..} Attributes{..} k v = case attributeCountLimit of+addAttribute AttributeLimits {..} Attributes {..} !k !v = case attributeCountLimit of Nothing -> Attributes newAttrs newCount attributesDropped- Just limit_ -> if newCount > limit_- then Attributes attributes attributesCount (attributesDropped + 1)- else Attributes newAttrs newCount attributesDropped+ Just limit_ ->+ if newCount > limit_+ 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+ newCount =+ if H.member k attributes+ then attributesCount+ else attributesCount + 1 limitPrimAttr limit_ (TextAttribute t) = TextAttribute (T.take limit_ t) limitPrimAttr _ attr = attr@@ -92,23 +109,27 @@ Just limit_ -> case attr of AttributeValue val -> AttributeValue $ limitPrimAttr limit_ val AttributeArray arr -> AttributeArray $ fmap (limitPrimAttr limit_) arr- {-# 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 limits = foldl' (\(!attrs') (!k, !v) -> addAttribute limits attrs' k v) {-# INLINE addAttributes #-} + getAttributes :: Attributes -> (Int, H.HashMap Text Attribute)-getAttributes Attributes{..} = (attributesCount, attributes)+getAttributes Attributes {..} = (attributesCount, attributes) + lookupAttribute :: Attributes -> Text -> Maybe Attribute-lookupAttribute Attributes{..} k = H.lookup k attributes+lookupAttribute Attributes {..} k = H.lookup k attributes --- | 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.++{- | 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.+-} data AttributeLimits = AttributeLimits { attributeCountLimit :: Maybe Int -- ^ The number of unique attributes that may be added to an 'Attributes' structure before they are dropped.@@ -119,36 +140,44 @@ deriving stock (Read, Show, Eq, Ord, Data, Generic) 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.++{- | 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- = AttributeValue PrimitiveAttribute- -- ^ An attribute representing a single primitive value- | AttributeArray [PrimitiveAttribute]- -- ^ An attribute representing an array of primitive values.- --- -- All values in the array MUST be of the same primitive attribute type.+ = -- | 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) deriving anyclass (Hashable) --- | Create a `TextAttribute` from the string value.------ @since 0.0.2.1++{- | 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++{- | 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@@ -157,58 +186,81 @@ deriving stock (Read, Show, Eq, Ord, Data, Generic) 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------ @++{- | 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 + unsafeMergeAttributesIgnoringLimits :: Attributes -> Attributes -> Attributes unsafeMergeAttributesIgnoringLimits (Attributes l lc ld) (Attributes r rc rd) = Attributes (l <> r) (lc + rc) (ld + rd)+ unsafeAttributesFromListIgnoringLimits :: [(Text, Attribute)] -> Attributes unsafeAttributesFromListIgnoringLimits l = Attributes hm c 0
src/OpenTelemetry/Baggage.hs view
@@ -4,118 +4,135 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-}+ -------------------------------------------------------------------------------- |--- Module : OpenTelemetry.Baggage--- Copyright : (c) Ian Duncan, 2021--- License : BSD-3--- Description : Serializable annotations to add user-defined values to telemetry--- Maintainer : Ian Duncan--- Stability : experimental--- Portability : non-portable (GHC extensions)------ Baggage is used to annotate telemetry, adding context and information to metrics, traces, and logs. --- It is a set of name/value pairs describing user-defined properties.------ Note: if you are trying to add data annotations specific to a single trace span, you should use--- 'OpenTelemetry.Trace.addAttribute' and 'OpenTelemetry.Trace.addAttributes'---+ ------------------------------------------------------------------------------module OpenTelemetry.Baggage - (++{- |+ Module : OpenTelemetry.Baggage+ Copyright : (c) Ian Duncan, 2021+ License : BSD-3+ Description : Serializable annotations to add user-defined values to telemetry+ Maintainer : Ian Duncan+ Stability : experimental+ Portability : non-portable (GHC extensions)++ Baggage is used to annotate telemetry, adding context and information to metrics, traces, and logs.+ It is a set of name/value pairs describing user-defined properties.++ Note: if you are trying to add data annotations specific to a single trace span, you should use+ 'OpenTelemetry.Trace.addAttribute' and 'OpenTelemetry.Trace.addAttributes'+-}+module OpenTelemetry.Baggage ( -- * Constructing 'Baggage' structures- Baggage- , empty- , fromHashMap- , values- , Token- , token- , mkToken- , tokenValue- , Element(..)- , element- , property- , InvalidBaggage(..)+ Baggage,+ empty,+ fromHashMap,+ values,+ Token,+ token,+ mkToken,+ tokenValue,+ Element (..),+ element,+ property,+ InvalidBaggage (..),+ -- * Modifying 'Baggage'- , insert- , delete+ insert,+ delete,+ -- * Encoding and decoding 'Baggage'- , encodeBaggageHeader- , encodeBaggageHeaderB- , decodeBaggageHeader - , decodeBaggageHeaderP- ) where+ encodeBaggageHeader,+ encodeBaggageHeaderB,+ decodeBaggageHeader,+ decodeBaggageHeaderP,+) where+ import Control.Applicative hiding (empty) import qualified Data.Attoparsec.ByteString.Char8 as P-import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Builder.Extra as BS+import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Builder.Extra as BS import Data.ByteString.Unsafe (unsafePackAddressLen) import Data.CharSet (CharSet) import qualified Data.CharSet as C-import Data.Hashable import qualified Data.HashMap.Strict as H+import Data.Hashable import Data.List (intersperse) import Data.Text (Text) import qualified Data.Text as T-import Data.Text.Encoding (encodeUtf8, decodeUtf8)-import qualified Data.ByteString.Builder as B+import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Language.Haskell.TH.Lib import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import Network.HTTP.Types.URI import System.IO.Unsafe --- | A key for a baggage entry, restricted to the set of valid characters--- specified in the @token@ definition of RFC 2616: ------ https://www.rfc-editor.org/rfc/rfc2616#section-2.2++{- | A key for a baggage entry, restricted to the set of valid characters+ specified in the @token@ definition of RFC 2616:++ https://www.rfc-editor.org/rfc/rfc2616#section-2.2+-} newtype Token = Token ByteString deriving stock (Show, Eq, Ord) deriving newtype (Hashable) + -- | Convert a 'Token' into a 'ByteString' tokenValue :: Token -> ByteString tokenValue (Token t) = t -instance Lift Token where #if MIN_VERSION_template_haskell(2, 17, 0)+instance Lift Token where liftTyped (Token tok) = liftCode $ unsafeTExpCoerce $ bsToExp tok #else+instance Lift Token where liftTyped (Token tok) = unsafeTExpCoerce $ bsToExp tok #endif --- | An entry into the baggage ++-- | An entry into the baggage data Element = Element { value :: Text , properties :: [Property] } deriving stock (Show, Eq) + element :: Text -> Element element t = Element t [] + data Property = Property { propertyKey :: Token , propertyValue :: Maybe Text } deriving stock (Show, Eq) + property :: Token -> Maybe Text -> Property property = Property --- | Baggage is used to annotate telemetry, adding context and information to metrics, traces, and logs. --- It is a set of name/value pairs describing user-defined properties. --- Each name in Baggage is associated with exactly one value.++{- | Baggage is used to annotate telemetry, adding context and information to metrics, traces, and logs.+ It is a set of name/value pairs describing user-defined properties.+ Each name in Baggage is associated with exactly one value.+-} newtype Baggage = Baggage (H.HashMap Token Element) deriving stock (Show, Eq) deriving newtype (Semigroup) + tokenCharacters :: CharSet tokenCharacters = C.fromList "!#$%&'*+-.^_`|~0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + -- Ripped from file-embed-0.0.13 bsToExp :: Monad m => ByteString -> m Exp #if MIN_VERSION_template_haskell(2, 5, 0)@@ -140,19 +157,22 @@ return $! AppE helper $! LitE $! StringL chars #endif + mkToken :: Text -> Maybe Token mkToken txt | txt `T.compareLength` 4096 == GT = Nothing | T.all (`C.member` tokenCharacters) txt = Just $ Token $ encodeUtf8 txt | otherwise = Nothing + token :: QuasiQuoter-token = QuasiQuoter- { quoteExp = parseExp- , quotePat = \_ -> fail "Token as pattern not implemented"- , quoteType = \_ -> fail "Can't use a Baggage Token as a type"- , quoteDec = \_ -> fail "Can't use a Baggage Token as a declaration"- }+token =+ QuasiQuoter+ { quoteExp = parseExp+ , quotePat = \_ -> fail "Token as pattern not implemented"+ , quoteType = \_ -> fail "Can't use a Baggage Token as a type"+ , quoteDec = \_ -> fail "Can't use a Baggage Token as a declaration"+ } where parseExp = \str -> case mkToken $ T.pack str of Nothing -> fail (show str ++ " is not a valid Token.")@@ -165,36 +185,40 @@ | TooManyListMembers | Empty --- TODO: The fact that this can be a max of 8192 bytes ++-- TODO: The fact that this can be a max of 8192 bytes -- should allow this to optimized pretty heavily encodeBaggageHeader :: Baggage -> ByteString-encodeBaggageHeader = - L.toStrict . - BS.toLazyByteStringWith (BS.untrimmedStrategy (8192 + 16) BS.smallChunkSize) L.empty .- encodeBaggageHeaderB+encodeBaggageHeader =+ L.toStrict+ . BS.toLazyByteStringWith (BS.untrimmedStrategy (8192 + 16) BS.smallChunkSize) L.empty+ . encodeBaggageHeaderB + encodeBaggageHeaderB :: Baggage -> B.Builder encodeBaggageHeaderB (Baggage bmap) =- mconcat $ - intersperse (B.char7 ',') $ - map go $- H.toList bmap+ mconcat $+ intersperse (B.char7 ',') $+ map go $+ H.toList bmap where- go (Token k, Element v props) = - B.byteString k <>- B.char7 '=' <>- urlEncodeBuilder False (encodeUtf8 v) <>- (mconcat $ intersperse (B.char7 ';') $ map propEncoder props)- propEncoder (Property (Token k) mv) = - B.byteString k <>- maybe - mempty - (\v -> B.char7 '=' <> urlEncodeBuilder False (encodeUtf8 v))- mv+ go (Token k, Element v props) =+ B.byteString k+ <> B.char7 '='+ <> urlEncodeBuilder False (encodeUtf8 v)+ <> (mconcat $ intersperse (B.char7 ';') $ map propEncoder props)+ propEncoder (Property (Token k) mv) =+ B.byteString k+ <> maybe+ mempty+ (\v -> B.char7 '=' <> urlEncodeBuilder False (encodeUtf8 v))+ mv + decodeBaggageHeader :: ByteString -> Either String Baggage decodeBaggageHeader = P.parseOnly decodeBaggageHeaderP + decodeBaggageHeaderP :: P.Parser Baggage decodeBaggageHeaderP = do owsP@@ -207,21 +231,22 @@ owsP = P.skipWhile (`C.member` owsSet) memberP :: P.Parser (Token, Element) memberP = do- tok <- tokenP + tok <- tokenP owsP _ <- P.char8 '=' owsP val <- valP props <- many (owsP >> P.char8 ';' >> owsP >> propertyP) pure (tok, Element val props)- valueSet = C.fromList $- concat - [ ['\x21']- , ['\x23'..'\x2B']- , ['\x2D'..'\x3A']- , ['\x3C'..'\x5B']- , ['\x5D'..'\x7E']- ]+ valueSet =+ C.fromList $+ concat+ [ ['\x21']+ , ['\x23' .. '\x2B']+ , ['\x2D' .. '\x3A']+ , ['\x3C' .. '\x5B']+ , ['\x5D' .. '\x7E']+ ] tokenP :: P.Parser Token tokenP = Token <$> P.takeWhile1 (`C.member` tokenCharacters) valP = decodeUtf8 <$> P.takeWhile (`C.member` valueSet)@@ -235,29 +260,35 @@ Just <$> valP pure $ Property key val + -- | An empty initial baggage value empty :: Baggage empty = Baggage H.empty -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 ::+ -- | 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 k v (Baggage c) = Baggage (H.insert k v c) + -- | Delete a key/value pair from the baggage.-delete :: Token -> Baggage -> Baggage +delete :: Token -> Baggage -> Baggage delete k (Baggage c) = Baggage (H.delete k c) --- | Returns the name/value pairs in the `Baggage`. The order of name/value pairs--- is not significant.------ @since 0.0.1.0++{- | Returns the name/value pairs in the `Baggage`. The order of name/value pairs+ is not significant.++ @since 0.0.1.0+-} values :: Baggage -> H.HashMap Token Element values (Baggage m) = m+ -- | Convert a 'H.HashMap' into 'Baggage' fromHashMap :: H.HashMap Token Element -> Baggage
src/OpenTelemetry/Common.hs view
@@ -1,10 +1,12 @@ module OpenTelemetry.Common where -import System.Clock (TimeSpec) import Data.Word (Word8)+import System.Clock (TimeSpec) + newtype Timestamp = Timestamp TimeSpec deriving (Read, Show, Eq, Ord)+ -- | Contain details about the trace. Unlike TraceState values, TraceFlags are present in all traces. The current version of the specification only supports a single flag called sampled. newtype TraceFlags = TraceFlags Word8
src/OpenTelemetry/Context.hs view
@@ -1,43 +1,47 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}+ -------------------------------------------------------------------------------- |--- Module : OpenTelemetry.Context--- Copyright : (c) Ian Duncan, 2021--- License : BSD-3--- Description : Carrier for execution-scoped values across API boundaries--- Maintainer : Ian Duncan--- Stability : experimental--- Portability : non-portable (GHC extensions)------ The ability to correlate events across service boundaries is one of the principle concepts behind distributed tracing. To find these correlations, components in a distributed system need to be able to collect, store, and transfer metadata referred to as context.------ A context will often have information identifying the current span and trace, and can contain arbitrary correlations as key-value pairs.------ Propagation is the means by which context is bundled and transferred in and across services, often via HTTP headers.------ Together, context and propagation represent the engine behind distributed tracing.---+ ------------------------------------------------------------------------------module OpenTelemetry.Context- ( Key(keyName)- , newKey- , Context- , HasContext(..)- , empty- , lookup- , insert++{- |+ Module : OpenTelemetry.Context+ Copyright : (c) Ian Duncan, 2021+ License : BSD-3+ Description : Carrier for execution-scoped values across API boundaries+ Maintainer : Ian Duncan+ Stability : experimental+ Portability : non-portable (GHC extensions)++ The ability to correlate events across service boundaries is one of the principle concepts behind distributed tracing. To find these correlations, components in a distributed system need to be able to collect, store, and transfer metadata referred to as context.++ A context will often have information identifying the current span and trace, and can contain arbitrary correlations as key-value pairs.++ Propagation is the means by which context is bundled and transferred in and across services, often via HTTP headers.++ Together, context and propagation represent the engine behind distributed tracing.+-}+module OpenTelemetry.Context (+ Key (keyName),+ newKey,+ Context,+ HasContext (..),+ empty,+ lookup,+ insert, -- , insertWith- , adjust- , delete- , union- , insertSpan- , lookupSpan- , removeSpan- , insertBaggage- , lookupBaggage- , removeBaggage- ) where+ adjust,+ delete,+ union,+ insertSpan,+ lookupSpan,+ removeSpan,+ insertBaggage,+ lookupBaggage,+ removeBaggage,+) where+ import Control.Monad.IO.Class import Data.Maybe import Data.Text (Text)@@ -45,26 +49,32 @@ import OpenTelemetry.Baggage (Baggage) import OpenTelemetry.Context.Types import OpenTelemetry.Internal.Trace.Types-import Prelude hiding (lookup) import System.IO.Unsafe+import Prelude hiding (lookup) + newKey :: MonadIO m => Text -> m (Key a) newKey n = liftIO (Key n <$> V.newKey) + class HasContext s where contextL :: Lens' s Context + empty :: Context empty = Context V.empty + lookup :: Key a -> Context -> Maybe a lookup (Key _ k) (Context v) = V.lookup k v + insert :: Key a -> a -> Context -> Context insert (Key _ k) x (Context v) = Context $ V.insert k x v --- insertWith --- :: (a -> a -> a) ++-- insertWith+-- :: (a -> a -> a) -- -- ^ new value -> old value -> result -- -> Key a -> a -> Context -> Context -- insertWith f (Key _ k) x (Context v) = Context $ case V.lookup k of@@ -74,36 +84,46 @@ adjust :: (a -> a) -> Key a -> Context -> Context adjust f (Key _ k) (Context v) = Context $ V.adjust f k v + delete :: Key a -> Context -> Context delete (Key _ k) (Context v) = Context $ V.delete k v + union :: Context -> Context -> Context union (Context v1) (Context v2) = Context $ V.union v1 v2 + spanKey :: Key Span spanKey = unsafePerformIO $ newKey "span" {-# NOINLINE spanKey #-} + lookupSpan :: Context -> Maybe Span lookupSpan = lookup spanKey + insertSpan :: Span -> Context -> Context insertSpan = insert spanKey -removeSpan :: Context -> Context ++removeSpan :: Context -> Context removeSpan = delete spanKey + baggageKey :: Key Baggage baggageKey = unsafePerformIO $ newKey "baggage" {-# NOINLINE baggageKey #-} + lookupBaggage :: Context -> Maybe Baggage lookupBaggage = lookup baggageKey + insertBaggage :: Baggage -> Context -> Context insertBaggage b c = case lookup baggageKey c of Nothing -> insert baggageKey b c Just b' -> insert baggageKey (b <> b') c+ removeBaggage :: Context -> Context removeBaggage = delete baggageKey
src/OpenTelemetry/Context/ThreadLocal.hs view
@@ -1,124 +1,170 @@ {-# LANGUAGE UnliftedFFITypes #-} -------------------------------------------------------------------------------- |--- Module : OpenTelemetry.Context.ThreadLocal--- Copyright : (c) Ian Duncan, 2021--- License : BSD-3--- Description : State management for 'OpenTelemetry.Context.Context' on a per-thread basis.--- Maintainer : Ian Duncan--- Stability : experimental--- Portability : non-portable (GHC extensions)------ Thread-local contexts may be attached as implicit state at a per-Haskell-thread--- level.------ This module uses a fair amount of GHC internals to enable performing--- lookups of context for any threads that are alive. Caution should be--- taken for consumers of this module to not retain ThreadId references--- indefinitely, as that could delay cleanup of thread-local state.------ Thread-local contexts have the following semantics:------ - A value 'attach'ed to a 'ThreadId' will remain alive at least as long--- as the 'ThreadId'. --- - A value may be detached from a 'ThreadId' via 'detach' by the--- library consumer without detriment.--- - No guarantees are made about when a value will be garbage-collected--- once all references to 'ThreadId' have been dropped. However, this simply--- means in practice that any unused contexts will cleaned up upon the next--- garbage collection and may not be actively freed when the program exits.---+ ------------------------------------------------------------------------------module OpenTelemetry.Context.ThreadLocal - ( ++{- |+ Module : OpenTelemetry.Context.ThreadLocal+ Copyright : (c) Ian Duncan, 2021+ License : BSD-3+ Description : State management for 'OpenTelemetry.Context.Context' on a per-thread basis.+ Maintainer : Ian Duncan+ Stability : experimental+ Portability : non-portable (GHC extensions)++ Thread-local contexts may be attached as implicit state at a per-Haskell-thread+ level.++ This module uses a fair amount of GHC internals to enable performing+ lookups of context for any threads that are alive. Caution should be+ taken for consumers of this module to not retain ThreadId references+ indefinitely, as that could delay cleanup of thread-local state.++ Thread-local contexts have the following semantics:++ - A value 'attach'ed to a 'ThreadId' will remain alive at least as long+ as the 'ThreadId'.+ - A value may be detached from a 'ThreadId' via 'detach' by the+ library consumer without detriment.+ - No guarantees are made about when a value will be garbage-collected+ once all references to 'ThreadId' have been dropped. However, this simply+ means in practice that any unused contexts will cleaned up upon the next+ garbage collection and may not be actively freed when the program exits.+-}+module OpenTelemetry.Context.ThreadLocal ( -- * Thread-local context- getContext- , lookupContext- , attachContext- , detachContext- , adjustContext+ getContext,+ lookupContext,+ attachContext,+ detachContext,+ adjustContext,+ -- ** Generalized thread-local context functions- -- You should not use these without using some sort of specific cross-thread coordination mechanism, ++ -- You should not use these without using some sort of specific cross-thread coordination mechanism, -- as there is no guarantee of what work the remote thread has done yet.- , lookupContextOnThread- , attachContextOnThread- , detachContextFromThread- , adjustContextOnThread- ) where-import OpenTelemetry.Context (Context, empty)+ lookupContextOnThread,+ attachContextOnThread,+ detachContextFromThread,+ adjustContextOnThread,++ -- ** Debugging tools+ threadContextMap,+) where+ import Control.Concurrent -- import Control.Concurrent.Async import Control.Concurrent.Thread.Storage+-- import Control.Monad++import Control.Monad (void) import Control.Monad.IO.Class import Data.Maybe (fromMaybe)--- import Control.Monad+import OpenTelemetry.Context (Context, empty) import System.IO.Unsafe import Prelude hiding (lookup)-import Control.Monad (void) + type ThreadContextMap = ThreadStorageMap Context ++{- | This is a global variable that is used to store the thread-local context map.+ It is not intended to be used directly for production purposes, but is exposed for debugging purposes.+-} threadContextMap :: ThreadContextMap threadContextMap = unsafePerformIO newThreadStorageMap {-# NOINLINE threadContextMap #-} --- | Retrieve a stored 'Context' for the current thread, or an empty context if none exists.------ Warning: this can easily cause disconnected traces if libraries don't explicitly set the--- context on forked threads.------ @since 0.0.1.0++{- | Retrieve a stored 'Context' for the current thread, or an empty context if none exists.++ Warning: this can easily cause disconnected traces if libraries don't explicitly set the+ context on forked threads.++ @since 0.0.1.0+-} getContext :: MonadIO m => m Context getContext = fromMaybe empty <$> lookupContext --- | Retrieve a stored 'Context' for the current thread, if it exists.------ @since 0.0.1.0++{- | Retrieve a stored 'Context' for the current thread, if it exists.++ @since 0.0.1.0+-} lookupContext :: MonadIO m => m (Maybe Context) lookupContext = lookup threadContextMap --- | Retrieve a stored 'Context' for the provided 'ThreadId', if it exists.------ @since 0.0.1.0++{- | Retrieve a stored 'Context' for the provided 'ThreadId', if it exists.++ @since 0.0.1.0+-} lookupContextOnThread :: MonadIO m => ThreadId -> m (Maybe Context) lookupContextOnThread = lookupOnThread threadContextMap --- | Store a given 'Context' for the current thread, returning any context previously stored.------ @since 0.0.1.0++{- | Store a given 'Context' for the current thread, returning any context previously stored.++ @since 0.0.1.0+-} attachContext :: MonadIO m => Context -> m (Maybe Context) attachContext = attach threadContextMap --- | Store a given 'Context' for the provided 'ThreadId', returning any context previously stored.------ @since 0.0.1.0++{- | Store a given 'Context' for the provided 'ThreadId', returning any context previously stored.++ @since 0.0.1.0+-} attachContextOnThread :: MonadIO m => ThreadId -> Context -> m (Maybe Context) attachContextOnThread = attachOnThread threadContextMap --- | Remove a stored 'Context' for the current thread, returning any context previously stored.------ @since 0.0.1.0++{- | Remove a stored 'Context' for the current thread, returning any context previously stored.++The detach functions don't generally need to be called manually, because finalizers will automatically+clean up contexts when a thread has completed and been garbage collected. If you are replacing a context+on a long-lived thread by detaching and attaching, use `adjustContext (const newContext)` instead to avoid+registering additional finalizer functions to be called on thread exit.++ @since 0.0.1.0+-} detachContext :: MonadIO m => m (Maybe Context) detachContext = detach threadContextMap --- | Remove a stored 'Context' for the provided 'ThreadId', returning any context previously stored.------ @since 0.0.1.0++{- | Remove a stored 'Context' for the provided 'ThreadId', returning any context previously stored.++The detach functions don't generally need to be called manually, because finalizers will automatically+clean up contexts when a thread has completed and been garbage collected. If you are replacing a context+on a long-lived thread by detaching and attaching, use `adjustContext (const newContext)` instead to avoid+registering additional finalizer functions to be called on thread exit.++ @since 0.0.1.0+-} detachContextFromThread :: MonadIO m => ThreadId -> m (Maybe Context) detachContextFromThread = detachFromThread threadContextMap --- | Alter the context on the current thread using the provided function------ @since 0.0.1.0++{- | Alter the context on the current thread using the provided function.++If there is not a context associated with the current thread, the function will+be applied to an empty context and the result will be stored++ @since 0.0.1.0+-} adjustContext :: MonadIO m => (Context -> Context) -> m ()-adjustContext f = liftIO $ do- ctxt <- getContext- void $ attachContext $ f ctxt+adjustContext f = update threadContextMap $ \mctx ->+ (f $ fromMaybe empty mctx, ()) --- | Alter the context------ @since 0.0.1.0-adjustContextOnThread :: MonadIO m => ThreadId -> (Context -> Context) -> m ()-adjustContextOnThread = adjustOnThread threadContextMap +{- | Alter the context++If there is not a context associated with the provided thread, the function will+be applied to an empty context and the result will be stored++ @since 0.0.1.0+-}+adjustContextOnThread :: MonadIO m => ThreadId -> (Context -> Context) -> m ()+adjustContextOnThread tid = updateOnThread threadContextMap tid $ \mctx ->+ (f $ fromMaybe empty mctx, ())
src/OpenTelemetry/Context/Types.hs view
@@ -3,20 +3,26 @@ import Data.Text (Text) import qualified Data.Vault.Strict as V --- | A `Context` is a propagation mechanism which carries execution-scoped values--- across API boundaries and between logically associated execution units.--- Cross-cutting concerns access their data in-process using the same shared--- `Context` object++{- | A `Context` is a propagation mechanism which carries execution-scoped values+ across API boundaries and between logically associated execution units.+ Cross-cutting concerns access their data in-process using the same shared+ `Context` object+-} newtype Context = Context V.Vault + instance Semigroup Context where (<>) (Context l) (Context r) = Context (V.union l r) + instance Monoid Context where mempty = Context V.empty --- | Keys are used to allow cross-cutting concerns to control access to their local state.--- They are unique such that other libraries which may use the same context--- cannot accidentally use the same key. It is recommended that concerns mediate--- data access via an API, rather than provide direct public access to their keys.-data Key a = Key { keyName :: Text, key :: V.Key a }++{- | Keys are used to allow cross-cutting concerns to control access to their local state.+ They are unique such that other libraries which may use the same context+ cannot accidentally use the same key. It is recommended that concerns mediate+ data access via an API, rather than provide direct public access to their keys.+-}+data Key a = Key {keyName :: Text, key :: V.Key a}
src/OpenTelemetry/Exporter.hs view
@@ -1,21 +1,24 @@ -------------------------------------------------------------------------------- |--- Module : OpenTelemetry.Exporter--- Copyright : (c) Ian Duncan, 2021--- License : BSD-3--- Description : Encode and transmit telemetry to external systems--- Maintainer : Ian Duncan--- Stability : experimental--- Portability : non-portable (GHC extensions)------ Span Exporter defines the interface that protocol-specific exporters must implement so that they can be plugged into OpenTelemetry SDK and support sending of telemetry data.------ The goal of the interface is to minimize burden of implementation for protocol-dependent telemetry exporters. The protocol exporter is expected to be primarily a simple telemetry data encoder and transmitter.---+ ----------------------------------------------------------------------------- -module OpenTelemetry.Exporter - ( Exporter (..)- , ExportResult (..)- ) where+{- |+ Module : OpenTelemetry.Exporter+ Copyright : (c) Ian Duncan, 2021+ License : BSD-3+ Description : Encode and transmit telemetry to external systems+ Maintainer : Ian Duncan+ Stability : experimental+ Portability : non-portable (GHC extensions)++ Span Exporter defines the interface that protocol-specific exporters must implement so that they can be plugged into OpenTelemetry SDK and support sending of telemetry data.++ The goal of the interface is to minimize burden of implementation for protocol-dependent telemetry exporters. The protocol exporter is expected to be primarily a simple telemetry data encoder and transmitter.+-}+module OpenTelemetry.Exporter (+ Exporter (..),+ ExportResult (..),+) where+ import OpenTelemetry.Internal.Trace.Types+
+ src/OpenTelemetry/Internal/Trace/Id.hs view
@@ -0,0 +1,272 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}++module OpenTelemetry.Internal.Trace.Id (+ TraceId (..),+ newTraceId,+ isEmptyTraceId,+ traceIdBytes,+ bytesToTraceId,+ baseEncodedToTraceId,+ traceIdBaseEncodedBuilder,+ traceIdBaseEncodedByteString,+ traceIdBaseEncodedText,+ SpanId (..),+ newSpanId,+ isEmptySpanId,+ spanIdBytes,+ bytesToSpanId,+ Base (..),+ baseEncodedToSpanId,+ spanIdBaseEncodedBuilder,+ spanIdBaseEncodedByteString,+ spanIdBaseEncodedText,+) where++import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.ByteArray.Encoding (+ Base (Base16),+ convertFromBase,+ convertToBase,+ )+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.ByteString.Builder (Builder)+import qualified Data.ByteString.Builder as B+import Data.ByteString.Short.Internal (+ ShortByteString (SBS),+ fromShort,+ toShort,+ )+import Data.Hashable (Hashable)+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8)+import GHC.Exts (+ IsString (fromString),+ eqWord#,+ indexWord64Array#,+ int2Word#,+ 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),+ )+import Prelude hiding (length)+++-- TODO faster encoding decoding via something like+-- https://github.com/lemire/Code-used-on-Daniel-Lemire-s-blog/blob/03fc2e82fdef2c6fd25721203e1654428fee123d/2019/04/17/hexparse.cpp#L390++-- | A valid trace identifier is a 16-byte array with at least one non-zero byte.+newtype TraceId = TraceId ShortByteString+ deriving stock (Ord, Eq, Generic)+ deriving newtype (Hashable)+++-- | A valid span identifier is an 8-byte array with at least one non-zero byte.+newtype SpanId = SpanId ShortByteString+ deriving stock (Ord, Eq)+ deriving newtype (Hashable)+++instance Show TraceId where+ showsPrec d i = showParen (d > 10) $ showString "TraceId " . showsPrec 11 (traceIdBaseEncodedText Base16 i)+++instance IsString TraceId where+ fromString str = case baseEncodedToTraceId Base16 (fromString str) of+ Left err -> error err+ Right ok -> ok+++instance Show SpanId where+ showsPrec d i = showParen (d > 10) $ showString "SpanId " . showsPrec 11 (spanIdBaseEncodedText Base16 i)+++instance IsString SpanId where+ fromString str = case baseEncodedToSpanId Base16 (fromString str) of+ Left err -> error err+ Right ok -> ok+++{- | Generate a 'TraceId' using the provided 'IdGenerator'++ This function is generally called by the @hs-opentelemetry-sdk@,+ but may be useful in some testing situations.++ @since 0.1.0.0+-}+newTraceId :: MonadIO m => IdGenerator -> m TraceId+newTraceId gen = liftIO (TraceId . toShort <$> generateTraceIdBytes gen)+++{- | Check whether all bytes in the 'TraceId' are zero.++ @since 0.1.0.0+-}+isEmptyTraceId :: TraceId -> Bool+#if MIN_VERSION_base(4,17,0)+isEmptyTraceId (TraceId (SBS arr)) =+ isTrue#+ (eqWord#+ (or#+ (word64ToWord# (indexWord64Array# arr 0#))+ (word64ToWord# (indexWord64Array# arr 1#)))+ (int2Word# 0#))+#else+isEmptyTraceId (TraceId (SBS arr)) =+ isTrue#+ (eqWord#+ (or#+ (indexWord64Array# arr 0#)+ (indexWord64Array# arr 1#))+ (int2Word# 0#))+#endif+++{- | Access the byte-level representation of the provided 'TraceId'++ @since 0.1.0.0+-}+traceIdBytes :: TraceId -> ByteString+traceIdBytes (TraceId bytes) = fromShort bytes+++{- | Convert a 'ByteString' to a 'TraceId'. Will fail if the 'ByteString'+ is not exactly 16 bytes long.++ @since 0.1.0.0+-}+bytesToTraceId :: ByteString -> Either String TraceId+bytesToTraceId bs =+ if BS.length bs == 16+ then Right $ TraceId $ toShort bs+ else Left "bytesToTraceId: TraceId must be 8 bytes long"+++{- | Convert a 'ByteString' of a specified base-encoding into a 'TraceId'.+ Will fail if the decoded value is not exactly 16 bytes long.++ @since 0.1.0.0+-}+baseEncodedToTraceId :: Base -> ByteString -> Either String TraceId+baseEncodedToTraceId b bs = do+ r <- convertFromBase b bs+ bytesToTraceId r+++{- | Output a 'TraceId' into a base-encoded bytestring 'Builder'.++ @since 0.1.0.0+-}+traceIdBaseEncodedBuilder :: Base -> TraceId -> Builder+traceIdBaseEncodedBuilder b = B.byteString . convertToBase b . traceIdBytes+++{- | Output a 'TraceId' into a base-encoded 'ByteString'.++ @since 0.1.0.0+-}+traceIdBaseEncodedByteString :: Base -> TraceId -> ByteString+traceIdBaseEncodedByteString b = convertToBase b . traceIdBytes+++{- | Output a 'TraceId' into a base-encoded 'Text'.++ @since 0.1.0.0+-}+traceIdBaseEncodedText :: Base -> TraceId -> Text+traceIdBaseEncodedText b = decodeUtf8 . traceIdBaseEncodedByteString b+++{- | Generate a 'SpanId' using the provided 'IdGenerator'++ This function is generally called by the @hs-opentelemetry-sdk@,+ but may be useful in some testing situations.++ @since 0.1.0.0+-}+newSpanId :: MonadIO m => IdGenerator -> m SpanId+newSpanId gen = liftIO (SpanId . toShort <$> generateSpanIdBytes gen)+++{- | Check whether all bytes in the 'SpanId' are zero.++ @since 0.1.0.0+-}+isEmptySpanId :: SpanId -> Bool+#if MIN_VERSION_base(4,17,0)+isEmptySpanId (SpanId (SBS arr)) = isTrue#+ (eqWord#+ (word64ToWord# (indexWord64Array# arr 0#))+ (int2Word# 0#))+#else+isEmptySpanId (SpanId (SBS arr)) = isTrue#+ (eqWord#+ (indexWord64Array# arr 0#)+ (int2Word# 0#))+#endif+++{- | Access the byte-level representation of the provided 'SpanId'++ @since 0.1.0.0+-}+spanIdBytes :: SpanId -> ByteString+spanIdBytes (SpanId bytes) = fromShort bytes+++{- | Convert a 'ByteString' of a specified base-encoding into a 'SpanId'.+ Will fail if the decoded value is not exactly 8 bytes long.++ @since 0.1.0.0+-}+bytesToSpanId :: ByteString -> Either String SpanId+bytesToSpanId bs =+ if BS.length bs == 8+ then Right $ SpanId $ toShort bs+ else Left "bytesToSpanId: SpanId must be 8 bytes long"+++{- | Convert a 'ByteString' of a specified base-encoding into a 'SpanId'.+ Will fail if the decoded value is not exactly 8 bytes long.++ @since 0.1.0.0+-}+baseEncodedToSpanId :: Base -> ByteString -> Either String SpanId+baseEncodedToSpanId b bs = do+ r <- convertFromBase b bs+ bytesToSpanId r+++{- | Output a 'SpanId' into a base-encoded bytestring 'Builder'.++ @since 0.1.0.0+-}+spanIdBaseEncodedBuilder :: Base -> SpanId -> Builder+spanIdBaseEncodedBuilder b = B.byteString . convertToBase b . spanIdBytes+++{- | Output a 'SpanId' into a base-encoded 'ByteString'.++ @since 0.1.0.0+-}+spanIdBaseEncodedByteString :: Base -> SpanId -> ByteString+spanIdBaseEncodedByteString b = convertToBase b . spanIdBytes+++{- | Output a 'SpanId' into a base-encoded 'Text'.++ @since 0.1.0.0+-}+spanIdBaseEncodedText :: Base -> SpanId -> Text+spanIdBaseEncodedText b = decodeUtf8 . spanIdBaseEncodedByteString b
src/OpenTelemetry/Internal/Trace/Types.hs view
@@ -1,18 +1,20 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE StrictData #-}+ module OpenTelemetry.Internal.Trace.Types where import Control.Concurrent.Async (Async) import Control.Exception (SomeException) import Control.Monad.IO.Class import Data.Bits-import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap)+import Data.Hashable (Hashable) import Data.IORef (IORef, readIORef)-import Data.String ( IsString(..) )+import Data.String (IsString (..)) import Data.Text (Text) import Data.Vector (Vector) import Data.Word (Word8)@@ -22,10 +24,10 @@ import OpenTelemetry.Common import OpenTelemetry.Context.Types import OpenTelemetry.Logging.Core (Log)-import OpenTelemetry.Trace.Id+import OpenTelemetry.Propagator (Propagator) import OpenTelemetry.Resource+import OpenTelemetry.Trace.Id import OpenTelemetry.Trace.Id.Generator-import OpenTelemetry.Propagator (Propagator) import OpenTelemetry.Trace.TraceState import OpenTelemetry.Util @@ -34,52 +36,61 @@ = Success | Failure (Maybe SomeException) --- | An identifier for the library that provides the instrumentation for a given Instrumented Library.--- Instrumented Library and Instrumentation Library may be the same library if it has built-in OpenTelemetry instrumentation.------ The inspiration of the OpenTelemetry project is to make every library and application observable out of the box by having them call OpenTelemetry API directly.--- However, many libraries will not have such integration, and as such there is a need for a separate library which would inject such calls, using mechanisms such as wrapping interfaces,--- subscribing to library-specific callbacks, or translating existing telemetry into the OpenTelemetry model.------ A library that enables OpenTelemetry observability for another library is called an Instrumentation Library.------ An instrumentation library should be named to follow any naming conventions of the instrumented library (e.g. 'middleware' for a web framework).------ If there is no established name, the recommendation is to prefix packages with "hs-opentelemetry-instrumentation", followed by the instrumented library name itself.------ In general, you can initialize the instrumentation library like so:------ @------ import qualified Data.Text as T--- import Data.Version (showVersion)--- import Paths_your_package_name------ instrumentationLibrary :: InstrumentationLibrary--- instrumentationLibrary = InstrumentationLibrary--- { libraryName = "your_package_name"--- , libraryVersion = T.pack $ showVersion version--- }------ @++{- | An identifier for the library that provides the instrumentation for a given Instrumented Library.+ Instrumented Library and Instrumentation Library may be the same library if it has built-in OpenTelemetry instrumentation.++ The inspiration of the OpenTelemetry project is to make every library and application observable out of the box by having them call OpenTelemetry API directly.+ However, many libraries will not have such integration, and as such there is a need for a separate library which would inject such calls, using mechanisms such as wrapping interfaces,+ subscribing to library-specific callbacks, or translating existing telemetry into the OpenTelemetry model.++ A library that enables OpenTelemetry observability for another library is called an Instrumentation Library.++ An instrumentation library should be named to follow any naming conventions of the instrumented library (e.g. 'middleware' for a web framework).++ If there is no established name, the recommendation is to prefix packages with "hs-opentelemetry-instrumentation", followed by the instrumented library name itself.++ In general, you can initialize the instrumentation library like so:++ @++ import qualified Data.Text as T+ import Data.Version (showVersion)+ import Paths_your_package_name++ instrumentationLibrary :: InstrumentationLibrary+ instrumentationLibrary = InstrumentationLibrary+ { libraryName = "your_package_name"+ , libraryVersion = T.pack $ showVersion version+ }++ @+-} data InstrumentationLibrary = InstrumentationLibrary { libraryName :: {-# UNPACK #-} !Text -- ^ The name of the instrumentation library , libraryVersion :: {-# UNPACK #-} !Text -- ^ The version of the instrumented library- } deriving (Ord, Eq, Generic, Show)+ }+ deriving (Ord, Eq, Generic, Show) + instance Hashable InstrumentationLibrary++ instance IsString InstrumentationLibrary where fromString str = InstrumentationLibrary (fromString str) "" + data Exporter a = Exporter { exporterExport :: HashMap InstrumentationLibrary (Vector a) -> IO ExportResult , exporterShutdown :: IO () } + data ShutdownResult = ShutdownSuccess | ShutdownFailure | ShutdownTimeout + data Processor = Processor { processorOnStart :: IORef ImmutableSpan -> Context -> IO () -- ^ Called when a span is started. This method is called synchronously on the thread that started the span, therefore it should not block or throw exceptions.@@ -107,6 +118,7 @@ -- ForceFlush SHOULD complete or abort within some timeout. ForceFlush can be implemented as a blocking API or an asynchronous API which notifies the caller via a callback or an event. OpenTelemetry client authors can decide if they want to make the flush timeout configurable. } + {- | 'Tracer's can be created from a 'TracerProvider'. -}@@ -121,10 +133,12 @@ , tracerProviderLogger :: Log Text -> IO () } --- | The 'Tracer' is responsible for creating 'Span's.------ Each 'Tracer' should be associated with the library or application that--- it instruments.++{- | The 'Tracer' is responsible for creating 'Span's.++ Each 'Tracer' should be associated with the library or application that+ it instruments.+-} data Tracer = Tracer { tracerName :: {-# UNPACK #-} !InstrumentationLibrary -- ^ Get the name of the 'Tracer'@@ -136,9 +150,11 @@ -- @since 0.0.10 } + instance Show Tracer where- show Tracer {tracerName = name} = "Tracer { tracerName = " <> show name <> "}"+ showsPrec d Tracer {tracerName = name} = showParen (d > 10) $ showString "Tracer {tracerName = " . shows name . showString "}" + {- | This is a link that is being added to a span which is going to be created. @@ -152,7 +168,7 @@ of a new Trace rather than trusting the incoming Trace context. The new linked Trace may also represent a long running asynchronous data processing operation that was initiated by one of many fast incoming requests. -When using the scatter/gather (also called fork/join) pattern, the root operation starts multiple downstream+When using the scatter\/gather (also called fork\/join) pattern, the root operation starts multiple downstream processing operations and all of them are aggregated back in a single Span. This last Span is linked to many operations it aggregates. All of them are the Spans from the same Trace. And similar to the Parent field of a Span.@@ -168,6 +184,7 @@ } deriving (Show) + {- | This is an immutable link for an existing span. @@ -197,6 +214,7 @@ } deriving (Show) + -- | Non-name fields that may be set on initial creation of a 'Span'. data SpanArguments = SpanArguments { kind :: SpanKind@@ -212,18 +230,20 @@ -- ^ An explicit start time, if the span has already begun. } + -- | The outcome of a call to 'OpenTelemetry.Trace.forceFlush' data FlushResult- = FlushTimeout- -- ^ One or more spans did not export from all associated exporters- -- within the alotted timeframe.- | FlushSuccess- -- ^ Flushing spans to all associated exporters succeeded.- | FlushError- -- ^ One or more exporters failed to successfully export one or more- -- unexported spans.+ = -- | One or more spans did not export from all associated exporters+ -- within the alotted timeframe.+ FlushTimeout+ | -- | Flushing spans to all associated exporters succeeded.+ FlushSuccess+ | -- | One or more exporters failed to successfully export one or more+ -- unexported spans.+ FlushError deriving (Show) + {- | @SpanKind@ describes the relationship between the @Span@, its parents, and its children in a Trace. @SpanKind@ describes two independent properties that benefit tracing systems during analysis. @@ -248,41 +268,43 @@ +-------------+--------------+---------------+------------------+------------------+ | `Internal` | | | | | +-------------+--------------+---------------+------------------+------------------+- -} data SpanKind- = Server- -- ^ Indicates that the span covers server-side handling of a synchronous RPC or other remote request.- -- This span is the child of a remote @Client@ span that was expected to wait for a response.- | Client- -- ^ Indicates that the span describes a synchronous request to some remote service.- -- This span is the parent of a remote @Server@ span and waits for its response.- | Producer- -- ^ Indicates that the span describes the parent of an asynchronous request.- -- This parent span is expected to end before the corresponding child @Producer@ span,- -- possibly even before the child span starts. In messaging scenarios with batching,- -- tracing individual messages requires a new @Producer@ span per message to be created.- | Consumer- -- ^ Indicates that the span describes the child of an asynchronous @Producer@ request.- | Internal- -- ^ Default value. Indicates that the span represents an internal operation within an application,- -- as opposed to an operations with remote parents or children.+ = -- | Indicates that the span covers server-side handling of a synchronous RPC or other remote request.+ -- This span is the child of a remote @Client@ span that was expected to wait for a response.+ Server+ | -- | Indicates that the span describes a synchronous request to some remote service.+ -- This span is the parent of a remote @Server@ span and waits for its response.+ Client+ | -- | Indicates that the span describes the parent of an asynchronous request.+ -- This parent span is expected to end before the corresponding child @Producer@ span,+ -- possibly even before the child span starts. In messaging scenarios with batching,+ -- tracing individual messages requires a new @Producer@ span per message to be created.+ Producer+ | -- | Indicates that the span describes the child of an asynchronous @Producer@ request.+ Consumer+ | -- | Default value. Indicates that the span represents an internal operation within an application,+ -- as opposed to an operations with remote parents or children.+ Internal deriving (Show) --- | The status of a @Span@. This may be used to indicate the successful completion of a span.------ The default is @Unset@------ These values form a total order: Ok > Error > Unset. This means that setting Status with StatusCode=Ok will override any prior or future attempts to set span Status with StatusCode=Error or StatusCode=Unset.++{- | The status of a @Span@. This may be used to indicate the successful completion of a span.++ The default is @Unset@++ These values form a total order: Ok > Error > Unset. This means that setting Status with StatusCode=Ok will override any prior or future attempts to set span Status with StatusCode=Error or StatusCode=Unset.+-} data SpanStatus- = Unset- -- ^ The default status.- | Error Text- -- ^ The operation contains an error. The text field may be empty, or else provide a description of the error.- | Ok- -- ^ The operation has been validated by an Application developer or Operator to have completed successfully.+ = -- | The default status.+ Unset+ | -- | The operation contains an error. The text field may be empty, or else provide a description of the error.+ Error Text+ | -- | The operation has been validated by an Application developer or Operator to have completed successfully.+ Ok deriving (Show, Eq) + instance Ord SpanStatus where compare Unset Unset = EQ compare Unset (Error _) = LT@@ -294,9 +316,11 @@ compare Ok (Error _) = GT compare Ok Ok = EQ --- | The frozen representation of a 'Span' that originates from the currently running process.------ Only 'Processor's and 'Exporter's should use rely on this interface.++{- | The frozen representation of a 'Span' that originates from the currently running process.++ Only 'Processor's and 'Exporter's should use rely on this interface.+-} data ImmutableSpan = ImmutableSpan { spanName :: Text -- ^ A name identifying the role of the span (like function or method name).@@ -319,65 +343,80 @@ , spanStatus :: SpanStatus , spanTracer :: Tracer -- ^ Creator of the span- } deriving (Show)+ }+ deriving (Show) --- | A 'Span' is the fundamental type you'll work with to trace your systems.------ A span is a single piece of instrumentation from a single location in your code or infrastructure. A span represents a single "unit of work" done by a service. Each span contains several key pieces of data:------ - A service name identifying the service the span is from--- - A name identifying the role of the span (like function or method name)--- - A timestamp that corresponds to the start of the span--- - A duration that describes how long that unit of work took to complete--- - An ID that uniquely identifies the span--- - A trace ID identifying which trace the span belongs to--- - A parent ID representing the parent span that called this span. (There is no parent ID for the root span of a given trace, which denotes that it's the start of the trace.)--- - Any additional metadata that might be helpful.--- - Zero or more links to related spans. Links can be useful for connecting causal relationships between things like web requests that enqueue asynchronous tasks to be processed.--- - Events, which denote a point in time occurrence. These can be useful for recording data about a span such as when an exception was thrown, or to emit structured logs into the span tree.------ A trace is made up of multiple spans. Tracing vendors such as Zipkin, Jaeger, Honeycomb, Datadog, Lightstep, etc. use the metadata from each span to reconstruct the relationships between them and generate a trace diagram.++{- | A 'Span' is the fundamental type you'll work with to trace your systems.++ A span is a single piece of instrumentation from a single location in your code or infrastructure. A span represents a single "unit of work" done by a service. Each span contains several key pieces of data:++ - A service name identifying the service the span is from+ - A name identifying the role of the span (like function or method name)+ - A timestamp that corresponds to the start of the span+ - A duration that describes how long that unit of work took to complete+ - An ID that uniquely identifies the span+ - A trace ID identifying which trace the span belongs to+ - A parent ID representing the parent span that called this span. (There is no parent ID for the root span of a given trace, which denotes that it's the start of the trace.)+ - Any additional metadata that might be helpful.+ - Zero or more links to related spans. Links can be useful for connecting causal relationships between things like web requests that enqueue asynchronous tasks to be processed.+ - Events, which denote a point in time occurrence. These can be useful for recording data about a span such as when an exception was thrown, or to emit structured logs into the span tree.++ A trace is made up of multiple spans. Tracing vendors such as Zipkin, Jaeger, Honeycomb, Datadog, Lightstep, etc. use the metadata from each span to reconstruct the relationships between them and generate a trace diagram.+-} data Span = Span (IORef ImmutableSpan) | FrozenSpan SpanContext | Dropped SpanContext + instance Show Span where- show (Span _ioref) = "(mutable span)"- show (FrozenSpan ctx) = show ctx- show (Dropped ctx) = show ctx+ showsPrec d (Span _ioref) = showParen (d > 10) $ showString "Span _ioref"+ showsPrec d (FrozenSpan ctx) = showParen (d > 10) $ showString "FrozenSpan " . showsPrec 11 ctx+ showsPrec d (Dropped ctx) = showParen (d > 10) $ showString "Dropped " . showsPrec 11 ctx --- | 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.++{- | 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.+-} defaultTraceFlags :: TraceFlags defaultTraceFlags = TraceFlags 0 + -- | Will the trace associated with this @TraceFlags@ value be sampled? isSampled :: TraceFlags -> Bool isSampled (TraceFlags flags) = flags `testBit` 0 + -- | Set the @sampled@ flag on the @TraceFlags@ setSampled :: TraceFlags -> TraceFlags setSampled (TraceFlags flags) = TraceFlags (flags `setBit` 0) --- | Unset the @sampled@ flag on the @TraceFlags@. This means that the--- application may choose whether or not to emit this Trace.++{- | Unset the @sampled@ flag on the @TraceFlags@. This means that the+ application may choose whether or not to emit this Trace.+-} unsetSampled :: TraceFlags -> TraceFlags unsetSampled (TraceFlags flags) = TraceFlags (flags `clearBit` 0) + -- | Get the current bitmask for the @TraceFlags@, useful for serialization purposes. traceFlagsValue :: TraceFlags -> Word8 traceFlagsValue (TraceFlags flags) = flags --- | Create a @TraceFlags@, from an arbitrary @Word8@. Note that for backwards-compatibility--- reasons, no checking is performed to determine whether the @TraceFlags@ bitmask provided--- is valid.++{- | Create a @TraceFlags@, from an arbitrary @Word8@. Note that for backwards-compatibility+ reasons, no checking is performed to determine whether the @TraceFlags@ bitmask provided+ is valid.+-} traceFlagsFromWord8 :: Word8 -> TraceFlags traceFlagsFromWord8 = TraceFlags --- | A `SpanContext` represents the portion of a `Span` which must be serialized and--- propagated along side of a distributed context. `SpanContext`s are immutable. +{- | A `SpanContext` represents the portion of a `Span` which must be serialized and+ propagated along side of a distributed context. `SpanContext`s are immutable.+-}+ -- The OpenTelemetry `SpanContext` representation conforms to the [W3C TraceContext -- specification](https://www.w3.org/TR/trace-context/). It contains two -- identifiers - a `TraceId` and a `SpanId` - along with a set of common@@ -409,18 +448,22 @@ , traceState :: TraceState -- TODO have to move TraceState impl from W3CTraceContext to here -- list of up to 32, remove rightmost if exceeded -- see w3c trace-context spec- } deriving (Show, Eq)+ }+ deriving (Show, Eq) + newtype NonRecordingSpan = NonRecordingSpan SpanContext --- | A “log” that happens as part of a span. An operation that is too fast for its own span, but too unique to roll up into its parent span.------ Events contain a name, a timestamp, and an optional set of Attributes, along with a timestamp. Events represent an event that occurred at a specific time within a span’s workload.------ When creating an event, this is the version that you will use. Attributes added that exceed the configured attribute limits will be dropped,--- which is accounted for in the 'Event' structure.------ @since 0.0.1.0++{- | A “log” that happens as part of a span. An operation that is too fast for its own span, but too unique to roll up into its parent span.++ Events contain a name, a timestamp, and an optional set of Attributes, along with a timestamp. Events represent an event that occurred at a specific time within a span’s workload.++ When creating an event, this is the version that you will use. Attributes added that exceed the configured attribute limits will be dropped,+ which is accounted for in the 'Event' structure.++ @since 0.0.1.0+-} data NewEvent = NewEvent { newEventName :: Text -- ^ The name of an event. Ideally this should be a relatively unique, but low cardinality value.@@ -432,9 +475,11 @@ -- If not specified, 'OpenTelemetry.Trace.getTimestamp' will be used to get a timestamp. } --- | A “log” that happens as part of a span. An operation that is too fast for its own span, but too unique to roll up into its parent span.------ Events contain a name, a timestamp, and an optional set of Attributes, along with a timestamp. Events represent an event that occurred at a specific time within a span’s workload.++{- | A “log” that happens as part of a span. An operation that is too fast for its own span, but too unique to roll up into its parent span.++ Events contain a name, a timestamp, and an optional set of Attributes, along with a timestamp. Events represent an event that occurred at a specific time within a span’s workload.+-} data Event = Event { eventName :: Text -- ^ The name of an event. Ideally this should be a relatively unique, but low cardinality value.@@ -445,6 +490,7 @@ } deriving (Show) + -- | Utility class to format arbitrary values to events. class ToEvent a where -- | Convert a value to an 'Event'@@ -452,25 +498,30 @@ -- @since 0.0.1.0 toEvent :: a -> Event --- | The outcome of a call to 'Sampler' indicating--- whether the 'Tracer' should sample a 'Span'.++{- | The outcome of a call to 'Sampler' indicating+ whether the 'Tracer' should sample a 'Span'.+-} data SamplingResult- = Drop- -- ^ isRecording == false. Span will not be recorded and all events and attributes will be dropped.- | RecordOnly- -- ^ isRecording == true, but Sampled flag MUST NOT be set.- | RecordAndSample- -- ^ isRecording == true, AND Sampled flag MUST be set.+ = -- | isRecording == false. Span will not be recorded and all events and attributes will be dropped.+ Drop+ | -- | isRecording == true, but Sampled flag MUST NOT be set.+ RecordOnly+ | -- | isRecording == true, AND Sampled flag MUST be set.+ RecordAndSample deriving (Show, Eq) --- | Interface that allows users to create custom samplers which will return a sampling SamplingResult based on information that--- is typically available just before the Span was created.++{- | Interface that allows users to create custom samplers which will return a sampling SamplingResult based on information that+ is typically available just before the Span was created.+-} 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) } + data SpanLimits = SpanLimits { spanAttributeValueLengthLimit :: Maybe Int , spanAttributeCountLimit :: Maybe Int@@ -478,22 +529,30 @@ , eventAttributeCountLimit :: Maybe Int , linkCountLimit :: Maybe Int , linkAttributeCountLimit :: Maybe Int- } deriving (Show, Eq)+ }+ deriving (Show, Eq) + defaultSpanLimits :: SpanLimits-defaultSpanLimits = SpanLimits- Nothing- Nothing- Nothing- Nothing- Nothing- Nothing+defaultSpanLimits =+ SpanLimits+ Nothing+ Nothing+ Nothing+ Nothing+ Nothing+ Nothing + 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 --- | When sending tracing information across process boundaries,--- the @SpanContext@ is used to serialize the relevant information.++{- | When sending tracing information across process boundaries,+ the @SpanContext@ is used to serialize the relevant information.+-} getSpanContext :: MonadIO m => Span -> m SpanContext getSpanContext (Span s) = liftIO (spanContext <$> readIORef s) getSpanContext (FrozenSpan c) = pure c
src/OpenTelemetry/Logging/Core.hs view
@@ -1,20 +1,23 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+ module OpenTelemetry.Logging.Core where-import OpenTelemetry.Common-import OpenTelemetry.Trace.Id (TraceId, SpanId)-import OpenTelemetry.Attributes ( Attribute )++import Data.Int (Int32, Int64) import Data.Text (Text)-import Data.Int (Int64, Int32)+import OpenTelemetry.Attributes (Attribute)+import OpenTelemetry.Common import OpenTelemetry.Resource (MaterializedResources)+import OpenTelemetry.Trace.Id (SpanId, TraceId) + data Log body = Log { timestamp :: Maybe Timestamp -- ^ Time when the event occurred measured by the origin clock. This field is optional, it may be missing if the timestamp is unknown. , tracingDetails :: Maybe (TraceId, SpanId, TraceFlags) -- ^ Tuple contains three fields:- -- + -- -- - Request trace id as defined in W3C Trace Context. Can be set for logs that are part of request processing and have an assigned trace id. -- - Span id. Can be set for logs that are part of a particular processing span. -- - Trace flag as defined in W3C Trace Context specification. At the time of writing the specification defines one flag - the SAMPLED flag.@@ -38,28 +41,30 @@ -- +-----------------------+-------------+------------------------------------------------------------------------------------------+ -- | 21-24 | FATAL | A fatal error such as application or system crash. | -- +-----------------------+-------------+------------------------------------------------------------------------------------------+- -- , name :: Maybe Text -- ^ Short low cardinality event type that does not contain varying parts. Name describes what happened (e.g. "ProcessStarted"). Recommended to be no longer than 50 characters. Typically used for filtering and grouping purposes in backends. , body :: body- {-- Type any- Value of type any can be one of the following:+ -- ^ A value containing the body of the log record. Can be for example a human-readable string message (including multi-line) describing the event in a free form or it can be a structured data composed of arrays and maps of other values. First-party Applications SHOULD use a string message. However, a structured body may be necessary to preserve the semantics of some existing log formats. Can vary for each occurrence of the event coming from the same source. This field is optional.+ , {-+ Type any+ Value of type any can be one of the following: - A scalar value: number, string or boolean,+ A scalar value: number, string or boolean, - A byte array,+ A byte array, - An array (a list) of any values,+ An array (a list) of any values, - A map<string, any>.- -}- -- ^ A value containing the body of the log record. Can be for example a human-readable string message (including multi-line) describing the event in a free form or it can be a structured data composed of arrays and maps of other values. First-party Applications SHOULD use a string message. However, a structured body may be necessary to preserve the semantics of some existing log formats. Can vary for each occurrence of the event coming from the same source. This field is optional.- , resource :: Maybe MaterializedResources+ A map<string, any>.+ -}++ resource :: Maybe MaterializedResources -- ^ Describes the source of the log, aka resource. Multiple occurrences of events coming from the same event source can happen across time and they all have the same value of Resource. Can contain for example information about the application that emits the record or about the infrastructure where the application runs. Data formats that represent this data model may be designed in a manner that allows the Resource field to be recorded only once per batch of log records that come from the same source. SHOULD follow OpenTelemetry semantic conventions for Resources. This field is optional. , attributes :: Maybe [(Text, Attribute)] -- ^ Additional information about the specific event occurrence. Unlike the Resource field, which is fixed for a particular source, Attributes can vary for each occurrence of the event coming from the same source. Can contain information about the request context (other than TraceId/SpanId). SHOULD follow OpenTelemetry semantic conventions for Log Attributes or semantic conventions for Span Attributes. This field is optional.- } deriving stock (Functor)+ }+ deriving stock (Functor)+ data SeverityNumber = Trace
src/OpenTelemetry/Processor.hs view
@@ -1,26 +1,30 @@ -------------------------------------------------------------------------------- |--- Module : OpenTelemetry.Processor--- Copyright : (c) Ian Duncan, 2021--- License : BSD-3--- Description : Hooks for performing actions on the start and end of recording spans--- Maintainer : Ian Duncan--- Stability : experimental--- Portability : non-portable (GHC extensions)------ Span processor is an interface which allows hooks for span start and end method invocations. The span processors are invoked only when IsRecording is true.------ Built-in span processors are responsible for batching and conversion of spans to exportable representation and passing batches to exporters.------ Span processors can be registered directly on SDK TracerProvider and they are invoked in the same order as they were registered.------ Each processor registered on TracerProvider is a start of pipeline that consist of span processor and optional exporter. SDK MUST allow to end each pipeline with individual exporter.------ SDK MUST allow users to implement and configure custom processors and decorate built-in processors for advanced scenarios such as tagging or filtering.---+ ------------------------------------------------------------------------------module OpenTelemetry.Processor - ( Processor(..)- , ShutdownResult(..)- ) where++{- |+ Module : OpenTelemetry.Processor+ Copyright : (c) Ian Duncan, 2021+ License : BSD-3+ Description : Hooks for performing actions on the start and end of recording spans+ Maintainer : Ian Duncan+ Stability : experimental+ Portability : non-portable (GHC extensions)++ Span processor is an interface which allows hooks for span start and end method invocations. The span processors are invoked only when IsRecording is true.++ Built-in span processors are responsible for batching and conversion of spans to exportable representation and passing batches to exporters.++ Span processors can be registered directly on SDK TracerProvider and they are invoked in the same order as they were registered.++ Each processor registered on TracerProvider is a start of pipeline that consist of span processor and optional exporter. SDK MUST allow to end each pipeline with individual exporter.++ SDK MUST allow users to implement and configure custom processors and decorate built-in processors for advanced scenarios such as tagging or filtering.+-}+module OpenTelemetry.Processor (+ Processor (..),+ ShutdownResult (..),+) where+ import OpenTelemetry.Internal.Trace.Types+
src/OpenTelemetry/Propagator.hs view
@@ -1,37 +1,41 @@ {-# LANGUAGE RankNTypes #-}+ -------------------------------------------------------------------------------- |--- Module : OpenTelemetry.Trace.Propagator--- Copyright : (c) Ian Duncan, 2021--- License : BSD-3--- Description : Sending and receiving state between system boundaries--- Maintainer : Ian Duncan--- Stability : experimental--- Portability : non-portable (GHC extensions)------ Cross-cutting concerns send their state to the next process using Propagators, which are defined as objects used to --- read and write context data to and from messages exchanged by the applications. --- Each concern creates a set of Propagators for every supported Propagator type.------ Propagators leverage the Context to inject and extract data for each cross-cutting concern, such as traces and Baggage.------ Propagation is usually implemented via a cooperation of library-specific request interceptors and Propagators, --- where the interceptors detect incoming and outgoing requests and use the Propagator's extract and inject operations --- respectively.------ The Propagators API is expected to be leveraged by users writing instrumentation libraries. However,--- users using the OpenTelemetry SDK may need to select appropriate propagators to work with existing 3rd party systems--- such as AWS.---+ -----------------------------------------------------------------------------++{- |+ Module : OpenTelemetry.Trace.Propagator+ Copyright : (c) Ian Duncan, 2021+ License : BSD-3+ Description : Sending and receiving state between system boundaries+ Maintainer : Ian Duncan+ Stability : experimental+ Portability : non-portable (GHC extensions)++ Cross-cutting concerns send their state to the next process using Propagators, which are defined as objects used to+ read and write context data to and from messages exchanged by the applications.+ Each concern creates a set of Propagators for every supported Propagator type.++ Propagators leverage the Context to inject and extract data for each cross-cutting concern, such as traces and Baggage.++ Propagation is usually implemented via a cooperation of library-specific request interceptors and Propagators,+ where the interceptors detect incoming and outgoing requests and use the Propagator's extract and inject operations+ respectively.++ The Propagators API is expected to be leveraged by users writing instrumentation libraries. However,+ users using the OpenTelemetry SDK may need to select appropriate propagators to work with existing 3rd party systems+ such as AWS.+-} module OpenTelemetry.Propagator where import Control.Monad import Control.Monad.IO.Class import Data.Text + {- |-A carrier is the medium used by Propagators to read values from and write values to. +A carrier is the medium used by Propagators to read values from and write values to. Each specific Propagator type defines its expected carrier type, such as a string map or a byte array. -} data Propagator context inboundCarrier outboundCarrier = Propagator@@ -40,32 +44,42 @@ , injector :: context -> outboundCarrier -> IO outboundCarrier } + instance Semigroup (Propagator c i o) where- (Propagator lNames lExtract lInject) <> (Propagator rNames rExtract rInject) = Propagator- { propagatorNames = lNames <> rNames- , extractor = \i -> lExtract i >=> rExtract i- , injector = \c -> lInject c >=> rInject c- }+ (Propagator lNames lExtract lInject) <> (Propagator rNames rExtract rInject) =+ Propagator+ { propagatorNames = lNames <> rNames+ , extractor = \i -> lExtract i >=> rExtract i+ , injector = \c -> lInject c >=> rInject c+ } + instance Monoid (Propagator c i o) where mempty = Propagator mempty (\_ c -> pure c) (\_ p -> pure p) + {- | Extracts the value from an incoming request. For example, from the headers of an HTTP request. 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 - -> 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 ::+ (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 (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 - -> o -- ^ The carrier that holds the propagation fields. For example, an outgoing message or HTTP request. - -> m o+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 (Propagator _ _ injector) c = liftIO . injector c
src/OpenTelemetry/Resource.hs view
@@ -1,170 +1,203 @@ {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DefaultSignatures #-}+ -------------------------------------------------------------------------------- |--- Module : OpenTelemetry.Resource--- Copyright : (c) Ian Duncan, 2021--- License : BSD-3--- Description : Facilities for attaching metadata attributes to all spans in a trace--- Maintainer : Ian Duncan--- Stability : experimental--- Portability : non-portable (GHC extensions)------ A Resource is an immutable representation of the entity producing--- telemetry. For example, a process producing telemetry that is running in--- a container on Kubernetes has a Pod name, it is in a namespace and--- possibly is part of a Deployment which also has a name. All three of--- these attributes can be included in the Resource.---+ ------------------------------------------------------------------------------module OpenTelemetry.Resource - ( ++{- |+ Module : OpenTelemetry.Resource+ Copyright : (c) Ian Duncan, 2021+ License : BSD-3+ Description : Facilities for attaching metadata attributes to all spans in a trace+ Maintainer : Ian Duncan+ Stability : experimental+ Portability : non-portable (GHC extensions)++ A Resource is an immutable representation of the entity producing+ telemetry. For example, a process producing telemetry that is running in+ a container on Kubernetes has a Pod name, it is in a namespace and+ possibly is part of a Deployment which also has a name. All three of+ these attributes can be included in the Resource.+-}+module OpenTelemetry.Resource ( -- * Creating resources directly- mkResource- , Resource- , (.=)- , (.=?)- , ResourceMerge- , mergeResources+ mkResource,+ Resource,+ (.=),+ (.=?),+ ResourceMerge,+ mergeResources,+ -- * Creating resources from data structures- , ToResource(..)- , materializeResources+ ToResource (..),+ materializeResources,+ -- * Using resources with a 'OpenTelemetry.Trace.TracerProvider'- , MaterializedResources- , emptyMaterializedResources- , getMaterializedResourcesSchema- , getMaterializedResourcesAttributes- ) where+ MaterializedResources,+ emptyMaterializedResources,+ getMaterializedResourcesSchema,+ getMaterializedResourcesAttributes,+) where -import Data.Proxy (Proxy(..))+import Data.Maybe (catMaybes)+import Data.Proxy (Proxy (..)) import Data.Text (Text) import GHC.TypeLits-import Data.Maybe (catMaybes) import OpenTelemetry.Attributes --- | A set of attributes created from one or more resources.------ A Resource is an immutable representation of the entity producing telemetry as Attributes. --- For example, a process producing telemetry that is running in a container on Kubernetes has a Pod name, --- it is in a namespace and possibly is part of a Deployment which also has a name. --- --- All three of these attributes can be included in the Resource. ------ Note that there are certain <https://github.com/open-telemetry/opentelemetry-specification/blob/34144d02baaa39f7aa97ee914539089e1481166c/specification/resource/semantic_conventions/README.md "standard attributes"> that have prescribed meanings.------ A number of these standard resources may be found in the @OpenTelemetry.Resource.*@ modules.------ The primary purpose of resources as a first-class concept in the SDK is decoupling of discovery of resource information from exporters. --- This allows for independent development and easy customization for users that need to integrate with closed source environments. ++{- | A set of attributes created from one or more resources.++ A Resource is an immutable representation of the entity producing telemetry as Attributes.+ For example, a process producing telemetry that is running in a container on Kubernetes has a Pod name,+ it is in a namespace and possibly is part of a Deployment which also has a name.++ All three of these attributes can be included in the Resource.++ Note that there are certain <https://github.com/open-telemetry/opentelemetry-specification/blob/34144d02baaa39f7aa97ee914539089e1481166c/specification/resource/semantic_conventions/README.md "standard attributes"> that have prescribed meanings.++ A number of these standard resources may be found in the @OpenTelemetry.Resource.*@ modules.++ The primary purpose of resources as a first-class concept in the SDK is decoupling of discovery of resource information from exporters.+ This allows for independent development and easy customization for users that need to integrate with closed source environments.+-} newtype Resource (schema :: Maybe Symbol) = Resource Attributes --- | Utility function to create a resource from a list--- of fields and attributes. See the '.=' and '.=?' functions.------ @since 0.0.1.0++{- | Utility function to create a resource from a list+ of fields and attributes. See the '.=' and '.=?' functions.++ @since 0.0.1.0+-} mkResource :: [Maybe (Text, Attribute)] -> Resource r mkResource = Resource . unsafeAttributesFromListIgnoringLimits . catMaybes --- | Utility function to convert a required resource attribute--- into the format needed for 'mkResource'.++{- | Utility function to convert a required resource attribute+ into the format needed for 'mkResource'.+-} (.=) :: 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'.++{- | Utility function to convert an optional resource attribute+ into the format needed for 'mkResource'.+-} (.=?) :: ToAttribute a => Text -> Maybe a -> Maybe (Text, Attribute) k .=? mv = (\k' v -> (k', toAttribute v)) k <$> mv++ instance Semigroup (Resource s) where (<>) (Resource l) (Resource r) = Resource (unsafeMergeAttributesIgnoringLimits l r) + instance Monoid (Resource s) where mempty = Resource emptyAttributes --- | Static checks to prevent invalid resources from being merged.------ Note: This is intended to be utilized for merging of resources whose attributes--- come from different sources,--- such as environment variables, or metadata extracted from the host or container.------ The resulting resource will have all attributes that are on any of the two input resources.--- If a key exists on both the old and updating resource, the value of the updating--- resource will be picked (even if the updated value is "empty").------ The resulting resource will have the Schema URL calculated as follows:------ - If the old resource's Schema URL is empty then the resulting resource's Schema--- URL will be set to the Schema URL of the updating resource,--- - Else if the updating resource's Schema URL is empty then the resulting--- resource's Schema URL will be set to the Schema URL of the old resource,--- - Else if the Schema URLs of the old and updating resources are the same then--- that will be the Schema URL of the resulting resource,--- - Else this is a merging error (this is the case when the Schema URL of the old--- and updating resources are not empty and are different). The resulting resource is--- therefore statically prohibited by this type-level function.---++{- | Static checks to prevent invalid resources from being merged.++ Note: This is intended to be utilized for merging of resources whose attributes+ come from different sources,+ such as environment variables, or metadata extracted from the host or container.++ The resulting resource will have all attributes that are on any of the two input resources.+ If a key exists on both the old and updating resource, the value of the updating+ resource will be picked (even if the updated value is "empty").++ The resulting resource will have the Schema URL calculated as follows:++ - If the old resource's Schema URL is empty then the resulting resource's Schema+ URL will be set to the Schema URL of the updating resource,+ - Else if the updating resource's Schema URL is empty then the resulting+ resource's Schema URL will be set to the Schema URL of the old resource,+ - Else if the Schema URLs of the old and updating resources are the same then+ that will be the Schema URL of the resulting resource,+ - Else this is a merging error (this is the case when the Schema URL of the old+ and updating resources are not empty and are different). The resulting resource is+ therefore statically prohibited by this type-level function.+-} type family ResourceMerge schemaLeft schemaRight :: Maybe Symbol where ResourceMerge 'Nothing 'Nothing = 'Nothing ResourceMerge 'Nothing ('Just s) = 'Just s ResourceMerge ('Just s) 'Nothing = 'Just s ResourceMerge ('Just s) ('Just s) = 'Just s --- | Combine two 'Resource' values into a new 'Resource' that contains the--- attributes of the two inputs.------ See the 'ResourceMerge' documentation about the additional semantics of merging two resources.------ @since 0.0.1.0-mergeResources :: - Resource old - -- ^ the old resource- -> Resource new- -- ^ the updating resource whose attributes take precedence- -> Resource (ResourceMerge old new)++{- | Combine two 'Resource' values into a new 'Resource' that contains the+ attributes of the two inputs.++ See the 'ResourceMerge' documentation about the additional semantics of merging two resources.++ @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 l) (Resource r) = Resource (unsafeMergeAttributesIgnoringLimits l r) + -- | A convenience class for converting arbitrary data into resources. class ToResource a where -- | Resource schema (if any) associated with the defined resource type ResourceSchema a :: Maybe Symbol++ type ResourceSchema a = 'Nothing++ -- | Convert the input value to a 'Resource' toResource :: a -> Resource (ResourceSchema a) + class MaterializeResource schema where -- | Convert resource fields into a version that discharges the schema from the -- type level to the runtime level. materializeResources :: Resource schema -> MaterializedResources + instance MaterializeResource 'Nothing where materializeResources (Resource attrs) = MaterializedResources Nothing attrs + instance KnownSymbol s => MaterializeResource ('Just s) where materializeResources (Resource attrs) = MaterializedResources (Just $ symbolVal (Proxy @s)) attrs + -- | A read-only resource attribute collection with an associated schema. data MaterializedResources = MaterializedResources { materializedResourcesSchema :: Maybe String , materializedResourcesAttributes :: Attributes } --- | A placeholder for 'MaterializedResources' when no resource information is--- available, needed, or required.------ @since 0.0.1.0++{- | A placeholder for 'MaterializedResources' when no resource information is+ available, needed, or required.++ @since 0.0.1.0+-} emptyMaterializedResources :: MaterializedResources emptyMaterializedResources = MaterializedResources Nothing emptyAttributes --- | Access the schema for a 'MaterializedResources' value.------ @since 0.0.1.0++{- | Access the schema for a 'MaterializedResources' value.++ @since 0.0.1.0+-} getMaterializedResourcesSchema :: MaterializedResources -> Maybe String getMaterializedResourcesSchema = materializedResourcesSchema --- | Access the attributes for a 'MaterializedResources' value.------ @since 0.0.1.0++{- | Access the attributes for a 'MaterializedResources' value.++ @since 0.0.1.0+-} getMaterializedResourcesAttributes :: MaterializedResources -> Attributes getMaterializedResourcesAttributes = materializedResourcesAttributes
src/OpenTelemetry/Resource/Cloud.hs view
@@ -1,24 +1,29 @@-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+ -------------------------------------------------------------------------------- |--- Module : OpenTelemetry.Resource.Cloud--- Copyright : (c) Ian Duncan, 2021--- License : BSD-3--- Description : Cloud resource detection--- Maintainer : Ian Duncan--- Stability : experimental--- Portability : non-portable (GHC extensions)------ Cloud resource detection---+ ------------------------------------------------------------------------------module OpenTelemetry.Resource.Cloud - ( Cloud(..)- ) where++{- |+ Module : OpenTelemetry.Resource.Cloud+ Copyright : (c) Ian Duncan, 2021+ License : BSD-3+ Description : Cloud resource detection+ Maintainer : Ian Duncan+ Stability : experimental+ Portability : non-portable (GHC extensions)++ Cloud resource detection+-}+module OpenTelemetry.Resource.Cloud (+ Cloud (..),+) where+ import Data.Text (Text)-import OpenTelemetry.Resource (ToResource(..), mkResource, (.=?))+import OpenTelemetry.Resource (ToResource (..), mkResource, (.=?)) + -- | A cloud infrastructure (e.g. GCP, Azure, AWS). data Cloud = Cloud { cloudProvider :: Maybe Text@@ -41,7 +46,6 @@ -- +------------------+------------------------+ -- | @tencent_cloud@ | Tencent Cloud | -- +------------------+------------------------+- -- , cloudAccountId :: Maybe Text -- ^ The cloud account ID the resource is assigned to. , cloudRegion :: Maybe Text@@ -100,15 +104,16 @@ -- +------------------------------+-------------------------------------------------+ -- | @tencent_cloud_scf@ | Tencent Cloud Serverless Cloud Function (SCF) | -- +------------------------------+-------------------------------------------------+- -- } + instance ToResource Cloud where type ResourceSchema Cloud = 'Nothing- toResource Cloud{..} = mkResource- [ "cloud.provider" .=? cloudProvider- , "cloud.account.id" .=? cloudAccountId- , "cloud.region" .=? cloudRegion- , "cloud.availability_zone" .=? cloudAvailabilityZone- , "cloud.platform" .=? cloudPlatform- ]+ toResource Cloud {..} =+ mkResource+ [ "cloud.provider" .=? cloudProvider+ , "cloud.account.id" .=? cloudAccountId+ , "cloud.region" .=? cloudRegion+ , "cloud.availability_zone" .=? cloudAvailabilityZone+ , "cloud.platform" .=? cloudPlatform+ ]
src/OpenTelemetry/Resource/Container.hs view
@@ -1,20 +1,25 @@-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+ -------------------------------------------------------------------------------- |--- Module : OpenTelemetry.Resource.Container--- Copyright : (c) Ian Duncan, 2021--- License : BSD-3--- Description : Detect & provide resource info about a container--- Maintainer : Ian Duncan--- Stability : experimental--- Portability : non-portable (GHC extensions)---+ -----------------------------------------------------------------------------++{- |+ Module : OpenTelemetry.Resource.Container+ Copyright : (c) Ian Duncan, 2021+ License : BSD-3+ Description : Detect & provide resource info about a container+ Maintainer : Ian Duncan+ Stability : experimental+ Portability : non-portable (GHC extensions)+-} module OpenTelemetry.Resource.Container where+ import Data.Text (Text) import OpenTelemetry.Resource + -- | A container instance. data Container = Container { containerName :: Maybe Text@@ -31,12 +36,14 @@ -- ^ Container image tag. } + instance ToResource Container where type ResourceSchema Container = 'Nothing- toResource Container{..} = mkResource - [ "container.name" .=? containerName- , "container.id" .=? containerId- , "container.runtime" .=? containerRuntime- , "container.image.name" .=? containerImageName- , "container.image.tag" .=? containerImageTag- ]+ toResource Container {..} =+ mkResource+ [ "container.name" .=? containerName+ , "container.id" .=? containerId+ , "container.runtime" .=? containerRuntime+ , "container.image.name" .=? containerImageName+ , "container.image.tag" .=? containerImageTag+ ]
src/OpenTelemetry/Resource/DeploymentEnvironment.hs view
@@ -1,34 +1,42 @@-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+ -------------------------------------------------------------------------------- |--- Module : OpenTelemetry.Resource.DeploymentEnvironment--- Copyright : (c) Ian Duncan, 2021--- License : BSD-3--- Description : Name of the deployment environment (aka deployment tier)--- Maintainer : Ian Duncan--- Stability : experimental--- Portability : non-portable (GHC extensions)---+ -----------------------------------------------------------------------------++{- |+ Module : OpenTelemetry.Resource.DeploymentEnvironment+ Copyright : (c) Ian Duncan, 2021+ License : BSD-3+ Description : Name of the deployment environment (aka deployment tier)+ Maintainer : Ian Duncan+ Stability : experimental+ Portability : non-portable (GHC extensions)+-} module OpenTelemetry.Resource.DeploymentEnvironment where+ import Data.Text (Text) import OpenTelemetry.Resource --- | The software deployment.------ This resource doesn't have a an automatic detector because--- deployment environments tend to have very different detection--- mechanisms for differing projects.++{- | The software deployment.++ This resource doesn't have a an automatic detector because+ deployment environments tend to have very different detection+ mechanisms for differing projects.+-} newtype DeploymentEnvironment = DeploymentEnvironment { deploymentEnvironment :: Maybe Text- -- ^ Name of the deployment environment (aka deployment tier). + -- ^ Name of the deployment environment (aka deployment tier). -- -- Examples: @staging@, @production@ } + instance ToResource DeploymentEnvironment where type ResourceSchema DeploymentEnvironment = 'Nothing- toResource DeploymentEnvironment{..} = mkResource- [ "deployment.environment" .=? deploymentEnvironment- ]+ toResource DeploymentEnvironment {..} =+ mkResource+ [ "deployment.environment" .=? deploymentEnvironment+ ]
src/OpenTelemetry/Resource/Device.hs view
@@ -1,14 +1,17 @@ -------------------------------------------------------------------------------- |--- Module : OpenTelemetry.Resource.Device--- Copyright : (c) Ian Duncan, 2021--- License : BSD-3--- Description : Not implemented yet--- Maintainer : Ian Duncan--- Stability : experimental--- Portability : non-portable (GHC extensions)------ Not implemented. Please file a GitHub issue if you want this.---+ -----------------------------------------------------------------------------++{- |+ Module : OpenTelemetry.Resource.Device+ Copyright : (c) Ian Duncan, 2021+ License : BSD-3+ Description : Not implemented yet+ Maintainer : Ian Duncan+ Stability : experimental+ Portability : non-portable (GHC extensions)++ Not implemented. Please file a GitHub issue if you want this.+-} module OpenTelemetry.Resource.Device where+
src/OpenTelemetry/Resource/FaaS.hs view
@@ -1,30 +1,35 @@-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+ -------------------------------------------------------------------------------- |--- Module : OpenTelemetry.Resource.FaaS--- Copyright : (c) Ian Duncan, 2021--- License : BSD-3--- Description : Resource information about a "function as a service" aka "serverless function" instance--- Maintainer : Ian Duncan--- Stability : experimental--- Portability : non-portable (GHC extensions)---+ -----------------------------------------------------------------------------++{- |+ Module : OpenTelemetry.Resource.FaaS+ Copyright : (c) Ian Duncan, 2021+ License : BSD-3+ Description : Resource information about a "function as a service" aka "serverless function" instance+ Maintainer : Ian Duncan+ Stability : experimental+ Portability : non-portable (GHC extensions)+-} module OpenTelemetry.Resource.FaaS where+ import Data.Text (Text) import OpenTelemetry.Resource + -- | A "function as a service" aka "serverless function" instance. data FaaS = FaaS { faasName :: Text- -- ^ The name of the single function that this runtime instance executes. + -- ^ The name of the single function that this runtime instance executes. -- -- This is the name of the function as configured/deployed on the FaaS platform and is usually different from the name of the callback function (which may be stored in the code.namespace/code.function span attributes). -- -- Examples: 'my-function' , faasId :: Maybe Text- -- ^ The unique ID of the single function that this runtime instance executes. + -- ^ The unique ID of the single function that this runtime instance executes. -- -- Depending on the cloud provider, use: --@@ -58,12 +63,14 @@ -- Examples: '128' } + instance ToResource FaaS where type ResourceSchema FaaS = 'Nothing- toResource FaaS{..} = mkResource- [ "faas.name" .= faasName- , "faas.id" .=? faasId- , "faas.version" .=? faasVersion- , "faas.instance" .=? faasInstance- , "faas.max_memory" .=? faasMaxMemory- ]+ toResource FaaS {..} =+ mkResource+ [ "faas.name" .= faasName+ , "faas.id" .=? faasId+ , "faas.version" .=? faasVersion+ , "faas.instance" .=? faasInstance+ , "faas.max_memory" .=? faasMaxMemory+ ]
src/OpenTelemetry/Resource/Host.hs view
@@ -1,22 +1,27 @@-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+ -------------------------------------------------------------------------------- |--- Module : OpenTelemetry.Resource.Host--- Copyright : (c) Ian Duncan, 2021--- License : BSD-3--- Description : Information about the underlying general computing instance--- Maintainer : Ian Duncan--- Stability : experimental--- Portability : non-portable (GHC extensions)---+ ------------------------------------------------------------------------------module OpenTelemetry.Resource.Host - ( Host (..)- ) where++{- |+ Module : OpenTelemetry.Resource.Host+ Copyright : (c) Ian Duncan, 2021+ License : BSD-3+ Description : Information about the underlying general computing instance+ Maintainer : Ian Duncan+ Stability : experimental+ Portability : non-portable (GHC extensions)+-}+module OpenTelemetry.Resource.Host (+ Host (..),+) where+ import Data.Text (Text)-import OpenTelemetry.Resource (ToResource(..), mkResource, (.=?))+import OpenTelemetry.Resource (ToResource (..), mkResource, (.=?)) + -- | A host is defined as a general computing instance. data Host = Host { hostId :: Maybe Text@@ -35,14 +40,16 @@ -- ^ The version string of the VM image as defined in Version Attributes. } + instance ToResource Host where type ResourceSchema Host = 'Nothing- toResource Host{..} = mkResource- [ "host.id" .=? hostId- , "host.name" .=? hostName- , "host.type" .=? hostType- , "host.arch" .=? hostArch- , "host.image.name" .=? hostImageName- , "host.image.id" .=? hostImageId- , "host.image.version" .=? hostImageVersion- ]+ toResource Host {..} =+ mkResource+ [ "host.id" .=? hostId+ , "host.name" .=? hostName+ , "host.type" .=? hostType+ , "host.arch" .=? hostArch+ , "host.image.name" .=? hostImageName+ , "host.image.id" .=? hostImageId+ , "host.image.version" .=? hostImageVersion+ ]
src/OpenTelemetry/Resource/Kubernetes.hs view
@@ -1,55 +1,70 @@-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+ -------------------------------------------------------------------------------- |--- Module : OpenTelemetry.Resource.Kubernetes--- Copyright : (c) Ian Duncan, 2021--- License : BSD-3--- Description : Information about how and where a process is running in a k8s cluster--- Maintainer : Ian Duncan--- Stability : experimental--- Portability : non-portable (GHC extensions)---+ -----------------------------------------------------------------------------++{- |+ Module : OpenTelemetry.Resource.Kubernetes+ Copyright : (c) Ian Duncan, 2021+ License : BSD-3+ Description : Information about how and where a process is running in a k8s cluster+ Maintainer : Ian Duncan+ Stability : experimental+ Portability : non-portable (GHC extensions)+-} module OpenTelemetry.Resource.Kubernetes where+ import Data.Text (Text) import OpenTelemetry.Resource + -- | A Kubernetes Cluster. newtype Cluster = Cluster { clusterName :: Maybe Text -- ^ The name of the cluster. } + instance ToResource Cluster where type ResourceSchema Cluster = 'Nothing- toResource Cluster{..} = mkResource- ["k8s.cluster.name" .=? clusterName]+ toResource Cluster {..} =+ mkResource+ ["k8s.cluster.name" .=? clusterName] + -- | A Kubernetes Node. data Node = Node { nodeName :: Maybe Text , nodeUid :: Maybe Text }++ instance ToResource Node where type ResourceSchema Node = 'Nothing- toResource Node{..} = mkResource- [ "k8s.node.name" .=? nodeName- , "k8s.node.uid" .=? nodeUid- ]+ toResource Node {..} =+ mkResource+ [ "k8s.node.name" .=? nodeName+ , "k8s.node.uid" .=? nodeUid+ ] + -- | Namespaces provide a scope for names. Names of objects need to be unique within a namespace, but not across namespaces. newtype Namespace = Namespace { namespaceName :: Maybe Text -- ^ The name of the namespace that the pod is running in. } + instance ToResource Namespace where type ResourceSchema Namespace = 'Nothing- toResource Namespace{..} = mkResource- [ "k8s.namespace.name" .=? namespaceName- ]+ toResource Namespace {..} =+ mkResource+ [ "k8s.namespace.name" .=? namespaceName+ ] + -- | The smallest and simplest Kubernetes object. A Pod represents a set of running containers on your cluster. data Pod = Pod { podName :: Maybe Text@@ -58,41 +73,50 @@ -- ^ The UID of the Pod. } + instance ToResource Pod where type ResourceSchema Pod = 'Nothing- toResource Pod{..} = mkResource- [ "k8s.pod.name" .=? podName- , "k8s.pod.uid" .=? podUid- ]+ toResource Pod {..} =+ mkResource+ [ "k8s.pod.name" .=? podName+ , "k8s.pod.uid" .=? podUid+ ] + -- | A container in a PodTemplate. data Container = Container { containerName :: Maybe Text- -- ^ The name of the Container from Pod specification, must be unique within a Pod. Container runtime usually uses different globally unique name (container.name). + -- ^ The name of the Container from Pod specification, must be unique within a Pod. Container runtime usually uses different globally unique name (container.name). , containerRestartCount :: Maybe Int- -- ^ Number of times the container was restarted. This attribute can be used to identify a particular container (running or stopped) within a container spec. + -- ^ Number of times the container was restarted. This attribute can be used to identify a particular container (running or stopped) within a container spec. } + instance ToResource Container where type ResourceSchema Container = 'Nothing- toResource Container{..} = mkResource- [ "k8s.container.name" .=? containerName- , "k8s.container.restart_count" .=? containerRestartCount- ]+ toResource Container {..} =+ mkResource+ [ "k8s.container.name" .=? containerName+ , "k8s.container.restart_count" .=? containerRestartCount+ ] + -- | A ReplicaSet’s purpose is to maintain a stable set of replica Pods running at any given time. data ReplicaSet = ReplicaSet { replicaSetUid :: Maybe Text , replicaSetName :: Maybe Text } + instance ToResource ReplicaSet where type ResourceSchema ReplicaSet = 'Nothing- toResource ReplicaSet{..} = mkResource- [ "k8s.replicaset.name" .=? replicaSetName- , "k8s.replicaset.uid" .=? replicaSetUid- ]+ toResource ReplicaSet {..} =+ mkResource+ [ "k8s.replicaset.name" .=? replicaSetName+ , "k8s.replicaset.uid" .=? replicaSetUid+ ] + -- | An API object that manages a replicated application, typically by running Pods with no local state. Each replica is represented by a Pod, and the Pods are distributed among the nodes of a cluster. data Deployment = Deployment { deploymentUid :: Maybe Text@@ -101,13 +125,16 @@ -- ^ The name of the Deployment. } + instance ToResource Deployment where type ResourceSchema Deployment = 'Nothing- toResource Deployment{..} = mkResource- [ "k8s.deployment.name" .=? deploymentName- , "k8s.deployment.uid" .=? deploymentUid- ]+ toResource Deployment {..} =+ mkResource+ [ "k8s.deployment.name" .=? deploymentName+ , "k8s.deployment.uid" .=? deploymentUid+ ] + -- | Manages the deployment and scaling of a set of Pods, and provides guarantees about the ordering and uniqueness of these Pods. data StatefulSet = StatefulSet { statefulSetUid :: Maybe Text@@ -116,28 +143,34 @@ -- ^ The name of the StatefulSet. } + instance ToResource StatefulSet where type ResourceSchema StatefulSet = 'Nothing- toResource StatefulSet{..} = mkResource- [ "k8s.statefulset.name" .=? statefulSetName- , "k8s.statefulset.uid" .=? statefulSetUid- ]+ toResource StatefulSet {..} =+ mkResource+ [ "k8s.statefulset.name" .=? statefulSetName+ , "k8s.statefulset.uid" .=? statefulSetUid+ ] + -- | A DaemonSet ensures that all (or some) Nodes run a copy of a Pod. data DaemonSet = DaemonSet { daemonSetUid :: Maybe Text- -- ^ The UID of the DaemonSet. + -- ^ The UID of the DaemonSet. , daemonSetName :: Maybe Text -- ^ The name of the DaemonSet. } + instance ToResource DaemonSet where type ResourceSchema DaemonSet = 'Nothing- toResource DaemonSet{..} = mkResource- [ "k8s.daemonset.name" .=? daemonSetName- , "k8s.daemonset.uid" .=? daemonSetUid- ]+ toResource DaemonSet {..} =+ mkResource+ [ "k8s.daemonset.name" .=? daemonSetName+ , "k8s.daemonset.uid" .=? daemonSetUid+ ] + -- | A Job creates one or more Pods and ensures that a specified number of them successfully terminate. data Job = Job { jobUid :: Maybe Text@@ -146,13 +179,16 @@ -- ^ The name of the Job. } + instance ToResource Job where type ResourceSchema Job = 'Nothing- toResource Job{..} = mkResource- [ "k8s.job.name" .=? jobName- , "k8s.job.uid" .=? jobUid- ]+ toResource Job {..} =+ mkResource+ [ "k8s.job.name" .=? jobName+ , "k8s.job.uid" .=? jobUid+ ] + -- | A CronJob creates Jobs on a repeating schedule. data CronJob = CronJob { cronJobUid :: Maybe Text@@ -161,9 +197,11 @@ -- ^ The name of the CronJob. } + instance ToResource CronJob where type ResourceSchema CronJob = 'Nothing- toResource CronJob{..} = mkResource- [ "k8s.cronjob.name" .=? cronJobName- , "k8s.cronjob.uid" .=? cronJobUid- ]+ toResource CronJob {..} =+ mkResource+ [ "k8s.cronjob.name" .=? cronJobName+ , "k8s.cronjob.uid" .=? cronJobUid+ ]
src/OpenTelemetry/Resource/OperatingSystem.hs view
@@ -1,22 +1,27 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-}+ -------------------------------------------------------------------------------- |--- Module : OpenTelemetry.Resource.OperatingSystem--- Copyright : (c) Ian Duncan, 2021--- License : BSD-3--- Description : Information about the operating system (OS) on which the process represented by this resource is running.--- Maintainer : Ian Duncan--- Stability : experimental--- Portability : non-portable (GHC extensions)------ In case of virtualized environments, this is the operating system as it is observed by the process, i.e., the virtualized guest rather than the underlying host.---+ -----------------------------------------------------------------------------++{- |+ Module : OpenTelemetry.Resource.OperatingSystem+ Copyright : (c) Ian Duncan, 2021+ License : BSD-3+ Description : Information about the operating system (OS) on which the process represented by this resource is running.+ Maintainer : Ian Duncan+ Stability : experimental+ Portability : non-portable (GHC extensions)++ In case of virtualized environments, this is the operating system as it is observed by the process, i.e., the virtualized guest rather than the underlying host.+-} module OpenTelemetry.Resource.OperatingSystem where+ import Data.Text (Text) import OpenTelemetry.Resource + -- | The operating system (OS) on which the process represented by this resource is running. data OperatingSystem = OperatingSystem { osType :: Text@@ -49,7 +54,6 @@ -- +-----------------+---------------------------------------+ -- | @z_os@ | IBM z/OS | -- +-----------------+---------------------------------------+- , osDescription :: Maybe Text -- ^ Human readable (not intended to be parsed) OS version information, like e.g. reported by @ver@ or @lsb_release -a@ commands. , osName :: Maybe Text@@ -58,12 +62,16 @@ -- ^ The version string of the operating system as defined in } + instance ToResource OperatingSystem where type ResourceSchema OperatingSystem = 'Nothing++ -- TODO ^ schema- toResource OperatingSystem{..} = mkResource- [ "os.type" .= osType- , "os.description" .=? osDescription- , "os.name" .=? osName- , "os.version" .=? osVersion- ]+ toResource OperatingSystem {..} =+ mkResource+ [ "os.type" .= osType+ , "os.description" .=? osDescription+ , "os.name" .=? osName+ , "os.version" .=? osVersion+ ]
src/OpenTelemetry/Resource/Process.hs view
@@ -1,21 +1,26 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-}+ -------------------------------------------------------------------------------- |--- Module : OpenTelemetry.Resource.Process--- Copyright : (c) Ian Duncan, 2021--- License : BSD-3--- Description : Standard resources and detectors for system processes--- Maintainer : Ian Duncan--- Stability : experimental--- Portability : non-portable (GHC extensions)---+ -----------------------------------------------------------------------------++{- |+ Module : OpenTelemetry.Resource.Process+ Copyright : (c) Ian Duncan, 2021+ License : BSD-3+ Description : Standard resources and detectors for system processes+ Maintainer : Ian Duncan+ Stability : experimental+ Portability : non-portable (GHC extensions)+-} module OpenTelemetry.Resource.Process where+ import Data.Text (Text) import OpenTelemetry.Resource + -- | An operating system process. data Process = Process { processPid :: Maybe Int@@ -39,35 +44,38 @@ -- -- Example: @C:\cmd\otecol --config="my directory\config.yaml"@ , processCommandArgs :: Maybe [Text]- -- ^ All the command arguments (including the command/executable itself) as received by the process. On Linux-based systems (and some other Unixoid systems supporting procfs), can be set according to the list of null-delimited strings extracted from @proc/[pid]/cmdline@. For libc-based executables, this would be the full argv vector passed to main. + -- ^ All the command arguments (including the command/executable itself) as received by the process. On Linux-based systems (and some other Unixoid systems supporting procfs), can be set according to the list of null-delimited strings extracted from @proc/[pid]/cmdline@. For libc-based executables, this would be the full argv vector passed to main. -- -- Example: @[cmd/otecol, --config=config.yaml]@ , processOwner :: Maybe Text- -- ^ The username of the user that owns the process. + -- ^ The username of the user that owns the process. -- -- Example: @root@ } + instance ToResource Process where type ResourceSchema Process = 'Nothing- toResource Process{..} = mkResource- [ "process.pid" .=? processPid- , "process.executable.name" .=? processExecutableName- , "process.executable.path" .=? processExecutablePath- , "process.command" .=? processCommand- , "process.command_line" .=? processCommandLine- , "process.command_args" .=? processCommandArgs- , "process.owner" .=? processOwner- ]+ toResource Process {..} =+ mkResource+ [ "process.pid" .=? processPid+ , "process.executable.name" .=? processExecutableName+ , "process.executable.path" .=? processExecutablePath+ , "process.command" .=? processCommand+ , "process.command_line" .=? processCommandLine+ , "process.command_args" .=? processCommandArgs+ , "process.owner" .=? processOwner+ ] + -- | The single (language) runtime instance which is monitored. data ProcessRuntime = ProcessRuntime { processRuntimeName :: Maybe Text- -- ^ The name of the runtime of this process. For compiled native binaries, this SHOULD be the name of the compiler. + -- ^ The name of the runtime of this process. For compiled native binaries, this SHOULD be the name of the compiler. -- -- Example: @OpenJDK Runtime Environment@ , processRuntimeVersion :: Maybe Text- -- ^ The version of the runtime of this process, as returned by the runtime without modification. + -- ^ The version of the runtime of this process, as returned by the runtime without modification. -- -- Example: @14.0.2@ , processRuntimeDescription :: Maybe Text@@ -76,10 +84,12 @@ -- Example: @Eclipse OpenJ9 Eclipse OpenJ9 VM openj9-0.21.0@ } + instance ToResource ProcessRuntime where type ResourceSchema ProcessRuntime = 'Nothing- toResource ProcessRuntime{..} = mkResource- [ "process.runtime.name" .=? processRuntimeName- , "process.runtime.version" .=? processRuntimeVersion- , "process.runtime.description" .=? processRuntimeDescription- ]+ toResource ProcessRuntime {..} =+ mkResource+ [ "process.runtime.name" .=? processRuntimeName+ , "process.runtime.version" .=? processRuntimeVersion+ , "process.runtime.description" .=? processRuntimeDescription+ ]
src/OpenTelemetry/Resource/Service.hs view
@@ -1,27 +1,32 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-}+ -------------------------------------------------------------------------------- |--- Module : OpenTelemetry.Resource.Service--- Copyright : (c) Ian Duncan, 2021--- License : BSD-3--- Description : Resource information about a "service"--- Maintainer : Ian Duncan--- Stability : experimental--- Portability : non-portable (GHC extensions)---+ -----------------------------------------------------------------------------++{- |+ Module : OpenTelemetry.Resource.Service+ Copyright : (c) Ian Duncan, 2021+ License : BSD-3+ Description : Resource information about a "service"+ Maintainer : Ian Duncan+ Stability : experimental+ Portability : non-portable (GHC extensions)+-} module OpenTelemetry.Resource.Service where+ import Data.Text import OpenTelemetry.Resource + -- | A service instance data Service = Service { serviceName :: Text -- ^ Logical name of the service. --- -- MUST be the same for all instances of horizontally scaled services. - -- If the value was not specified, SDKs MUST fallback to unknown_service: concatenated with process.executable.name, + -- MUST be the same for all instances of horizontally scaled services.+ -- If the value was not specified, SDKs MUST fallback to unknown_service: concatenated with process.executable.name, -- e.g. unknown_service:bash. If process.executable.name is not available, the value MUST be set to unknown_service. -- -- If using the built-in resource detectors, this can be specified via the@@ -44,11 +49,13 @@ -- Example: @2.0.0@ } + instance ToResource Service where type ResourceSchema Service = 'Nothing- toResource Service{..} = mkResource- [ "service.name" .= serviceName- , "service.namespace" .=? serviceNamespace- , "service.instance.id" .=? serviceInstanceId- , "service.version" .=? serviceVersion- ]+ toResource Service {..} =+ mkResource+ [ "service.name" .= serviceName+ , "service.namespace" .=? serviceNamespace+ , "service.instance.id" .=? serviceInstanceId+ , "service.version" .=? serviceVersion+ ]
src/OpenTelemetry/Resource/Telemetry.hs view
@@ -1,22 +1,27 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-}+ -------------------------------------------------------------------------------- |--- Module : OpenTelemetry.Resource.Telemetry--- Copyright : (c) Ian Duncan, 2021--- License : BSD-3--- Description : Information about the telemetry SDK used to capture data recorded --- by the instrumentation libraries.--- Maintainer : Ian Duncan--- Stability : experimental--- Portability : non-portable (GHC extensions)---+ -----------------------------------------------------------------------------++{- |+ Module : OpenTelemetry.Resource.Telemetry+ Copyright : (c) Ian Duncan, 2021+ License : BSD-3+ Description : Information about the telemetry SDK used to capture data recorded+ by the instrumentation libraries.+ Maintainer : Ian Duncan+ Stability : experimental+ Portability : non-portable (GHC extensions)+-} module OpenTelemetry.Resource.Telemetry where-import Data.Text ( Text )++import Data.Text (Text) import OpenTelemetry.Resource + -- - id: cpp -- value: "cpp" -- - id: dotnet@@ -49,14 +54,15 @@ -- ^ The version string of the telemetry SDK. , telemetryAutoVersion :: Maybe Text --- ^ The version string of the auto instrumentation agent, if used.- } -instance ToResource Telemetry where ++instance ToResource Telemetry where type ResourceSchema Telemetry = 'Nothing- toResource Telemetry{..} = mkResource- [ "telemetry.sdk.name" .= telemetrySdkName- , "telemetry.sdk.language" .=? telemetrySdkLanguage- , "telemetry.sdk.version" .=? telemetrySdkVersion- , "telemetry.auto.version" .=? telemetryAutoVersion- ]+ toResource Telemetry {..} =+ mkResource+ [ "telemetry.sdk.name" .= telemetrySdkName+ , "telemetry.sdk.language" .=? telemetrySdkLanguage+ , "telemetry.sdk.version" .=? telemetrySdkVersion+ , "telemetry.auto.version" .=? telemetryAutoVersion+ ]
src/OpenTelemetry/Resource/Webengine.hs view
@@ -1,14 +1,17 @@ -------------------------------------------------------------------------------- |--- Module : OpenTelemetry.Resource.Telemetry--- Copyright : (c) Ian Duncan, 2021--- License : BSD-3--- Description : Not implemented--- Maintainer : Ian Duncan--- Stability : experimental--- Portability : non-portable (GHC extensions)------ Not implemented. Please file a GitHub issue if you want this.---+ -----------------------------------------------------------------------------++{- |+ Module : OpenTelemetry.Resource.Telemetry+ Copyright : (c) Ian Duncan, 2021+ License : BSD-3+ Description : Not implemented+ Maintainer : Ian Duncan+ Stability : experimental+ Portability : non-portable (GHC extensions)++ Not implemented. Please file a GitHub issue if you want this.+-} module OpenTelemetry.Resource.Webengine where+
src/OpenTelemetry/Trace/Core.hs view
@@ -1,771 +1,870 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NumericUnderscores #-}-{-# LANGUAGE ScopedTypeVariables #-}--------------------------------------------------------------------------------- |--- Module : OpenTelemetry.Trace.Core--- Copyright : (c) Ian Duncan, 2021--- License : BSD-3--- Description : Low-level tracing API--- Maintainer : Ian Duncan--- Stability : experimental--- Portability : non-portable (GHC extensions)------ Traces track the progression of a single request, called a trace, as it is handled by services that make up an application. The request may be initiated by a user or an application. Distributed tracing is a form of tracing that traverses process, network and security boundaries. Each unit of work in a trace is called a span; a trace is a tree of spans. Spans are objects that represent the work being done by individual services or components involved in a request as it flows through a system. A span contains a span context, which is a set of globally unique identifiers that represent the unique request that each span is a part of. A span provides Request, Error and Duration (RED) metrics that can be used to debug availability as well as performance issues.------ A trace contains a single root span which encapsulates the end-to-end latency for the entire request. You can think of this as a single logical operation, such as clicking a button in a web application to add a product to a shopping cart. The root span would measure the time it took from an end-user clicking that button to the operation being completed or failing (so, the item is added to the cart or some error occurs) and the result being displayed to the user. A trace is comprised of the single root span and any number of child spans, which represent operations taking place as part of the request. Each span contains metadata about the operation, such as its name, start and end timestamps, attributes, events, and status.--- --- To create and manage 'Span's in OpenTelemetry, the <https://hackage.haskell.org/package/hs-opentelemetry-api OpenTelemetry API> provides the tracer interface. This object is responsible for tracking the active span in your process, and allows you to access the current span in order to perform operations on it such as adding attributes, events, and finishing it when the work it tracks is complete. One or more tracer objects can be created in a process through the tracer provider, a factory interface that allows for multiple 'Tracer's to be instantiated in a single process with different options.--- --- Generally, the lifecycle of a span resembles the following:--- --- A request is received by a service. The span context is extracted from the request headers, if it exists.--- A new span is created as a child of the extracted span context; if none exists, a new root span is created.--- The service handles the request. Additional attributes and events are added to the span that are useful for understanding the context of the request, such as the hostname of the machine handling the request, or customer identifiers.--- New spans may be created to represent work being done by sub-components of the service.--- When the service makes a remote call to another service, the current span context is serialized and forwarded to the next service by injecting the span context into the headers or message envelope.--- The work being done by the service completes, successfully or not. The span status is appropriately set, and the span is marked finished.--- For more information, see the traces specification, which covers concepts including: trace, span, parent/child relationship, span context, attributes, events and links.--------- This module implements eveything required to conform to the trace & span public interface described--- by the OpenTelemetry specification.------ See OpenTelemetry.Trace.Monad for an implementation that's--- generally easier to use in idiomatic Haskell.----------------------------------------------------------------------------------module OpenTelemetry.Trace.Core (- -- * @TracerProvider@ operations- TracerProvider- , createTracerProvider- , shutdownTracerProvider- , forceFlushTracerProvider- , getTracerProviderResources- , getTracerProviderPropagators- , getGlobalTracerProvider- , setGlobalTracerProvider- , emptyTracerProviderOptions- , TracerProviderOptions(..)- -- * @Tracer@ operations- , Tracer- , tracerName- , HasTracer(..)- , makeTracer- , getTracer- , getImmutableSpanTracer- , getTracerTracerProvider- , InstrumentationLibrary(..)- , TracerOptions(..)- , tracerOptions- -- * Span operations- , Span- , ImmutableSpan(..)- , SpanContext(..)- -- | W3c Trace flags - --- -- https://www.w3.org/TR/trace-context/#trace-flags- , TraceFlags- , traceFlagsValue- , traceFlagsFromWord8- , defaultTraceFlags- , isSampled- , setSampled- , unsetSampled- -- ** Creating @Span@s- , inSpan- , inSpan'- , inSpan''- , createSpan- , createSpanWithoutCallStack- , wrapSpanContext- , SpanKind(..)- , defaultSpanArguments- , SpanArguments(..)- , NewLink(..)- , Link(..)- -- ** Recording @Event@s- , Event(..)- , NewEvent(..)- , addEvent- -- ** Enriching @Span@s with additional information- , updateName- , OpenTelemetry.Trace.Core.addAttribute- , OpenTelemetry.Trace.Core.addAttributes- , spanGetAttributes- , Attribute(..)- , ToAttribute(..)- , PrimitiveAttribute(..)- , ToPrimitiveAttribute(..)- -- ** Recording error information - , recordException- , setStatus- , SpanStatus(..)- -- ** Completing @Span@s- , endSpan- -- ** Accessing other @Span@ information- , getSpanContext- , isRecording- , isValid- , spanIsRemote- -- * Utilities- , Timestamp- , getTimestamp- , timestampNanoseconds- , unsafeReadSpan- , whenSpanIsRecording- -- * Limits- , SpanLimits(..)- , defaultSpanLimits- , bracketError-) where-import Control.Applicative-import Control.Concurrent.Async-import Control.Concurrent (myThreadId)-import Control.Exception ( Exception(..), try, SomeException(..) )-import Control.Monad-import Control.Monad.IO.Class-import Data.Coerce-import Data.IORef-import Data.Maybe (isNothing, fromMaybe, isJust)-import Data.Text (Text)-import qualified Data.Text as T-import Data.Typeable-import qualified Data.Vector as V-import Data.Word (Word64)-import GHC.Stack-import Network.HTTP.Types-import OpenTelemetry.Attributes-import qualified OpenTelemetry.Attributes as A-import OpenTelemetry.Context-import OpenTelemetry.Common-import OpenTelemetry.Context.ThreadLocal-import OpenTelemetry.Propagator (Propagator)-import OpenTelemetry.Internal.Trace.Types-import qualified OpenTelemetry.Internal.Trace.Types as Types-import OpenTelemetry.Resource-import OpenTelemetry.Trace.Id-import OpenTelemetry.Trace.Id.Generator-import OpenTelemetry.Trace.Id.Generator.Dummy-import OpenTelemetry.Trace.Sampler-import qualified OpenTelemetry.Trace.TraceState as TraceState-import OpenTelemetry.Util-import System.Clock-import System.IO.Unsafe-import System.Timeout (timeout)-import Control.Monad.IO.Unlift-import OpenTelemetry.Logging.Core (Log)--- | Create a 'Span'. ------ If the provided 'Context' has a span in it (inserted via 'OpenTelemetry.Context.insertSpan'),--- that 'Span' will be used as the parent of the 'Span' created via this API.------ Note: if the @hs-opentelemetry-sdk@ or another SDK is not installed, all actions that use the created--- 'Span's produced will be no-ops.------ @since 0.0.1.0-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'- -> Context- -- ^ Context, potentially containing a parent span. If no existing parent (or context) exists,- -- you can use 'OpenTelemetry.Context.empty'.- -> Text- -- ^ Span name- -> SpanArguments- -- ^ Additional span information- -> m Span- -- ^ The created 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- }---- | The same thing as 'createSpan', except that it does not have a 'HasCallStack' constraint.-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'- -> Context- -- ^ Context, potentially containing a parent span. If no existing parent (or context) exists,- -- you can use 'OpenTelemetry.Context.empty'.- -> 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- tId <- case parent of- Nothing -> newTraceId $ tracerProviderIdGenerator $ tracerProvider t- Just (Span s) ->- traceId . Types.spanContext <$> readIORef s- Just (FrozenSpan s) -> pure $ traceId s- Just (Dropped s) -> pure $ traceId s-- if null $ tracerProviderProcessors $ tracerProvider t- then pure $ Dropped $ SpanContext defaultTraceFlags False tId sId TraceState.empty- else do- (samplingOutcome, attrs, samplingTraceState) <- case parent of- -- TODO, this seems logically like what we'd do here- Just (Dropped _) -> pure (Drop, [], TraceState.empty)- _ -> shouldSample (tracerProviderSampler $ tracerProvider t)- ctxt- tId- n- args-- -- TODO properly populate- let ctxtForSpan = SpanContext- { traceFlags = case samplingOutcome of- Drop -> defaultTraceFlags- RecordOnly -> defaultTraceFlags- RecordAndSample -> setSampled defaultTraceFlags- , isRemote = False- , traceState = samplingTraceState- , spanId = sId- , traceId = tId- }-- mkRecordingSpan = do- st <- maybe getTimestamp pure startTime- tid <- myThreadId- let additionalInfo = [("thread.id", toAttribute $ getThreadId tid)]- is = ImmutableSpan- { spanName = n- , spanContext = ctxtForSpan- , spanParent = parent- , spanKind = kind- , spanAttributes =- A.addAttributes- (limitBy t spanAttributeCountLimit)- emptyAttributes- (concat [additionalInfo, attrs, attributes])- , spanLinks =- let limitedLinks = fromMaybe 128 (linkCountLimit $ tracerProviderSpanLimits $ tracerProvider t)- in frozenBoundedCollection limitedLinks $ fmap freezeLink links- , spanEvents = emptyAppendOnlyBoundedCollection $ fromMaybe 128 (eventCountLimit $ tracerProviderSpanLimits $ tracerProvider t)- , spanStatus = Unset- , spanStart = st- , spanEnd = Nothing- , spanTracer = t- }- s <- newIORef is- eResult <- try $ mapM_ (\processor -> processorOnStart processor s ctxt) $ tracerProviderProcessors $ tracerProvider t- case eResult of- Left err -> print (err :: SomeException)- Right _ -> pure ()- pure $ Span s-- case samplingOutcome of- Drop -> pure $ Dropped ctxtForSpan- RecordOnly -> mkRecordingSpan- RecordAndSample -> mkRecordingSpan- where- freezeLink :: NewLink -> Link- freezeLink NewLink{..} = Link- { frozenLinkContext = linkContext- , frozenLinkAttributes = A.addAttributes (limitBy t linkAttributeCountLimit) A.emptyAttributes linkAttributes- }---- | The simplest function for annotating code with trace information.------ @since 0.0.1.0-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.- -> 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-inSpan t n args m = inSpan'' t callStack n args (const m)--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 = inSpan'' t callStack--inSpan''- :: (MonadUnliftIO m, HasCallStack)- => Tracer- -> CallStack- -- ^ Record the location of the span in the codebase using the provided- -- callstack for source location info.- -> Text- -- ^ The name of the span. This may be updated later via 'updateName'- -> SpanArguments- -> (Span -> m a)- -> m a-inSpan'' t cs 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- endSpan s Nothing- adjustContext $ \ctx ->- maybe (removeSpan ctx) (`insertSpan` ctx) parent- )- (\(_, s) -> f s)----- | Returns whether the the @Span@ is currently recording. If a span--- is dropped, this will always return False. If a span is from an--- external process, this will return True, and if the span was --- created by this process, the span will return True until endSpan--- is called.-isRecording :: MonadIO m => Span -> m Bool-isRecording (Span s) = liftIO (isNothing . spanEnd <$> readIORef s)-isRecording (FrozenSpan _) = pure True-isRecording (Dropped _) = pure False--{- | Add an attribute to a span. Only has a useful effect on recording spans.--As an application developer when you need to record an attribute first consult existing semantic conventions for Resources, Spans, and Metrics. If an appropriate name does not exists you will need to come up with a new name. To do that consider a few options:--The name is specific to your company and may be possibly used outside the company as well. To avoid clashes with names introduced by other companies (in a distributed system that uses applications from multiple vendors) it is recommended to prefix the new name by your company’s reverse domain name, e.g. 'com.acme.shopname'.--The name is specific to your application that will be used internally only. If you already have an internal company process that helps you to ensure no name clashes happen then feel free to follow it. Otherwise it is recommended to prefix the attribute name by your application name, provided that the application name is reasonably unique within your organization (e.g. 'myuniquemapapp.longitude' is likely fine). Make sure the application name does not clash with an existing semantic convention namespace.--The name may be generally applicable to applications in the industry. In that case consider submitting a proposal to this specification to add a new name to the semantic conventions, and if necessary also to add a new namespace.--It is recommended to limit names to printable Basic Latin characters (more precisely to 'U+0021' .. 'U+007E' subset of Unicode code points), although the Haskell OpenTelemetry specification DOES provide full Unicode support.--Attribute names that start with 'otel.' are reserved to be defined by OpenTelemetry specification. These are typically used to express OpenTelemetry concepts in formats that don’t have a corresponding concept.--For example, the 'otel.library.name' attribute is used to record the instrumentation library name, which is an OpenTelemetry concept that is natively represented in OTLP, but does not have an equivalent in other telemetry formats and protocols.--Any additions to the 'otel.*' namespace MUST be approved as part of OpenTelemetry specification.--@since 0.0.1.0--}-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 =- OpenTelemetry.Attributes.addAttribute- (limitBy (spanTracer i) spanAttributeCountLimit)- (spanAttributes i)- k- v- }-addAttribute (FrozenSpan _) _ _ = pure ()-addAttribute (Dropped _) _ _ = pure ()---- | A convenience function related to 'addAttribute' that adds multiple attributes to a span at the same time.------ This function may be slightly more performant than repeatedly calling 'addAttribute'. ------ @since 0.0.1.0-addAttributes :: MonadIO m => Span -> [(Text, A.Attribute)] -> m ()-addAttributes (Span s) attrs = liftIO $ modifyIORef s $ \i -> i- { spanAttributes =- OpenTelemetry.Attributes.addAttributes- (limitBy (spanTracer i) spanAttributeCountLimit)- (spanAttributes i)- attrs- }-addAttributes (FrozenSpan _) _ = pure ()-addAttributes (Dropped _) _ = pure ()---- | Add an event to a recording span. Events will not be recorded for remote spans and dropped spans.------ @since 0.0.1.0-addEvent :: MonadIO m => Span -> NewEvent -> m ()-addEvent (Span s) NewEvent{..} = liftIO $ do- t <- maybe getTimestamp pure newEventTimestamp- modifyIORef s $ \i -> i- { spanEvents = appendToBoundedCollection (spanEvents i) $- Event- { eventName = newEventName- , eventAttributes = A.addAttributes- (limitBy (spanTracer i) eventAttributeCountLimit)- emptyAttributes- newEventAttributes- , eventTimestamp = t- }- }-addEvent (FrozenSpan _) _ = pure ()-addEvent (Dropped _) _ = pure ()---- | Sets the Status of the Span. If used, this will override the default @Span@ status, which is @Unset@.------ These values form a total order: Ok > Error > Unset. This means that setting Status with StatusCode=Ok will override any prior or future attempts to set span Status with StatusCode=Error or StatusCode=Unset.------ @since 0.0.1.0-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- }-setStatus (FrozenSpan _) _ = pure ()-setStatus (Dropped _) _ = pure ()--{- |-Updates the Span name. Upon this update, any sampling behavior based on Span name will depend on the implementation.--Note that @Sampler@s can only consider information already present during span creation. Any changes done later, including updated span name, cannot change their decisions.--Alternatives for the name update may be late Span creation, when Span is started with the explicit timestamp from the past at the moment where the final Span name is known, or reporting a Span with the desired name as a child Span.--@since 0.0.1.0--}-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 ()--{- |-Signals that the operation described by this span has now (or at the time optionally specified) ended.--This does have any effects on child spans. Those may still be running and can be ended later.--This also does not inactivate the Span in any Context it is active in. It is still possible to use an ended span as -parent via a Context it is contained in. Also, putting the Span into a Context will still work after the Span was ended.--@since 0.0.1.0--}-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 ->- let ref = i { spanEnd = spanEnd i <|> Just ts }- in (ref, (isJust $ spanEnd i, ref))- unless alreadyFinished $ do- eResult <- try $ mapM_ (`processorOnEnd` s) $ tracerProviderProcessors $ tracerProvider $ spanTracer frozenS- case eResult of- Left err -> print (err :: SomeException)- Right _ -> pure ()-endSpan (FrozenSpan _) _ = pure ()-endSpan (Dropped _) _ = pure ()---- | A specialized variant of @addEvent@ that records attributes conforming to--- the OpenTelemetry specification's --- <https://github.com/open-telemetry/opentelemetry-specification/blob/49c2f56f3c0468ceb2b69518bcadadd96e0a5a8b/specification/trace/semantic_conventions/exceptions.md semantic conventions>------ @since 0.0.1.0-recordException :: (MonadIO m, Exception e) => Span -> [(Text, Attribute)] -> Maybe Timestamp -> e -> m ()-recordException s attrs ts e = liftIO $ do- cs <- whoCreated e- let message = T.pack $ show e- addEvent s $ 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)- ]- , newEventTimestamp = ts- }---- | Returns @True@ if the @SpanContext@ has a non-zero @TraceID@ and a non-zero @SpanID@-isValid :: SpanContext -> Bool-isValid sc = not- (isEmptyTraceId (traceId sc) && isEmptySpanId (spanId sc))--{- |-Returns @True@ if the @SpanContext@ was propagated from a remote parent, --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 (Span s) = liftIO $ do- i <- readIORef s- pure $ Types.isRemote $ Types.spanContext i-spanIsRemote (FrozenSpan c) = pure $ Types.isRemote c-spanIsRemote (Dropped _) = pure False---- | Really only intended for tests, this function does not conform--- 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"--wrapSpanContext :: SpanContext -> Span-wrapSpanContext = FrozenSpan---- | This can be useful for pulling data for attributes and--- using it to copy / otherwise use the data to further enrich--- instrumentation.-spanGetAttributes :: MonadIO m => Span -> m A.Attributes-spanGetAttributes = \case- Span ref -> do- s <- liftIO $ readIORef ref- pure $ spanAttributes s- FrozenSpan _ -> pure A.emptyAttributes- Dropped _ -> pure A.emptyAttributes---- | Sometimes, you may have a more accurate notion of when a traced--- operation has ended. In this case you may call 'getTimestamp', and then--- supply 'endSpan' with the more accurate timestamp you have acquired.------ When using the monadic interface, (such as 'OpenTelemetry.Trace.Monad.inSpan', you may call--- 'endSpan' early to record the information, and the first call to 'endSpan' will be honored.------ @since 0.0.1.0-getTimestamp :: MonadIO m => m Timestamp-getTimestamp = liftIO $ coerce @(IO TimeSpec) @(IO Timestamp) $ getTime Realtime--limitBy ::- Tracer- -> (SpanLimits -> Maybe Int)- -- ^ Attribute count- -> AttributeLimits-limitBy t countF = AttributeLimits- { attributeCountLimit = countLimit- , attributeLengthLimit = lengthLimit- }- where- countLimit =- countF (tracerProviderSpanLimits $ tracerProvider t) <|>- attributeCountLimit- (tracerProviderAttributeLimits $ tracerProvider t)- lengthLimit =- spanAttributeValueLengthLimit (tracerProviderSpanLimits $ tracerProvider t) <|>- attributeLengthLimit- (tracerProviderAttributeLimits $ tracerProvider t)--globalTracer :: IORef TracerProvider-globalTracer = unsafePerformIO $ do- p <- createTracerProvider- []- emptyTracerProviderOptions- newIORef p-{-# NOINLINE globalTracer #-}--data TracerProviderOptions = TracerProviderOptions- { tracerProviderOptionsIdGenerator :: IdGenerator- , tracerProviderOptionsSampler :: Sampler- , tracerProviderOptionsResources :: MaterializedResources- , tracerProviderOptionsAttributeLimits :: AttributeLimits- , tracerProviderOptionsSpanLimits :: SpanLimits- , tracerProviderOptionsPropagators :: Propagator Context RequestHeaders ResponseHeaders- , tracerProviderOptionsLogger :: Log Text -> IO ()- }---- | Options for creating a 'TracerProvider' with invalid ids, no resources, default limits, and no propagators.------ In effect, tracing is a no-op when using this configuration.------ @since 0.0.1.0-emptyTracerProviderOptions :: TracerProviderOptions-emptyTracerProviderOptions = TracerProviderOptions- dummyIdGenerator- (parentBased $ parentBasedOptions alwaysOn)- emptyMaterializedResources- defaultAttributeLimits- defaultSpanLimits- mempty- (\_ -> pure ())---- | Initialize a new tracer provider------ You should generally use 'getGlobalTracerProvider' for most applications.-createTracerProvider :: MonadIO m => [Processor] -> TracerProviderOptions -> m TracerProvider-createTracerProvider ps opts = liftIO $ do- let g = tracerProviderOptionsIdGenerator opts- pure $ TracerProvider- (V.fromList ps)- g- (tracerProviderOptionsSampler opts)- (tracerProviderOptionsResources opts)- (tracerProviderOptionsAttributeLimits opts)- (tracerProviderOptionsSpanLimits opts)- (tracerProviderOptionsPropagators opts)- (tracerProviderOptionsLogger opts)---- | Access the globally configured 'TracerProvider'. Once the --- the global tracer provider is initialized via the OpenTelemetry SDK,--- 'Tracer's created from this 'TracerProvider' will export spans to their--- configured exporters. Prior to that, any 'Tracer's acquired from the--- uninitialized 'TracerProvider' will create no-op spans.------ @since 0.0.1.0-getGlobalTracerProvider :: MonadIO m => m TracerProvider-getGlobalTracerProvider = liftIO $ readIORef globalTracer---- | Overwrite the globally configured 'TracerProvider'.------ 'Tracer's acquired from the previously installed 'TracerProvider'--- will continue to use that 'TracerProvider's configured span processors,--- exporters, and other settings.------ @since 0.0.1.0-setGlobalTracerProvider :: MonadIO m => TracerProvider -> m ()-setGlobalTracerProvider = liftIO . writeIORef globalTracer--getTracerProviderResources :: TracerProvider -> MaterializedResources-getTracerProviderResources = tracerProviderResources--getTracerProviderPropagators :: TracerProvider -> Propagator Context RequestHeaders ResponseHeaders-getTracerProviderPropagators = tracerProviderPropagators---- | Tracer configuration options.-newtype TracerOptions = TracerOptions- { tracerSchema :: Maybe Text- -- ^ OpenTelemetry provides a schema for describing common attributes so that backends can easily parse and identify relevant information. - -- It is important to understand these conventions when writing instrumentation, in order to normalize your data and increase its utility.- --- -- In particular, this option is valuable to set when possible, because it allows vendors to normalize data accross releases in order to account- -- for attribute name changes.- }---- | Default Tracer options-tracerOptions :: TracerOptions-tracerOptions = TracerOptions Nothing---- | A small utility lens for extracting a 'Tracer' from a larger data type------ This will generally be most useful as a means of implementing 'OpenTelemetry.Trace.Monad.getTracer'------ @since 0.0.1.0-class HasTracer s where- tracerL :: Lens' s Tracer--makeTracer :: TracerProvider -> InstrumentationLibrary -> TracerOptions -> Tracer-makeTracer tp n TracerOptions{} = Tracer n tp--getTracer :: MonadIO m => TracerProvider -> InstrumentationLibrary -> TracerOptions -> m Tracer-getTracer tp n TracerOptions{} = liftIO $ do- pure $ Tracer n tp-{-# DEPRECATED getTracer "use makeTracer" #-}--getImmutableSpanTracer :: ImmutableSpan -> Tracer-getImmutableSpanTracer = spanTracer--getTracerTracerProvider :: Tracer -> TracerProvider-getTracerTracerProvider = tracerProvider---- | Smart constructor for 'SpanArguments' providing reasonable values for most 'Span's created--- that are internal to an application.------ Defaults:------ - `kind`: `Internal`--- - `attributes`: @[]@--- - `links`: @[]@--- - `startTime`: `Nothing` (`getTimestamp` will be called upon `Span` creation)-defaultSpanArguments :: SpanArguments-defaultSpanArguments = SpanArguments- { kind = Internal- , attributes = []- , links = []- , startTime = Nothing- }---- | This method provides a way for provider to do any cleanup required.------ This will also trigger shutdowns on all internal processors.------ @since 0.0.1.0-shutdownTracerProvider :: MonadIO m => TracerProvider -> m ()-shutdownTracerProvider TracerProvider{..} = liftIO $ do- asyncShutdownResults <- forM tracerProviderProcessors $ \processor -> do- processorShutdown processor- mapM_ wait asyncShutdownResults---- | 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- -> 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- mresult <- timeout (fromMaybe 5_000_000 mtimeout) $- foldM- (\status action -> do- res <- waitCatch action- pure $! case res of- Left _err -> FlushError- Right _ok -> status- )- FlushSuccess- jobs- case mresult of- Nothing -> pure FlushTimeout- Just res -> pure res---- | Utility function to only perform costly attribute annotations--- for spans that are actually -whenSpanIsRecording :: MonadIO m => Span -> m () -> m ()-whenSpanIsRecording (Span ref) m = do- span_ <- liftIO $ readIORef ref- case spanEnd span_ of- Nothing -> m- Just _ -> pure ()-whenSpanIsRecording (FrozenSpan _) _ = pure ()-whenSpanIsRecording (Dropped _) _ = pure ()--timestampNanoseconds :: Timestamp -> Word64-timestampNanoseconds (Timestamp TimeSpec{..}) = fromIntegral (sec * 1_000_000_000) + fromIntegral nsec+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++-----------------------------------------------------------------------------++-----------------------------------------------------------------------------++{- |+ Module : OpenTelemetry.Trace.Core+ Copyright : (c) Ian Duncan, 2021+ License : BSD-3+ Description : Low-level tracing API+ Maintainer : Ian Duncan+ Stability : experimental+ Portability : non-portable (GHC extensions)++ Traces track the progression of a single request, called a trace, as it is handled by services that make up an application. The request may be initiated by a user or an application. Distributed tracing is a form of tracing that traverses process, network and security boundaries. Each unit of work in a trace is called a span; a trace is a tree of spans. Spans are objects that represent the work being done by individual services or components involved in a request as it flows through a system. A span contains a span context, which is a set of globally unique identifiers that represent the unique request that each span is a part of. A span provides Request, Error and Duration (RED) metrics that can be used to debug availability as well as performance issues.++ A trace contains a single root span which encapsulates the end-to-end latency for the entire request. You can think of this as a single logical operation, such as clicking a button in a web application to add a product to a shopping cart. The root span would measure the time it took from an end-user clicking that button to the operation being completed or failing (so, the item is added to the cart or some error occurs) and the result being displayed to the user. A trace is comprised of the single root span and any number of child spans, which represent operations taking place as part of the request. Each span contains metadata about the operation, such as its name, start and end timestamps, attributes, events, and status.++ To create and manage 'Span's in OpenTelemetry, the <https://hackage.haskell.org/package/hs-opentelemetry-api OpenTelemetry API> provides the tracer interface. This object is responsible for tracking the active span in your process, and allows you to access the current span in order to perform operations on it such as adding attributes, events, and finishing it when the work it tracks is complete. One or more tracer objects can be created in a process through the tracer provider, a factory interface that allows for multiple 'Tracer's to be instantiated in a single process with different options.++ Generally, the lifecycle of a span resembles the following:++ A request is received by a service. The span context is extracted from the request headers, if it exists.+ A new span is created as a child of the extracted span context; if none exists, a new root span is created.+ The service handles the request. Additional attributes and events are added to the span that are useful for understanding the context of the request, such as the hostname of the machine handling the request, or customer identifiers.+ New spans may be created to represent work being done by sub-components of the service.+ When the service makes a remote call to another service, the current span context is serialized and forwarded to the next service by injecting the span context into the headers or message envelope.+ The work being done by the service completes, successfully or not. The span status is appropriately set, and the span is marked finished.+ For more information, see the traces specification, which covers concepts including: trace, span, parent/child relationship, span context, attributes, events and links.+++ This module implements eveything required to conform to the trace & span public interface described+ by the OpenTelemetry specification.++ See OpenTelemetry.Trace.Monad for an implementation that's+ generally easier to use in idiomatic Haskell.+-}+module OpenTelemetry.Trace.Core (+ -- * @TracerProvider@ operations+ TracerProvider,+ createTracerProvider,+ shutdownTracerProvider,+ forceFlushTracerProvider,+ getTracerProviderResources,+ getTracerProviderPropagators,+ getGlobalTracerProvider,+ setGlobalTracerProvider,+ emptyTracerProviderOptions,+ TracerProviderOptions (..),++ -- * @Tracer@ operations+ Tracer,+ tracerName,+ HasTracer (..),+ makeTracer,+ getTracer,+ getImmutableSpanTracer,+ getTracerTracerProvider,+ InstrumentationLibrary (..),+ TracerOptions (..),+ tracerOptions,++ -- * Span operations+ Span,+ ImmutableSpan (..),+ SpanContext (..),+ -- | W3c Trace flags+ --+ -- https://www.w3.org/TR/trace-context/#trace-flags+ TraceFlags,+ traceFlagsValue,+ traceFlagsFromWord8,+ defaultTraceFlags,+ isSampled,+ setSampled,+ unsetSampled,++ -- ** Creating @Span@s+ inSpan,+ inSpan',+ inSpan'',+ createSpan,+ createSpanWithoutCallStack,+ wrapSpanContext,+ SpanKind (..),+ defaultSpanArguments,+ SpanArguments (..),+ NewLink (..),+ Link (..),++ -- ** Recording @Event@s+ Event (..),+ NewEvent (..),+ addEvent,++ -- ** Enriching @Span@s with additional information+ updateName,+ OpenTelemetry.Trace.Core.addAttribute,+ OpenTelemetry.Trace.Core.addAttributes,+ spanGetAttributes,+ Attribute (..),+ ToAttribute (..),+ PrimitiveAttribute (..),+ ToPrimitiveAttribute (..),++ -- ** Recording error information+ recordException,+ setStatus,+ SpanStatus (..),++ -- ** Completing @Span@s+ endSpan,++ -- ** Accessing other @Span@ information+ getSpanContext,+ isRecording,+ isValid,+ spanIsRemote,++ -- * Utilities+ Timestamp,+ getTimestamp,+ timestampNanoseconds,+ unsafeReadSpan,+ whenSpanIsRecording,++ -- * Limits+ SpanLimits (..),+ defaultSpanLimits,+ bracketError,+) where++import Control.Applicative+import Control.Concurrent (myThreadId)+import Control.Concurrent.Async+import Control.Exception (Exception (..), SomeException (..), try)+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift+import Data.Coerce+import Data.IORef+import Data.Maybe (fromMaybe, isJust, isNothing)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Typeable+import qualified Data.Vector as V+import Data.Word (Word64)+import GHC.Stack+import Network.HTTP.Types+import OpenTelemetry.Attributes+import qualified OpenTelemetry.Attributes as A+import OpenTelemetry.Common+import OpenTelemetry.Context+import OpenTelemetry.Context.ThreadLocal+import OpenTelemetry.Internal.Trace.Types+import qualified OpenTelemetry.Internal.Trace.Types as Types+import OpenTelemetry.Logging.Core (Log)+import OpenTelemetry.Propagator (Propagator)+import OpenTelemetry.Resource+import OpenTelemetry.Trace.Id+import OpenTelemetry.Trace.Id.Generator+import OpenTelemetry.Trace.Id.Generator.Dummy+import OpenTelemetry.Trace.Sampler+import qualified OpenTelemetry.Trace.TraceState as TraceState+import OpenTelemetry.Util+import System.Clock+import System.IO.Unsafe+import System.Timeout (timeout)+++{- | Create a 'Span'.++ If the provided 'Context' has a span in it (inserted via 'OpenTelemetry.Context.insertSpan'),+ that 'Span' will be used as the parent of the 'Span' created via this API.++ Note: if the @hs-opentelemetry-sdk@ or another SDK is not installed, all actions that use the created+ 'Span's produced will be no-ops.++ @since 0.0.1.0+-}+createSpan ::+ (MonadIO m, HasCallStack) =>+ -- | '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,+ -- 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+ }+++-- | 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+ -- used for the lifecycle of the created 'Span'+ Tracer ->+ -- | 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+createSpanWithoutCallStack t ctxt n args@SpanArguments {..} = liftIO $ do+ sId <- newSpanId $ tracerProviderIdGenerator $ tracerProvider t+ let parent = lookupSpan ctxt+ tId <- case parent of+ Nothing -> newTraceId $ tracerProviderIdGenerator $ tracerProvider t+ Just (Span s) ->+ traceId . Types.spanContext <$> readIORef s+ Just (FrozenSpan s) -> pure $ traceId s+ Just (Dropped s) -> pure $ traceId s++ if null $ tracerProviderProcessors $ tracerProvider t+ then pure $ Dropped $ SpanContext defaultTraceFlags False tId sId TraceState.empty+ else do+ (samplingOutcome, attrs, samplingTraceState) <- case parent of+ -- TODO, this seems logically like what we'd do here+ Just (Dropped _) -> pure (Drop, [], TraceState.empty)+ _ ->+ shouldSample+ (tracerProviderSampler $ tracerProvider t)+ ctxt+ tId+ n+ args++ -- TODO properly populate+ let ctxtForSpan =+ SpanContext+ { traceFlags = case samplingOutcome of+ Drop -> defaultTraceFlags+ RecordOnly -> defaultTraceFlags+ RecordAndSample -> setSampled defaultTraceFlags+ , isRemote = False+ , traceState = samplingTraceState+ , spanId = sId+ , traceId = tId+ }++ mkRecordingSpan = do+ st <- maybe getTimestamp pure startTime+ tid <- myThreadId+ let additionalInfo = [("thread.id", toAttribute $ getThreadId tid)]+ is =+ ImmutableSpan+ { spanName = n+ , spanContext = ctxtForSpan+ , spanParent = parent+ , spanKind = kind+ , spanAttributes =+ A.addAttributes+ (limitBy t spanAttributeCountLimit)+ emptyAttributes+ (concat [additionalInfo, attrs, attributes])+ , spanLinks =+ let limitedLinks = fromMaybe 128 (linkCountLimit $ tracerProviderSpanLimits $ tracerProvider t)+ in frozenBoundedCollection limitedLinks $ fmap freezeLink links+ , spanEvents = emptyAppendOnlyBoundedCollection $ fromMaybe 128 (eventCountLimit $ tracerProviderSpanLimits $ tracerProvider t)+ , spanStatus = Unset+ , spanStart = st+ , spanEnd = Nothing+ , spanTracer = t+ }+ s <- newIORef is+ eResult <- try $ mapM_ (\processor -> processorOnStart processor s ctxt) $ tracerProviderProcessors $ tracerProvider t+ case eResult of+ Left err -> print (err :: SomeException)+ Right _ -> pure ()+ pure $ Span s++ case samplingOutcome of+ Drop -> pure $ Dropped ctxtForSpan+ RecordOnly -> mkRecordingSpan+ RecordAndSample -> mkRecordingSpan+ where+ freezeLink :: NewLink -> Link+ freezeLink NewLink {..} =+ Link+ { frozenLinkContext = linkContext+ , frozenLinkAttributes = A.addAttributes (limitBy t linkAttributeCountLimit) A.emptyAttributes linkAttributes+ }+++{- | 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',+ -- span links, starting attributes, etc.+ SpanArguments ->+ -- | 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)+++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 ->+ -- | 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+ 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+ endSpan s Nothing+ adjustContext $ \ctx ->+ maybe (removeSpan ctx) (`insertSpan` ctx) parent+ )+ (\(_, s) -> f s)+++{- | Returns whether the the @Span@ is currently recording. If a span+ is dropped, this will always return False. If a span is from an+ external process, this will return True, and if the span was+ created by this process, the span will return True until endSpan+ is called.+-}+isRecording :: MonadIO m => Span -> m Bool+isRecording (Span s) = liftIO (isNothing . spanEnd <$> readIORef s)+isRecording (FrozenSpan _) = pure True+isRecording (Dropped _) = pure False+++{- | Add an attribute to a span. Only has a useful effect on recording spans.++As an application developer when you need to record an attribute first consult existing semantic conventions for Resources, Spans, and Metrics. If an appropriate name does not exists you will need to come up with a new name. To do that consider a few options:++The name is specific to your company and may be possibly used outside the company as well. To avoid clashes with names introduced by other companies (in a distributed system that uses applications from multiple vendors) it is recommended to prefix the new name by your company’s reverse domain name, e.g. 'com.acme.shopname'.++The name is specific to your application that will be used internally only. If you already have an internal company process that helps you to ensure no name clashes happen then feel free to follow it. Otherwise it is recommended to prefix the attribute name by your application name, provided that the application name is reasonably unique within your organization (e.g. 'myuniquemapapp.longitude' is likely fine). Make sure the application name does not clash with an existing semantic convention namespace.++The name may be generally applicable to applications in the industry. In that case consider submitting a proposal to this specification to add a new name to the semantic conventions, and if necessary also to add a new namespace.++It is recommended to limit names to printable Basic Latin characters (more precisely to 'U+0021' .. 'U+007E' subset of Unicode code points), although the Haskell OpenTelemetry specification DOES provide full Unicode support.++Attribute names that start with 'otel.' are reserved to be defined by OpenTelemetry specification. These are typically used to express OpenTelemetry concepts in formats that don’t have a corresponding concept.++For example, the 'otel.library.name' attribute is used to record the instrumentation library name, which is an OpenTelemetry concept that is natively represented in OTLP, but does not have an equivalent in other telemetry formats and protocols.++Any additions to the 'otel.*' namespace MUST be approved as part of OpenTelemetry specification.++@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 (Span s) k v = liftIO $ modifyIORef' s $ \(!i) ->+ i+ { spanAttributes =+ OpenTelemetry.Attributes.addAttribute+ (limitBy (spanTracer i) spanAttributeCountLimit)+ (spanAttributes i)+ k+ v+ }+addAttribute (FrozenSpan _) _ _ = pure ()+addAttribute (Dropped _) _ _ = pure ()+++{- | A convenience function related to 'addAttribute' that adds multiple attributes to a span at the same time.++ This function may be slightly more performant than repeatedly calling 'addAttribute'.++ @since 0.0.1.0+-}+addAttributes :: MonadIO m => Span -> [(Text, A.Attribute)] -> m ()+addAttributes (Span s) attrs = liftIO $ modifyIORef' s $ \(!i) ->+ i+ { spanAttributes =+ OpenTelemetry.Attributes.addAttributes+ (limitBy (spanTracer i) spanAttributeCountLimit)+ (spanAttributes i)+ attrs+ }+addAttributes (FrozenSpan _) _ = pure ()+addAttributes (Dropped _) _ = pure ()+++{- | Add an event to a recording span. Events will not be recorded for remote spans and dropped spans.++ @since 0.0.1.0+-}+addEvent :: MonadIO m => Span -> NewEvent -> m ()+addEvent (Span s) NewEvent {..} = liftIO $ do+ t <- maybe getTimestamp pure newEventTimestamp+ modifyIORef' s $ \(!i) ->+ i+ { spanEvents =+ appendToBoundedCollection (spanEvents i) $+ Event+ { eventName = newEventName+ , eventAttributes =+ A.addAttributes+ (limitBy (spanTracer i) eventAttributeCountLimit)+ emptyAttributes+ newEventAttributes+ , eventTimestamp = t+ }+ }+addEvent (FrozenSpan _) _ = pure ()+addEvent (Dropped _) _ = pure ()+++{- | Sets the Status of the Span. If used, this will override the default @Span@ status, which is @Unset@.++ These values form a total order: Ok > Error > Unset. This means that setting Status with StatusCode=Ok will override any prior or future attempts to set span Status with StatusCode=Error or StatusCode=Unset.++ @since 0.0.1.0+-}+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+ }+setStatus (FrozenSpan _) _ = pure ()+setStatus (Dropped _) _ = pure ()+++{- |+Updates the Span name. Upon this update, any sampling behavior based on Span name will depend on the implementation.++Note that @Sampler@s can only consider information already present during span creation. Any changes done later, including updated span name, cannot change their decisions.++Alternatives for the name update may be late Span creation, when Span is started with the explicit timestamp from the past at the moment where the final Span name is known, or reporting a Span with the desired name as a child Span.++@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 (Span s) n = liftIO $ modifyIORef' s $ \(!i) -> i {spanName = n}+updateName (FrozenSpan _) _ = pure ()+updateName (Dropped _) _ = pure ()+++{- |+Signals that the operation described by this span has now (or at the time optionally specified) ended.++This does have any effects on child spans. Those may still be running and can be ended later.++This also does not inactivate the Span in any Context it is active in. It is still possible to use an ended span as+parent via a Context it is contained in. Also, putting the Span into a Context will still work after the Span was ended.++@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 (Span s) mts = liftIO $ do+ ts <- maybe getTimestamp pure mts+ (alreadyFinished, frozenS) <- atomicModifyIORef' s $ \(!i) ->+ let ref = i {spanEnd = spanEnd i <|> Just ts}+ in (ref, (isJust $ spanEnd i, ref))+ unless alreadyFinished $ do+ eResult <- try $ mapM_ (`processorOnEnd` s) $ tracerProviderProcessors $ tracerProvider $ spanTracer frozenS+ case eResult of+ Left err -> print (err :: SomeException)+ Right _ -> pure ()+endSpan (FrozenSpan _) _ = pure ()+endSpan (Dropped _) _ = pure ()+++{- | A specialized variant of @addEvent@ that records attributes conforming to+ the OpenTelemetry specification's+ <https://github.com/open-telemetry/opentelemetry-specification/blob/49c2f56f3c0468ceb2b69518bcadadd96e0a5a8b/specification/trace/semantic_conventions/exceptions.md semantic conventions>++ @since 0.0.1.0+-}+recordException :: (MonadIO m, Exception e) => Span -> [(Text, Attribute)] -> Maybe Timestamp -> e -> m ()+recordException s attrs ts e = liftIO $ do+ cs <- whoCreated e+ let message = T.pack $ show e+ addEvent s $+ 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)+ ]+ , newEventTimestamp = ts+ }+++-- | Returns @True@ if the @SpanContext@ has a non-zero @TraceID@ and a non-zero @SpanID@+isValid :: SpanContext -> Bool+isValid sc =+ not+ (isEmptyTraceId (traceId sc) && isEmptySpanId (spanId sc))+++{- |+Returns @True@ if the @SpanContext@ was propagated from a remote parent,++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 (Span s) = liftIO $ do+ i <- readIORef s+ pure $ Types.isRemote $ Types.spanContext i+spanIsRemote (FrozenSpan c) = pure $ Types.isRemote c+spanIsRemote (Dropped _) = pure False+++{- | Really only intended for tests, this function does not conform+ 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"+++wrapSpanContext :: SpanContext -> Span+wrapSpanContext = FrozenSpan+++{- | This can be useful for pulling data for attributes and+ using it to copy / otherwise use the data to further enrich+ instrumentation.+-}+spanGetAttributes :: MonadIO m => Span -> m A.Attributes+spanGetAttributes = \case+ Span ref -> do+ s <- liftIO $ readIORef ref+ pure $ spanAttributes s+ FrozenSpan _ -> pure A.emptyAttributes+ Dropped _ -> pure A.emptyAttributes+++{- | Sometimes, you may have a more accurate notion of when a traced+ operation has ended. In this case you may call 'getTimestamp', and then+ supply 'endSpan' with the more accurate timestamp you have acquired.++ When using the monadic interface, (such as 'OpenTelemetry.Trace.Monad.inSpan', you may call+ 'endSpan' early to record the information, and the first call to 'endSpan' will be honored.++ @since 0.0.1.0+-}+getTimestamp :: MonadIO m => m Timestamp+getTimestamp = liftIO $ coerce @(IO TimeSpec) @(IO Timestamp) $ getTime Realtime+++limitBy ::+ Tracer ->+ -- | Attribute count+ (SpanLimits -> Maybe Int) ->+ AttributeLimits+limitBy t countF =+ AttributeLimits+ { attributeCountLimit = countLimit+ , attributeLengthLimit = lengthLimit+ }+ where+ countLimit =+ countF (tracerProviderSpanLimits $ tracerProvider t)+ <|> attributeCountLimit+ (tracerProviderAttributeLimits $ tracerProvider t)+ lengthLimit =+ spanAttributeValueLengthLimit (tracerProviderSpanLimits $ tracerProvider t)+ <|> attributeLengthLimit+ (tracerProviderAttributeLimits $ tracerProvider t)+++globalTracer :: IORef TracerProvider+globalTracer = unsafePerformIO $ do+ p <-+ createTracerProvider+ []+ emptyTracerProviderOptions+ newIORef p+{-# NOINLINE globalTracer #-}+++data TracerProviderOptions = TracerProviderOptions+ { tracerProviderOptionsIdGenerator :: IdGenerator+ , tracerProviderOptionsSampler :: Sampler+ , tracerProviderOptionsResources :: MaterializedResources+ , tracerProviderOptionsAttributeLimits :: AttributeLimits+ , tracerProviderOptionsSpanLimits :: SpanLimits+ , tracerProviderOptionsPropagators :: Propagator Context RequestHeaders ResponseHeaders+ , tracerProviderOptionsLogger :: Log Text -> IO ()+ }+++{- | Options for creating a 'TracerProvider' with invalid ids, no resources, default limits, and no propagators.++ In effect, tracing is a no-op when using this configuration.++ @since 0.0.1.0+-}+emptyTracerProviderOptions :: TracerProviderOptions+emptyTracerProviderOptions =+ TracerProviderOptions+ dummyIdGenerator+ (parentBased $ parentBasedOptions alwaysOn)+ emptyMaterializedResources+ defaultAttributeLimits+ defaultSpanLimits+ mempty+ (\_ -> pure ())+++{- | Initialize a new tracer provider++ You should generally use 'getGlobalTracerProvider' for most applications.+-}+createTracerProvider :: MonadIO m => [Processor] -> TracerProviderOptions -> m TracerProvider+createTracerProvider ps opts = liftIO $ do+ let g = tracerProviderOptionsIdGenerator opts+ pure $+ TracerProvider+ (V.fromList ps)+ g+ (tracerProviderOptionsSampler opts)+ (tracerProviderOptionsResources opts)+ (tracerProviderOptionsAttributeLimits opts)+ (tracerProviderOptionsSpanLimits opts)+ (tracerProviderOptionsPropagators opts)+ (tracerProviderOptionsLogger opts)+++{- | Access the globally configured 'TracerProvider'. Once the+ the global tracer provider is initialized via the OpenTelemetry SDK,+ 'Tracer's created from this 'TracerProvider' will export spans to their+ configured exporters. Prior to that, any 'Tracer's acquired from the+ uninitialized 'TracerProvider' will create no-op spans.++ @since 0.0.1.0+-}+getGlobalTracerProvider :: MonadIO m => m TracerProvider+getGlobalTracerProvider = liftIO $ readIORef globalTracer+++{- | Overwrite the globally configured 'TracerProvider'.++ 'Tracer's acquired from the previously installed 'TracerProvider'+ will continue to use that 'TracerProvider's configured span processors,+ exporters, and other settings.++ @since 0.0.1.0+-}+setGlobalTracerProvider :: MonadIO m => TracerProvider -> m ()+setGlobalTracerProvider = liftIO . writeIORef globalTracer+++getTracerProviderResources :: TracerProvider -> MaterializedResources+getTracerProviderResources = tracerProviderResources+++getTracerProviderPropagators :: TracerProvider -> Propagator Context RequestHeaders ResponseHeaders+getTracerProviderPropagators = tracerProviderPropagators+++-- | Tracer configuration options.+newtype TracerOptions = TracerOptions+ { tracerSchema :: Maybe Text+ -- ^ OpenTelemetry provides a schema for describing common attributes so that backends can easily parse and identify relevant information.+ -- It is important to understand these conventions when writing instrumentation, in order to normalize your data and increase its utility.+ --+ -- In particular, this option is valuable to set when possible, because it allows vendors to normalize data accross releases in order to account+ -- for attribute name changes.+ }+++-- | Default Tracer options+tracerOptions :: TracerOptions+tracerOptions = TracerOptions Nothing+++{- | A small utility lens for extracting a 'Tracer' from a larger data type++ This will generally be most useful as a means of implementing 'OpenTelemetry.Trace.Monad.getTracer'++ @since 0.0.1.0+-}+class HasTracer s where+ tracerL :: Lens' s Tracer+++makeTracer :: TracerProvider -> InstrumentationLibrary -> TracerOptions -> Tracer+makeTracer tp n TracerOptions {} = Tracer n tp+++getTracer :: MonadIO m => TracerProvider -> InstrumentationLibrary -> TracerOptions -> m Tracer+getTracer tp n TracerOptions {} = liftIO $ do+ pure $ Tracer n tp+{-# DEPRECATED getTracer "use makeTracer" #-}+++getImmutableSpanTracer :: ImmutableSpan -> Tracer+getImmutableSpanTracer = spanTracer+++getTracerTracerProvider :: Tracer -> TracerProvider+getTracerTracerProvider = tracerProvider+++{- | Smart constructor for 'SpanArguments' providing reasonable values for most 'Span's created+ that are internal to an application.++ Defaults:++ - `kind`: `Internal`+ - `attributes`: @[]@+ - `links`: @[]@+ - `startTime`: `Nothing` (`getTimestamp` will be called upon `Span` creation)+-}+defaultSpanArguments :: SpanArguments+defaultSpanArguments =+ SpanArguments+ { kind = Internal+ , attributes = []+ , links = []+ , startTime = Nothing+ }+++{- | This method provides a way for provider to do any cleanup required.++ This will also trigger shutdowns on all internal processors.++ @since 0.0.1.0+-}+shutdownTracerProvider :: MonadIO m => TracerProvider -> m ()+shutdownTracerProvider TracerProvider {..} = liftIO $ do+ asyncShutdownResults <- forM tracerProviderProcessors $ \processor -> do+ processorShutdown processor+ mapM_ wait asyncShutdownResults+++{- | 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 TracerProvider {..} mtimeout = liftIO $ do+ jobs <- forM tracerProviderProcessors $ \processor -> async $ do+ processorForceFlush processor+ mresult <-+ timeout (fromMaybe 5_000_000 mtimeout) $+ foldM+ ( \status action -> do+ res <- waitCatch action+ pure $! case res of+ Left _err -> FlushError+ Right _ok -> status+ )+ FlushSuccess+ jobs+ case mresult of+ Nothing -> pure FlushTimeout+ Just res -> pure res+++{- | Utility function to only perform costly attribute annotations+ for spans that are actually+-}+whenSpanIsRecording :: MonadIO m => Span -> m () -> m ()+whenSpanIsRecording (Span ref) m = do+ span_ <- liftIO $ readIORef ref+ case spanEnd span_ of+ Nothing -> m+ Just _ -> pure ()+whenSpanIsRecording (FrozenSpan _) _ = pure ()+whenSpanIsRecording (Dropped _) _ = pure ()+++timestampNanoseconds :: Timestamp -> Word64+timestampNanoseconds (Timestamp TimeSpec {..}) = fromIntegral (sec * 1_000_000_000) + fromIntegral nsec
src/OpenTelemetry/Trace/Id.hs view
@@ -1,231 +1,61 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE UnboxedTuples #-} -------------------------------------------------------------------------------- |--- Module : OpenTelemetry.Trace.Id--- Copyright : (c) Ian Duncan, 2021--- License : BSD-3--- Description : Trace and Span ID generation, validation, serialization, and deserialization--- Maintainer : Ian Duncan--- Stability : experimental--- Portability : non-portable (GHC extensions)------ Trace and Span Id generation------ No Aeson instances are provided since they've got the potential to be--- transport-specific in format. Use newtypes for serialisation instead.--------------------------------------------------------------------------------- -module OpenTelemetry.Trace.Id- ( -- * Working with 'TraceId's- TraceId- -- ** Creating 'TraceId's- , newTraceId- -- ** Checking 'TraceId's for validity- , isEmptyTraceId- -- ** Encoding / decoding 'TraceId' from bytes- , traceIdBytes- , bytesToTraceId- -- ** Encoding / decoding 'TraceId' from a given 'Base' encoding- , baseEncodedToTraceId- , traceIdBaseEncodedBuilder- , traceIdBaseEncodedByteString- , traceIdBaseEncodedText- -- * Working with 'SpanId's- , SpanId- -- ** Creating 'SpanId's- , newSpanId- -- ** Checking 'SpanId's for validity- , isEmptySpanId- -- ** Encoding / decoding 'SpanId' from bytes- , spanIdBytes- , bytesToSpanId- -- ** Encoding / decoding 'SpanId' from a given 'Base' encoding- , Base(..)- , baseEncodedToSpanId- , spanIdBaseEncodedBuilder- , spanIdBaseEncodedByteString- , spanIdBaseEncodedText- ) where--import OpenTelemetry.Trace.Id.Generator-import Control.Monad.IO.Class-import Data.ByteArray.Encoding-import Data.ByteString (ByteString)-import qualified Data.ByteString as BS-import Data.ByteString.Builder (Builder)-import qualified Data.ByteString.Builder as B-import Data.Hashable (Hashable)-import Data.Text (Text)-import Data.Text.Encoding (decodeUtf8)--import Data.ByteString.Short.Internal-import GHC.Exts-import GHC.ST-import Prelude hiding (length)---- TODO faster encoding decoding via something like--- https://github.com/lemire/Code-used-on-Daniel-Lemire-s-blog/blob/03fc2e82fdef2c6fd25721203e1654428fee123d/2019/04/17/hexparse.cpp#L390---- | A valid trace identifier is a 16-byte array with at least one non-zero byte.-newtype TraceId = TraceId ShortByteString- deriving stock (Ord, Eq)- deriving newtype (Hashable)---- | A valid span identifier is an 8-byte array with at least one non-zero byte.-newtype SpanId = SpanId ShortByteString- deriving stock (Ord, Eq)- deriving newtype (Hashable)--instance Show TraceId where- show = show . traceIdBaseEncodedText Base16--instance IsString TraceId where- fromString str = case baseEncodedToTraceId Base16 (fromString str) of- Left err -> error err- Right ok -> ok--instance Show SpanId where- show = show . spanIdBaseEncodedText Base16--instance IsString SpanId where- fromString str = case baseEncodedToSpanId Base16 (fromString str) of- Left err -> error err- Right ok -> ok---- | Generate a 'TraceId' using the provided 'IdGenerator'------ This function is generally called by the @hs-opentelemetry-sdk@,--- but may be useful in some testing situations.------ @since 0.1.0.0-newTraceId :: MonadIO m => IdGenerator -> m TraceId-newTraceId gen = liftIO (TraceId . toShort <$> generateTraceIdBytes gen)---- | Check whether all bytes in the 'TraceId' are zero.------ @since 0.1.0.0-isEmptyTraceId :: TraceId -> Bool-isEmptyTraceId (TraceId (SBS arr)) =- isTrue#- (eqWord#- (or#-#if MIN_VERSION_base(4,17,0)- (word64ToWord# (indexWord64Array# arr 0#))- (word64ToWord# (indexWord64Array# arr 1#)))-#else- (indexWord64Array# arr 0#)- (indexWord64Array# arr 1#))-#endif- (int2Word# 0#))+----------------------------------------------------------------------------- --- | Access the byte-level representation of the provided 'TraceId'------ @since 0.1.0.0-traceIdBytes :: TraceId -> ByteString-traceIdBytes (TraceId bytes) = fromShort bytes+{- |+ Module : OpenTelemetry.Trace.Id+ Copyright : (c) Ian Duncan, 2021+ License : BSD-3+ Description : Trace and Span ID generation, validation, serialization, and deserialization+ Maintainer : Ian Duncan+ Stability : experimental+ Portability : non-portable (GHC extensions) --- | Convert a 'ByteString' to a 'TraceId'. Will fail if the 'ByteString'--- is not exactly 16 bytes long.------ @since 0.1.0.0-bytesToTraceId :: ByteString -> Either String TraceId-bytesToTraceId bs = if BS.length bs == 16- then Right $ TraceId $ toShort bs- else Left "bytesToTraceId: TraceId must be 8 bytes long"+ Trace and Span Id generation --- | Convert a 'ByteString' of a specified base-encoding into a 'TraceId'.--- Will fail if the decoded value is not exactly 16 bytes long.------ @since 0.1.0.0-baseEncodedToTraceId :: Base -> ByteString -> Either String TraceId-baseEncodedToTraceId b bs = do- r <- convertFromBase b bs- bytesToTraceId r+ No Aeson instances are provided since they've got the potential to be+ transport-specific in format. Use newtypes for serialisation instead.+-}+module OpenTelemetry.Trace.Id (+ -- * Working with 'TraceId's+ TraceId, --- | Output a 'TraceId' into a base-encoded bytestring 'Builder'.------ @since 0.1.0.0-traceIdBaseEncodedBuilder :: Base -> TraceId -> Builder-traceIdBaseEncodedBuilder b = B.byteString . convertToBase b . traceIdBytes+ -- ** Creating 'TraceId's+ newTraceId, --- | Output a 'TraceId' into a base-encoded 'ByteString'.------ @since 0.1.0.0-traceIdBaseEncodedByteString :: Base -> TraceId -> ByteString-traceIdBaseEncodedByteString b = convertToBase b . traceIdBytes+ -- ** Checking 'TraceId's for validity+ isEmptyTraceId, --- | Output a 'TraceId' into a base-encoded 'Text'.------ @since 0.1.0.0-traceIdBaseEncodedText :: Base -> TraceId -> Text-traceIdBaseEncodedText b = decodeUtf8 . traceIdBaseEncodedByteString b+ -- ** Encoding / decoding 'TraceId' from bytes+ traceIdBytes,+ bytesToTraceId, --- | Generate a 'SpanId' using the provided 'IdGenerator'------ This function is generally called by the @hs-opentelemetry-sdk@,--- but may be useful in some testing situations.------ @since 0.1.0.0-newSpanId :: MonadIO m => IdGenerator -> m SpanId-newSpanId gen = liftIO (SpanId . toShort <$> generateSpanIdBytes gen)+ -- ** Encoding / decoding 'TraceId' from a given 'Base' encoding+ baseEncodedToTraceId,+ traceIdBaseEncodedBuilder,+ traceIdBaseEncodedByteString,+ traceIdBaseEncodedText, --- | Check whether all bytes in the 'SpanId' are zero.------ @since 0.1.0.0-isEmptySpanId :: SpanId -> Bool-isEmptySpanId (SpanId (SBS arr)) = isTrue#- (eqWord#-#if MIN_VERSION_base(4,17,0)- (word64ToWord# (indexWord64Array# arr 0#))-#else- (indexWord64Array# arr 0#)-#endif- (int2Word# 0#))+ -- * Working with 'SpanId's+ SpanId, --- | Access the byte-level representation of the provided 'SpanId'------ @since 0.1.0.0-spanIdBytes :: SpanId -> ByteString-spanIdBytes (SpanId bytes) = fromShort bytes+ -- ** Creating 'SpanId's+ newSpanId, --- | Convert a 'ByteString' of a specified base-encoding into a 'SpanId'.--- Will fail if the decoded value is not exactly 8 bytes long.------ @since 0.1.0.0-bytesToSpanId :: ByteString -> Either String SpanId-bytesToSpanId bs = if BS.length bs == 8- then Right $ SpanId $ toShort bs- else Left "bytesToSpanId: SpanId must be 8 bytes long"+ -- ** Checking 'SpanId's for validity+ isEmptySpanId, --- | Convert a 'ByteString' of a specified base-encoding into a 'SpanId'.--- Will fail if the decoded value is not exactly 8 bytes long.------ @since 0.1.0.0-baseEncodedToSpanId :: Base -> ByteString -> Either String SpanId-baseEncodedToSpanId b bs = do- r <- convertFromBase b bs- bytesToSpanId r+ -- ** Encoding / decoding 'SpanId' from bytes+ spanIdBytes,+ bytesToSpanId, --- | Output a 'SpanId' into a base-encoded bytestring 'Builder'.------ @since 0.1.0.0-spanIdBaseEncodedBuilder :: Base -> SpanId -> Builder-spanIdBaseEncodedBuilder b = B.byteString . convertToBase b . spanIdBytes+ -- ** Encoding / decoding 'SpanId' from a given 'Base' encoding+ Base (..),+ baseEncodedToSpanId,+ spanIdBaseEncodedBuilder,+ spanIdBaseEncodedByteString,+ spanIdBaseEncodedText,+) where --- | Output a 'SpanId' into a base-encoded 'ByteString'.------ @since 0.1.0.0-spanIdBaseEncodedByteString :: Base -> SpanId -> ByteString-spanIdBaseEncodedByteString b = convertToBase b . spanIdBytes+import OpenTelemetry.Internal.Trace.Id --- | Output a 'SpanId' into a base-encoded 'Text'.------ @since 0.1.0.0-spanIdBaseEncodedText :: Base -> SpanId -> Text-spanIdBaseEncodedText b = decodeUtf8 . spanIdBaseEncodedByteString b
src/OpenTelemetry/Trace/Id/Generator.hs view
@@ -1,30 +1,35 @@ -------------------------------------------------------------------------------- |--- Module : OpenTelemetry.Id.Generator--- Copyright : (c) Ian Duncan, 2021--- License : BSD-3--- Description : Raw byte generation facilities for ID generation--- Maintainer : Ian Duncan--- Stability : experimental--- Portability : non-portable (GHC extensions)------ Stateful random number generation interface for creating Trace and Span ID--- bytes.------ In most cases, the built-in generator in the hs-opentelemetry-sdk will be sufficient, but the--- interface is exposed for more exotic needs.---+ ------------------------------------------------------------------------------module OpenTelemetry.Trace.Id.Generator - ( IdGenerator(..)- ) where++{- |+ Module : OpenTelemetry.Id.Generator+ Copyright : (c) Ian Duncan, 2021+ License : BSD-3+ Description : Raw byte generation facilities for ID generation+ Maintainer : Ian Duncan+ Stability : experimental+ Portability : non-portable (GHC extensions)++ Stateful random number generation interface for creating Trace and Span ID+ bytes.++ In most cases, the built-in generator in the hs-opentelemetry-sdk will be sufficient, but the+ interface is exposed for more exotic needs.+-}+module OpenTelemetry.Trace.Id.Generator (+ IdGenerator (..),+) where+ import Data.ByteString (ByteString) --- | An interface for generating the underlying bytes for--- trace and span ids.++{- | An interface for generating the underlying bytes for+ trace and span ids.+-} data IdGenerator = IdGenerator { generateSpanIdBytes :: IO ByteString- -- ^ MUST generate exactly 8 bytes+ -- ^ MUST generate exactly 8 bytes , generateTraceIdBytes :: IO ByteString- -- ^ MUST generate exactly 16 bytes+ -- ^ MUST generate exactly 16 bytes }
src/OpenTelemetry/Trace/Id/Generator/Dummy.hs view
@@ -2,9 +2,11 @@ import OpenTelemetry.Trace.Id.Generator + -- | A non-functioning id generator for use when an SDK is not installed dummyIdGenerator :: IdGenerator-dummyIdGenerator = IdGenerator- { generateSpanIdBytes = pure "\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL"- , generateTraceIdBytes = pure "\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL"- }+dummyIdGenerator =+ IdGenerator+ { generateSpanIdBytes = pure "\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL"+ , generateTraceIdBytes = pure "\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL"+ }
src/OpenTelemetry/Trace/Monad.hs view
@@ -1,26 +1,29 @@+{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DefaultSignatures #-}+ -------------------------------------------------------------------------------- |--- Module : OpenTelemetry.Trace.Monad--- Copyright : (c) Ian Duncan, 2021--- License : BSD-3--- Description : Higher-level tracing API--- Maintainer : Ian Duncan--- Stability : experimental--- Portability : non-portable (GHC extensions)------ The recommended tracing interface for application developers------ See OpenTelemetry.Trace for an interface that's--- more lower-level, but more flexible.---+ ------------------------------------------------------------------------------module OpenTelemetry.Trace.Monad- ( inSpan- , inSpan'- , OpenTelemetry.Trace.Monad.inSpan''++{- |+ Module : OpenTelemetry.Trace.Monad+ Copyright : (c) Ian Duncan, 2021+ License : BSD-3+ Description : Higher-level tracing API+ Maintainer : Ian Duncan+ Stability : experimental+ Portability : non-portable (GHC extensions)++ The recommended tracing interface for application developers++ See OpenTelemetry.Trace for an interface that's+ more lower-level, but more flexible.+-}+module OpenTelemetry.Trace.Monad (+ inSpan,+ inSpan',+ OpenTelemetry.Trace.Monad.inSpan'', -- Interacting with the span in the current context -- , getSpan -- , updateName@@ -30,46 +33,61 @@ -- , addEvent -- , NewEvent (..) -- Fundamental monad instances- , MonadTracer(..)- ) where+ MonadTracer (..),+) where -import Data.Text (Text)-import OpenTelemetry.Trace.Core- ( Tracer- , Span- , SpanArguments(..)- , inSpan''- ) import Control.Monad.IO.Unlift+import Control.Monad.Identity (IdentityT)+import Control.Monad.Reader (ReaderT)+import Control.Monad.Trans (MonadTrans (lift))+import Data.Text (Text) import GHC.Stack+import OpenTelemetry.Trace.Core (+ Span,+ SpanArguments (..),+ Tracer,+ inSpan'',+ ) + -- | This is generally scoped by Monad stack to do different things class Monad m => MonadTracer m where getTracer :: m Tracer -inSpan- :: (MonadUnliftIO m, MonadTracer m, HasCallStack)- => Text- -> SpanArguments- -> m a- -> m a++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- -> (Span -> m a)- -> m a++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)- => CallStack- -> Text- -> SpanArguments- -> (Span -> m a)- -> m a++inSpan'' ::+ (MonadUnliftIO m, MonadTracer m, HasCallStack) =>+ CallStack ->+ Text ->+ SpanArguments ->+ (Span -> m a) ->+ m a inSpan'' cs n args f = do t <- getTracer OpenTelemetry.Trace.Core.inSpan'' t cs n args f+++instance MonadTracer m => MonadTracer (IdentityT m) where+ getTracer = lift getTracer+++instance {-# OVERLAPPABLE #-} MonadTracer m => MonadTracer (ReaderT r m) where+ getTracer = lift getTracer
src/OpenTelemetry/Trace/Sampler.hs view
@@ -1,117 +1,133 @@ -------------------------------------------------------------------------------- |--- Module : OpenTelemetry.Trace.Sampler--- Copyright : (c) Ian Duncan, 2021--- License : BSD-3--- Description : Sampling strategies for reducing tracing overhead--- Maintainer : Ian Duncan--- Stability : experimental--- Portability : non-portable (GHC extensions)------ This module provides several built-in sampling strategies, as well as the ability to define custom samplers.------ Sampling is the concept of selecting a few elements from a large collection and learning about the entire collection by extrapolating from the selected set. It’s widely used throughout the world whenever trying to tackle a problem of scale: for example, a survey assumes that by asking a small group of people a set of questions, you can learn something about the opinions of the entire populace.------ While it’s nice to believe that every event is precious, the reality of monitoring high volume production infrastructure is that there are some attributes to events that make them more interesting than the rest. Failures are often more interesting than successes! Rare events are more interesting than common events! Capturing some traffic from all customers can be better than capturing all traffic from some customers.------ Sampling as a basic technique for instrumentation is no different—by recording information about a representative subset of requests flowing through a system, you can learn about the overall performance of the system. And as with surveys and air monitoring, the way you choose your representative set (the sample set) can greatly influence the accuracy of your results.------ Sampling is widespread in observability systems because it lowers the cost of producing, collecting, and analyzing data in systems anywhere cost is a concern. Developers and operators in an observability system apply or attach key=value properties to observability data–spans and metrics–and we use these properties to investigate hypotheses about our systems after the fact. It is interesting to look at how sampling impacts our ability to analyze observability data, using key=value restrictions for some keys and grouping the output based on other keys.------ Sampling schemes let observability systems collect examples of data that are not merely exemplary, but also representative. Sampling schemes compute a set of representative items and, in doing so, score each item with what is commonly called the item's "sampling rate." A sampling rate of 10 indicates that the item represents an estimated 10 individuals in the original data set.+ -----------------------------------------------------------------------------++{- |+ Module : OpenTelemetry.Trace.Sampler+ Copyright : (c) Ian Duncan, 2021+ License : BSD-3+ Description : Sampling strategies for reducing tracing overhead+ Maintainer : Ian Duncan+ Stability : experimental+ Portability : non-portable (GHC extensions)++ This module provides several built-in sampling strategies, as well as the ability to define custom samplers.++ Sampling is the concept of selecting a few elements from a large collection and learning about the entire collection by extrapolating from the selected set. It’s widely used throughout the world whenever trying to tackle a problem of scale: for example, a survey assumes that by asking a small group of people a set of questions, you can learn something about the opinions of the entire populace.++ While it’s nice to believe that every event is precious, the reality of monitoring high volume production infrastructure is that there are some attributes to events that make them more interesting than the rest. Failures are often more interesting than successes! Rare events are more interesting than common events! Capturing some traffic from all customers can be better than capturing all traffic from some customers.++ Sampling as a basic technique for instrumentation is no different—by recording information about a representative subset of requests flowing through a system, you can learn about the overall performance of the system. And as with surveys and air monitoring, the way you choose your representative set (the sample set) can greatly influence the accuracy of your results.++ Sampling is widespread in observability systems because it lowers the cost of producing, collecting, and analyzing data in systems anywhere cost is a concern. Developers and operators in an observability system apply or attach key=value properties to observability data–spans and metrics–and we use these properties to investigate hypotheses about our systems after the fact. It is interesting to look at how sampling impacts our ability to analyze observability data, using key=value restrictions for some keys and grouping the output based on other keys.++ Sampling schemes let observability systems collect examples of data that are not merely exemplary, but also representative. Sampling schemes compute a set of representative items and, in doing so, score each item with what is commonly called the item's "sampling rate." A sampling rate of 10 indicates that the item represents an estimated 10 individuals in the original data set.+-} module OpenTelemetry.Trace.Sampler (- Sampler(..),- SamplingResult(..),+ Sampler (..),+ SamplingResult (..), parentBased, parentBasedOptions,- ParentBasedOptions(..),+ ParentBasedOptions (..), traceIdRatioBased, alwaysOn,- alwaysOff+ alwaysOff, ) where+ import Data.Binary.Get import Data.Bits import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.Text import Data.Word (Word64)-import OpenTelemetry.Trace.Id+import OpenTelemetry.Attributes (toAttribute) import OpenTelemetry.Context import OpenTelemetry.Internal.Trace.Types+import OpenTelemetry.Trace.Id import OpenTelemetry.Trace.TraceState as TraceState-import OpenTelemetry.Attributes (toAttribute) --- | Returns @RecordAndSample@ always.------ Description returns AlwaysOnSampler.------ @since 0.1.0.0++{- | Returns @RecordAndSample@ always.++ Description returns AlwaysOnSampler.++ @since 0.1.0.0+-} alwaysOn :: Sampler-alwaysOn = Sampler- { getDescription = "AlwaysOnSampler"- , shouldSample = \ctxt _ _ _ -> do- mspanCtxt <- sequence (getSpanContext <$> lookupSpan ctxt)- pure (RecordAndSample, [], maybe TraceState.empty traceState mspanCtxt)- }+alwaysOn =+ Sampler+ { getDescription = "AlwaysOnSampler"+ , shouldSample = \ctxt _ _ _ -> do+ mspanCtxt <- sequence (getSpanContext <$> lookupSpan ctxt)+ pure (RecordAndSample, [], maybe TraceState.empty traceState mspanCtxt)+ } --- | Returns @Drop@ always.------ Description returns AlwaysOffSampler.------ @since 0.1.0.0++{- | Returns @Drop@ always.++ Description returns AlwaysOffSampler.++ @since 0.1.0.0+-} alwaysOff :: Sampler-alwaysOff = Sampler- { getDescription = "AlwaysOffSampler"- , shouldSample = \ctxt _ _ _ -> do- mspanCtxt <- sequence (getSpanContext <$> lookupSpan ctxt)- pure (Drop, [], maybe TraceState.empty traceState mspanCtxt)- }+alwaysOff =+ Sampler+ { getDescription = "AlwaysOffSampler"+ , shouldSample = \ctxt _ _ _ -> do+ mspanCtxt <- sequence (getSpanContext <$> lookupSpan ctxt)+ pure (Drop, [], maybe TraceState.empty traceState mspanCtxt)+ } --- | The TraceIdRatioBased ignores the parent SampledFlag. To respect the parent SampledFlag, --- the TraceIdRatioBased should be used as a delegate of the @parentBased@ sampler specified below.--- --- Description returns a string of the form "TraceIdRatioBased{RATIO}" with RATIO replaced with the Sampler --- instance's trace sampling ratio represented as a decimal number.------ @since 0.1.0.0++{- | The TraceIdRatioBased ignores the parent SampledFlag. To respect the parent SampledFlag,+ the TraceIdRatioBased should be used as a delegate of the @parentBased@ sampler specified below.++ Description returns a string of the form "TraceIdRatioBased{RATIO}" with RATIO replaced with the Sampler+ instance's trace sampling ratio represented as a decimal number.++ @since 0.1.0.0+-} traceIdRatioBased :: Double -> Sampler-traceIdRatioBased fraction = if fraction >= 1- then alwaysOn- else sampler+traceIdRatioBased fraction =+ if fraction >= 1+ then alwaysOn+ else sampler where safeFraction = max fraction 0- sampleRate = if safeFraction > 0 - then toAttribute ((round (1 / safeFraction)) :: Int)- else toAttribute (0 :: Int)+ sampleRate =+ if safeFraction > 0+ then toAttribute ((round (1 / safeFraction)) :: Int)+ else toAttribute (0 :: Int) traceIdUpperBound = floor (fraction * fromIntegral ((1 :: Word64) `shiftL` 63)) :: Word64- sampler = Sampler- { getDescription = "TraceIdRatioBased{" <> 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- if x < traceIdUpperBound- then do- pure (RecordAndSample, [("sampleRate", sampleRate)], maybe TraceState.empty traceState mspanCtxt)- else- pure (Drop, [], maybe TraceState.empty traceState mspanCtxt)- }+ sampler =+ Sampler+ { getDescription = "TraceIdRatioBased{" <> 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+ if x < traceIdUpperBound+ then do+ pure (RecordAndSample, [("sampleRate", sampleRate)], maybe TraceState.empty traceState mspanCtxt)+ else pure (Drop, [], maybe TraceState.empty traceState mspanCtxt)+ } --- | This is a composite sampler. ParentBased helps distinguish between the following cases:------ No parent (root span).------ Remote parent (SpanContext.IsRemote() == true) with SampledFlag equals true--- --- Remote parent (SpanContext.IsRemote() == true) with SampledFlag equals false------ Local parent (SpanContext.IsRemote() == false) with SampledFlag equals true------ Local parent (SpanContext.IsRemote() == false) with SampledFlag equals false------ @since 0.1.0.0-data ParentBasedOptions = ParentBasedOptions ++{- | This is a composite sampler. ParentBased helps distinguish between the following cases:++ No parent (root span).++ Remote parent (SpanContext.IsRemote() == true) with SampledFlag equals true++ Remote parent (SpanContext.IsRemote() == true) with SampledFlag equals false++ Local parent (SpanContext.IsRemote() == false) with SampledFlag equals true++ Local parent (SpanContext.IsRemote() == false) with SampledFlag equals false++ @since 0.1.0.0+-}+data ParentBasedOptions = ParentBasedOptions { rootSampler :: Sampler -- ^ Sampler called for spans with no parent (root spans) , remoteParentSampled :: Sampler@@ -124,50 +140,59 @@ -- ^ default: alwaysOff } --- | A smart constructor for 'ParentBasedOptions' with reasonable starting--- defaults.------ @since 0.1.0.0-parentBasedOptions - :: Sampler - -- ^ Root sampler- -> ParentBasedOptions-parentBasedOptions root = ParentBasedOptions- { rootSampler = root- , remoteParentSampled = alwaysOn- , remoteParentNotSampled = alwaysOff- , localParentSampled = alwaysOn- , localParentNotSampled = alwaysOff- } --- | A sampler which behaves differently based on the incoming sampling decision. ------ In general, this will sample spans that have parents that were sampled, and will not sample spans whose parents were not sampled.------ @since 0.1.0.0+{- | A smart constructor for 'ParentBasedOptions' with reasonable starting+ defaults.++ @since 0.1.0.0+-}+parentBasedOptions ::+ -- | Root sampler+ Sampler ->+ ParentBasedOptions+parentBasedOptions root =+ ParentBasedOptions+ { rootSampler = root+ , remoteParentSampled = alwaysOn+ , remoteParentNotSampled = alwaysOff+ , localParentSampled = alwaysOn+ , localParentNotSampled = alwaysOff+ }+++{- | A sampler which behaves differently based on the incoming sampling decision.++ In general, this will sample spans that have parents that were sampled, and will not sample spans whose parents were not sampled.++ @since 0.1.0.0+-} parentBased :: ParentBasedOptions -> Sampler-parentBased ParentBasedOptions{..} = Sampler- { getDescription = - "ParentBased{root=" <> - getDescription rootSampler <>- ", remoteParentSampled=" <>- getDescription remoteParentSampled <>- ", remoteParentNotSampled=" <>- getDescription remoteParentNotSampled <>- ", localParentSampled=" <>- getDescription localParentSampled <>- ", localParentNotSampled=" <>- getDescription localParentNotSampled <>- "}"- , shouldSample = \ctx tid name csa -> do- mspanCtxt <- sequence (getSpanContext <$> lookupSpan ctx)- case mspanCtxt of- Nothing -> shouldSample rootSampler ctx tid name csa- Just root -> if OpenTelemetry.Internal.Trace.Types.isRemote root- then if isSampled $ traceFlags root- then shouldSample remoteParentSampled ctx tid name csa- else shouldSample remoteParentNotSampled ctx tid name csa- else if isSampled $ traceFlags root- then shouldSample localParentSampled ctx tid name csa- else shouldSample localParentNotSampled ctx tid name csa- }+parentBased ParentBasedOptions {..} =+ Sampler+ { getDescription =+ "ParentBased{root="+ <> getDescription rootSampler+ <> ", remoteParentSampled="+ <> getDescription remoteParentSampled+ <> ", remoteParentNotSampled="+ <> getDescription remoteParentNotSampled+ <> ", localParentSampled="+ <> getDescription localParentSampled+ <> ", localParentNotSampled="+ <> getDescription localParentNotSampled+ <> "}"+ , shouldSample = \ctx tid name csa -> do+ mspanCtxt <- sequence (getSpanContext <$> lookupSpan ctx)+ case mspanCtxt of+ Nothing -> shouldSample rootSampler ctx tid name csa+ Just root ->+ if OpenTelemetry.Internal.Trace.Types.isRemote root+ then+ if isSampled $ traceFlags root+ then shouldSample remoteParentSampled ctx tid name csa+ else shouldSample remoteParentNotSampled ctx tid name csa+ else+ if isSampled $ traceFlags root+ then shouldSample localParentSampled ctx tid name csa+ else shouldSample localParentNotSampled ctx tid name csa+ }
src/OpenTelemetry/Trace/TraceState.hs view
@@ -1,73 +1,88 @@ -------------------------------------------------------------------------------- |--- Module : OpenTelemetry.Trace.TraceState--- Copyright : (c) Ian Duncan, 2021--- License : BSD-3--- Description : W3C-compliant way to provide additional vendor-specific trace identification information across different distributed tracing systems--- Maintainer : Ian Duncan--- Stability : experimental--- Portability : non-portable (GHC extensions)------ The main purpose of the tracestate HTTP header is to provide additional vendor-specific trace identification information across different distributed tracing systems and is a companion header for the traceparent field. It also conveys information about the request’s position in multiple distributed tracing graphs.------ The tracestate field may contain any opaque value in any of the keys. Tracestate MAY be sent or received as multiple header fields. Multiple tracestate header fields MUST be handled as specified by RFC7230 Section 3.2.2 Field Order. The tracestate header SHOULD be sent as a single field when possible, but MAY be split into multiple header fields. When sending tracestate as multiple header fields, it MUST be split according to RFC7230. When receiving multiple tracestate header fields, they MUST be combined into a single header according to RFC7230.------ See the W3C specification https://www.w3.org/TR/trace-context/#tracestate-header--- for more details.---+ ------------------------------------------------------------------------------module OpenTelemetry.Trace.TraceState - ( TraceState- , Key(..)- , Value(..)- , empty- , insert- , update- , delete- , toList- ) where +{- |+ Module : OpenTelemetry.Trace.TraceState+ Copyright : (c) Ian Duncan, 2021+ License : BSD-3+ Description : W3C-compliant way to provide additional vendor-specific trace identification information across different distributed tracing systems+ Maintainer : Ian Duncan+ Stability : experimental+ Portability : non-portable (GHC extensions)++ The main purpose of the tracestate HTTP header is to provide additional vendor-specific trace identification information across different distributed tracing systems and is a companion header for the traceparent field. It also conveys information about the request’s position in multiple distributed tracing graphs.++ The tracestate field may contain any opaque value in any of the keys. Tracestate MAY be sent or received as multiple header fields. Multiple tracestate header fields MUST be handled as specified by RFC7230 Section 3.2.2 Field Order. The tracestate header SHOULD be sent as a single field when possible, but MAY be split into multiple header fields. When sending tracestate as multiple header fields, it MUST be split according to RFC7230. When receiving multiple tracestate header fields, they MUST be combined into a single header according to RFC7230.++ See the W3C specification https://www.w3.org/TR/trace-context/#tracestate-header+ for more details.+-}+module OpenTelemetry.Trace.TraceState (+ TraceState (TraceState),+ Key (..),+ Value (..),+ empty,+ insert,+ update,+ delete,+ toList,+) where+ import Data.Text (Text) + newtype Key = Key Text deriving (Show, Eq, Ord) + newtype Value = Value Text deriving (Show, Eq, Ord) --- | Data structure compliant with the storage and serialization needs of --- the W3C @tracestate@ header.++{- | Data structure compliant with the storage and serialization needs of+ the W3C @tracestate@ header.+-} newtype TraceState = TraceState [(Key, Value)] deriving (Show, Eq, Ord) + -- | An empty 'TraceState' key-value pair dictionary empty :: TraceState empty = TraceState [] --- | Add a key-value pair to a 'TraceState'------ O(n)++{- | Add a key-value pair to a 'TraceState'++ O(n)+-} insert :: Key -> Value -> TraceState -> TraceState insert k v ts = case delete k ts of (TraceState l) -> TraceState ((k, v) : l) --- | Update a value in the 'TraceState'. Does nothing if--- the value associated with the given key doesn't exist.------ O(n)++{- | Update a value in the 'TraceState'. Does nothing if+ the value associated with the given key doesn't exist.++ O(n)+-} update :: Key -> (Value -> Value) -> TraceState -> TraceState update k f (TraceState ts) = case break (\(k', _v) -> k == k') ts of (before, []) -> TraceState before (before, (_, v) : kvs) -> TraceState ((k, f v) : (before ++ kvs)) --- | Remove a key-value pair for the given key.------ O(n)++{- | Remove a key-value pair for the given key.++ O(n)+-} delete :: Key -> TraceState -> TraceState delete k (TraceState ts) = TraceState $ filter (\(k', _) -> k' /= k) ts --- | Convert the 'TraceState' to a list.------ O(1)++{- | Convert the 'TraceState' to a list.++ O(1)+-} toList :: TraceState -> [(Key, Value)] toList (TraceState ts) = ts
src/OpenTelemetry/Util.hs view
@@ -4,132 +4,166 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StrictData #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UnliftedFFITypes #-}-{-# LANGUAGE ScopedTypeVariables #-}+ -------------------------------------------------------------------------------- |--- Module : OpenTelemetry.Util--- Copyright : (c) Ian Duncan, 2021--- License : BSD-3--- Description : Convenience functions to simplify common instrumentation needs.--- Maintainer : Ian Duncan--- Stability : experimental--- Portability : non-portable (GHC extensions)---+ ------------------------------------------------------------------------------module OpenTelemetry.Util- ( constructorName- , HasConstructor- , getThreadId- , bracketError++{- |+ Module : OpenTelemetry.Util+ Copyright : (c) Ian Duncan, 2021+ License : BSD-3+ Description : Convenience functions to simplify common instrumentation needs.+ Maintainer : Ian Duncan+ Stability : experimental+ Portability : non-portable (GHC extensions)+-}+module OpenTelemetry.Util (+ constructorName,+ HasConstructor,+ getThreadId,+ bracketError,+ -- * Data structures- , AppendOnlyBoundedCollection- , emptyAppendOnlyBoundedCollection- , appendToBoundedCollection- , appendOnlyBoundedCollectionSize- , appendOnlyBoundedCollectionValues- , appendOnlyBoundedCollectionDroppedElementCount- , FrozenBoundedCollection- , frozenBoundedCollection- , frozenBoundedCollectionValues- , frozenBoundedCollectionDroppedElementCount- ) where+ AppendOnlyBoundedCollection,+ emptyAppendOnlyBoundedCollection,+ appendToBoundedCollection,+ appendOnlyBoundedCollectionSize,+ appendOnlyBoundedCollectionValues,+ appendOnlyBoundedCollectionDroppedElementCount,+ FrozenBoundedCollection,+ frozenBoundedCollection,+ frozenBoundedCollectionValues,+ frozenBoundedCollectionDroppedElementCount,+) where +import Control.Exception (SomeException)+import qualified Control.Exception as EUnsafe+import Control.Monad.IO.Unlift import Data.Foldable import Data.Kind import qualified Data.Vector as V+import Foreign.C (CInt (..))+import GHC.Base (Addr#)+import GHC.Conc (ThreadId (ThreadId)) import GHC.Generics-import GHC.Conc (ThreadId(ThreadId))-import GHC.Base (ThreadId#)-import Foreign.C (CInt(..)) import VectorBuilder.Builder (Builder) import qualified VectorBuilder.Builder as Builder import qualified VectorBuilder.Vector as Builder-import Control.Monad.IO.Unlift-import Control.Exception (SomeException)-import qualified Control.Exception as EUnsafe+import Unsafe.Coerce (unsafeCoerce#) --- | Useful for annotating which constructor in an ADT was chosen------ @since 0.1.0.0++{- | Useful for annotating which constructor in an ADT was chosen++ @since 0.1.0.0+-} constructorName :: (HasConstructor (Rep a), Generic a) => a -> String constructorName = genericConstrName . from + -- | Detect a constructor from any datatype which derives 'Generic' class HasConstructor (f :: Type -> Type) where genericConstrName :: f x -> String + instance HasConstructor f => HasConstructor (D1 c f) where genericConstrName (M1 x) = genericConstrName x + instance (HasConstructor x, HasConstructor y) => HasConstructor (x :+: y) where genericConstrName (L1 l) = genericConstrName l genericConstrName (R1 r) = genericConstrName r + instance Constructor c => HasConstructor (C1 c f) where- genericConstrName x = conName x+ genericConstrName = conName -foreign import ccall unsafe "rts_getThreadId" c_getThreadId :: ThreadId# -> CInt+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 tid#)+getThreadId (ThreadId tid#) = fromIntegral $ c_getThreadId (unsafeCoerce# tid#) {-# INLINE getThreadId #-} + data AppendOnlyBoundedCollection a = AppendOnlyBoundedCollection { collection :: Builder a , maxSize :: {-# UNPACK #-} !Int , dropped :: {-# UNPACK #-} !Int } + instance forall a. Show a => Show (AppendOnlyBoundedCollection a) where- show AppendOnlyBoundedCollection {collection=c} =+ showsPrec d AppendOnlyBoundedCollection {collection = c, maxSize = m, dropped = r} = let vec = Builder.build c :: V.Vector a- in show vec+ in showParen (d > 10) $+ showString "AppendOnlyBoundedCollection {collection = "+ . shows vec+ . showString ", maxSize = "+ . shows m+ . showString ", dropped = "+ . shows r+ . showString "}" + -- | Initialize a bounded collection that admits a maximum size emptyAppendOnlyBoundedCollection ::- Int- -- ^ Maximum size- -> AppendOnlyBoundedCollection a+ -- | Maximum size+ Int ->+ AppendOnlyBoundedCollection a emptyAppendOnlyBoundedCollection s = AppendOnlyBoundedCollection mempty s 0 + appendOnlyBoundedCollectionValues :: AppendOnlyBoundedCollection a -> V.Vector a appendOnlyBoundedCollectionValues (AppendOnlyBoundedCollection a _ _) = Builder.build a + appendOnlyBoundedCollectionSize :: AppendOnlyBoundedCollection a -> Int appendOnlyBoundedCollectionSize (AppendOnlyBoundedCollection b _ _) = Builder.size b + appendOnlyBoundedCollectionDroppedElementCount :: AppendOnlyBoundedCollection a -> Int appendOnlyBoundedCollectionDroppedElementCount (AppendOnlyBoundedCollection _ _ d) = d + appendToBoundedCollection :: AppendOnlyBoundedCollection a -> a -> AppendOnlyBoundedCollection a-appendToBoundedCollection c@(AppendOnlyBoundedCollection b ms d) x = if appendOnlyBoundedCollectionSize c < ms- then AppendOnlyBoundedCollection (b <> Builder.singleton x) ms d- else AppendOnlyBoundedCollection b ms (d + 1)+appendToBoundedCollection c@(AppendOnlyBoundedCollection b ms d) x =+ if appendOnlyBoundedCollectionSize c < ms+ then AppendOnlyBoundedCollection (b <> Builder.singleton x) ms d+ else AppendOnlyBoundedCollection b ms (d + 1) + data FrozenBoundedCollection a = FrozenBoundedCollection { collection :: !(V.Vector a) , dropped :: !Int- } deriving (Show)+ }+ deriving (Show) + frozenBoundedCollection :: Foldable f => Int -> f a -> FrozenBoundedCollection a frozenBoundedCollection maxSize_ coll = FrozenBoundedCollection (V.fromListN maxSize_ $ toList coll) (collLength - maxSize_) where collLength = length coll + frozenBoundedCollectionValues :: FrozenBoundedCollection a -> V.Vector a frozenBoundedCollectionValues (FrozenBoundedCollection coll _) = coll + frozenBoundedCollectionDroppedElementCount :: FrozenBoundedCollection a -> Int frozenBoundedCollectionDroppedElementCount (FrozenBoundedCollection _ dropped_) = dropped_ --- | Like 'Context.Exception.bracket', but provides the @after@ function with information about--- uncaught exceptions.------ @since 0.1.0.0++{- | Like 'Context.Exception.bracket', but provides the @after@ function with information about+ uncaught exceptions.++ @since 0.1.0.0+-} 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@@ -142,7 +176,7 @@ -- -- https://github.com/fpco/safe-exceptions/issues/2 _ :: Either SomeException b <-- EUnsafe.try $ EUnsafe.uninterruptibleMask_ $ run $ after (Just e1) x+ EUnsafe.try $ EUnsafe.uninterruptibleMask_ $ run $ after (Just e1) x EUnsafe.throwIO e1 Right y -> do _ <- EUnsafe.uninterruptibleMask_ $ run $ after Nothing x
test/OpenTelemetry/Trace/SamplerSpec.hs view
@@ -1,13 +1,14 @@ module OpenTelemetry.Trace.SamplerSpec where import Control.Monad-import Test.Hspec import qualified OpenTelemetry.Context as Context import OpenTelemetry.Trace.Core import OpenTelemetry.Trace.Id import OpenTelemetry.Trace.Sampler import qualified OpenTelemetry.Trace.TraceState as TraceState+import Test.Hspec + builtInNonCompositeSamplers :: [Sampler] builtInNonCompositeSamplers = [ alwaysOff@@ -15,6 +16,7 @@ , traceIdRatioBased 0.99 ] + -- TODO, these would largely be good candidates for quickcheck spec :: Spec spec = describe "Sampler" $ do@@ -23,30 +25,31 @@ specify (show (getDescription sampler) ++ " returns parent tracestate") $ do let (Right aTraceId) = baseEncodedToTraceId Base16 "00000000000000000000000000000001" (Right parentSpanId) = baseEncodedToSpanId Base16 "000000000000000a"- remoteSpan = SpanContext- { traceFlags = defaultTraceFlags- , isRemote = False- , traceState = TraceState.insert (TraceState.Key "k") (TraceState.Value "v") TraceState.empty- , spanId = parentSpanId- , traceId = aTraceId- }+ remoteSpan =+ SpanContext+ { traceFlags = defaultTraceFlags+ , isRemote = False+ , traceState = TraceState.insert (TraceState.Key "k") (TraceState.Value "v") TraceState.empty+ , spanId = parentSpanId+ , traceId = aTraceId+ } traceParent = wrapSpanContext remoteSpan parentContext = Context.insertSpan traceParent Context.empty (_, _, ts) <- shouldSample sampler parentContext aTraceId "test" defaultSpanArguments ts `shouldBe` traceState remoteSpan - describe "alwaysOff" $ do it "returns Drop" $ do let (Right aTraceId) = baseEncodedToTraceId Base16 "00000000000000000000000000000001" (Right parentSpanId) = baseEncodedToSpanId Base16 "000000000000000a"- remoteSpan = SpanContext- { traceFlags = defaultTraceFlags- , isRemote = False- , traceState = TraceState.empty- , spanId = parentSpanId- , traceId = aTraceId- }+ remoteSpan =+ SpanContext+ { traceFlags = defaultTraceFlags+ , isRemote = False+ , traceState = TraceState.empty+ , spanId = parentSpanId+ , traceId = aTraceId+ } traceParent = wrapSpanContext remoteSpan parentContext = Context.insertSpan traceParent Context.empty (res, _, _) <- shouldSample alwaysOff parentContext aTraceId "test" defaultSpanArguments@@ -56,13 +59,14 @@ it "returns RecordAndSample" $ do let (Right aTraceId) = baseEncodedToTraceId Base16 "00000000000000000000000000000001" (Right parentSpanId) = baseEncodedToSpanId Base16 "000000000000000a"- remoteSpan = SpanContext- { traceFlags = defaultTraceFlags- , isRemote = False- , traceState = TraceState.empty- , spanId = parentSpanId- , traceId = aTraceId- }+ remoteSpan =+ SpanContext+ { traceFlags = defaultTraceFlags+ , isRemote = False+ , traceState = TraceState.empty+ , spanId = parentSpanId+ , traceId = aTraceId+ } traceParent = wrapSpanContext remoteSpan parentContext = Context.insertSpan traceParent Context.empty (res, _, _) <- shouldSample alwaysOn parentContext aTraceId "test" defaultSpanArguments@@ -73,13 +77,14 @@ let sampler = traceIdRatioBased 0.5 (Right aTraceId) = baseEncodedToTraceId Base16 "ffffffffffffffff0000000000000000" (Right parentSpanId) = baseEncodedToSpanId Base16 "0000000000000001"- remoteSpan = SpanContext- { traceFlags = defaultTraceFlags- , isRemote = False- , traceState = TraceState.empty- , spanId = parentSpanId- , traceId = aTraceId- }+ remoteSpan =+ SpanContext+ { traceFlags = defaultTraceFlags+ , isRemote = False+ , traceState = TraceState.empty+ , spanId = parentSpanId+ , traceId = aTraceId+ } traceParent = wrapSpanContext remoteSpan parentContext = Context.insertSpan traceParent Context.empty (res, _, _) <- shouldSample sampler parentContext aTraceId "test" defaultSpanArguments@@ -88,13 +93,14 @@ let sampler = traceIdRatioBased 0.5 (Right aTraceId) = baseEncodedToTraceId Base16 "00000000000000000000000000000000" (Right parentSpanId) = baseEncodedToSpanId Base16 "0000000000000001"- remoteSpan = SpanContext- { traceFlags = defaultTraceFlags- , isRemote = False- , traceState = TraceState.empty- , spanId = parentSpanId- , traceId = aTraceId- }+ remoteSpan =+ SpanContext+ { traceFlags = defaultTraceFlags+ , isRemote = False+ , traceState = TraceState.empty+ , spanId = parentSpanId+ , traceId = aTraceId+ } traceParent = wrapSpanContext remoteSpan parentContext = Context.insertSpan traceParent Context.empty (res, _, _) <- shouldSample sampler parentContext aTraceId "test" defaultSpanArguments@@ -104,13 +110,14 @@ permissiveSampler = traceIdRatioBased 0.75 (Right aTraceId) = baseEncodedToTraceId Base16 "3fffffffffffffff0000000000000000" (Right parentSpanId) = baseEncodedToSpanId Base16 "0000000000000001"- remoteSpan = SpanContext- { traceFlags = defaultTraceFlags- , isRemote = False- , traceState = TraceState.empty- , spanId = parentSpanId- , traceId = aTraceId- }+ remoteSpan =+ SpanContext+ { traceFlags = defaultTraceFlags+ , isRemote = False+ , traceState = TraceState.empty+ , spanId = parentSpanId+ , traceId = aTraceId+ } traceParent = wrapSpanContext remoteSpan parentContext = Context.insertSpan traceParent Context.empty do@@ -118,5 +125,3 @@ (resPermissive, _, _) <- shouldSample conservativeSampler parentContext aTraceId "test" defaultSpanArguments resConservative `shouldBe` RecordAndSample resPermissive `shouldBe` RecordAndSample- -
test/OpenTelemetry/Trace/TraceFlagsSpec.hs view
@@ -3,6 +3,7 @@ import OpenTelemetry.Trace.Core import Test.Hspec + spec :: Spec spec = describe "TraceFlags" $ do it "starts unsampled by default" $ do
test/Spec.hs view
@@ -1,27 +1,32 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-import Test.Hspec-import OpenTelemetry.Attributes (lookupAttribute)-import OpenTelemetry.Trace.Core-import Control.Monad.Reader-import OpenTelemetry.Context+ import Control.Exception-import qualified Data.Bifunctor import Control.Monad.IO.Unlift (MonadUnliftIO)+import Control.Monad.Reader+import qualified Data.Bifunctor import Data.IORef import Data.Maybe (isJust) import qualified Data.Vector as V-import qualified VectorBuilder.Vector as Builder+import OpenTelemetry.Attributes (lookupAttribute)+import OpenTelemetry.Context+import OpenTelemetry.Trace.Core -- Specs-import qualified OpenTelemetry.Trace.TraceFlagsSpec as TraceFlags+ import qualified OpenTelemetry.Trace.SamplerSpec as Sampler+import qualified OpenTelemetry.Trace.TraceFlagsSpec as TraceFlags import OpenTelemetry.Util+import Test.Hspec+import qualified VectorBuilder.Vector as Builder + newtype TestException = TestException String deriving (Show) + instance Exception TestException + exceptionTest :: IO () exceptionTest = do tp <- getGlobalTracerProvider@@ -34,10 +39,11 @@ spanState <- unsafeReadSpan =<< readIORef spanToCheck let ev = V.head $ appendOnlyBoundedCollectionValues $ spanEvents spanState eventName ev `shouldBe` "exception"- eventAttributes ev `shouldSatisfy` \attrs -> - isJust (lookupAttribute attrs "exception.type") &&- isJust (lookupAttribute attrs "exception.message") &&- isJust (lookupAttribute attrs "exception.stacktrace")+ eventAttributes ev `shouldSatisfy` \attrs ->+ isJust (lookupAttribute attrs "exception.type")+ && isJust (lookupAttribute attrs "exception.message")+ && isJust (lookupAttribute attrs "exception.stacktrace")+ main :: IO () main = hspec $ do