hs-opentelemetry-api (empty) → 0.0.1.0

raw patch · 38 files changed

+4028/−0 lines, 38 filesdep +asyncdep +attoparsecdep +basesetup-changed

Dependencies added: async, attoparsec, base, binary, bytestring, charset, clock, containers, ghc-prim, hashable, hs-opentelemetry-api, hspec, http-types, memory, mtl, template-haskell, text, thread-utils-context, unliftio-core, unordered-containers, vault, vector, vector-builder

Files

• ChangeLog.md +3/−0
• LICENSE +30/−0
• README.md +22/−0
• Setup.hs +2/−0
• hs-opentelemetry-api.cabal +128/−0
• src/OpenTelemetry/Attributes.hs +183/−0
• src/OpenTelemetry/Baggage.hs +260/−0
• src/OpenTelemetry/Context.hs +101/−0
• src/OpenTelemetry/Context/ThreadLocal.hs +119/−0
• src/OpenTelemetry/Context/Types.hs +22/−0
• src/OpenTelemetry/Exporter.hs +21/−0
• src/OpenTelemetry/Internal/Trace/Types.hs +395/−0
• src/OpenTelemetry/Processor.hs +26/−0
• src/OpenTelemetry/Propagator.hs +71/−0
• src/OpenTelemetry/Resource.hs +170/−0
• src/OpenTelemetry/Resource/Cloud.hs +114/−0
• src/OpenTelemetry/Resource/Container.hs +42/−0
• src/OpenTelemetry/Resource/DeploymentEnvironment.hs +34/−0
• src/OpenTelemetry/Resource/Device.hs +14/−0
• src/OpenTelemetry/Resource/FaaS.hs +69/−0
• src/OpenTelemetry/Resource/Host.hs +48/−0
• src/OpenTelemetry/Resource/Kubernetes.hs +169/−0
• src/OpenTelemetry/Resource/OperatingSystem.hs +69/−0
• src/OpenTelemetry/Resource/Process.hs +85/−0
• src/OpenTelemetry/Resource/Service.hs +54/−0
• src/OpenTelemetry/Resource/Telemetry.hs +62/−0
• src/OpenTelemetry/Resource/Webengine.hs +14/−0
• src/OpenTelemetry/Trace/Core.hs +681/−0
• src/OpenTelemetry/Trace/Id.hs +332/−0
• src/OpenTelemetry/Trace/Id/Generator.hs +30/−0
• src/OpenTelemetry/Trace/Id/Generator/Dummy.hs +10/−0
• src/OpenTelemetry/Trace/Monad.hs +75/−0
• src/OpenTelemetry/Trace/Sampler.hs +173/−0
• src/OpenTelemetry/Trace/TraceState.hs +73/−0
• src/OpenTelemetry/Util.hs +144/−0
• test/OpenTelemetry/Trace/SamplerSpec.hs +122/−0
• test/OpenTelemetry/Trace/TraceFlagsSpec.hs +13/−0
• test/Spec.hs +48/−0

@@ -0,0 +1,3 @@+# Changelog for hs-opentelemetry-api++## Unreleased changes

@@ -0,0 +1,30 @@+Copyright Ian Duncan (c) 2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Ian Duncan nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,22 @@+# OpenTelemetry API for Haskell++This package provides an interface for instrumentors to use when instrumenting+a library directly or implementing a wrapper API around an existing project.++The methods in this package can be safely called by libraries or end-user applications regardless of+whether the application has registered an OpenTelemetry SDK configuration or not.+When the OpenTelemetry SDK has not registered a tracer provider with any span processors, there API incurs minimal performance overhead, as most of the core interface performs no-ops.++In order to generate and export telemetry data, you will also need to use the [OpenTelemetry Haskell SDK](https://github.com/iand675/hs-opentelemetry/blob/main/sdk/README.md).++The inspiration of the OpenTelemetry project is to make every library and application observable out of the box by having them call the OpenTelemetry API directly. Until that happens, there is a need for a separate library which can inject this information. A library that enables observability for another library is called an instrumentation library. In the case of Haskell, instrumentation is currently entirely manual.++Visit the [GitHub project](https://github.com/iand675/hs-opentelemetry#readme) for a list of provided instrumentation libraries.++## Install Dependencies++Add `hs-opentelemetry-api` to your `package.yaml` or Cabal file.++### Useful Links+- For more information on OpenTelemetry, visit: <https://opentelemetry.io/>+- For more about the Haskell OpenTelemetry project, visit: <https://github.com/iand675/hs-opentelemetry>

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,128 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           hs-opentelemetry-api+version:        0.0.1.0+synopsis:       OpenTelemetry API for use by libraries for direct instrumentation or wrapper packages.+description:    Please see the README on GitHub at <https://github.com/iand675/hs-opentelemetry/tree/main/api#readme>+category:       OpenTelemetry, Telemetry, Monitoring, Observability, Metrics+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+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/iand675/hs-opentelemetry++library+  exposed-modules:+      OpenTelemetry.Attributes+      OpenTelemetry.Baggage+      OpenTelemetry.Context+      OpenTelemetry.Context.ThreadLocal+      OpenTelemetry.Exporter+      OpenTelemetry.Processor+      OpenTelemetry.Propagator+      OpenTelemetry.Resource+      OpenTelemetry.Resource.Cloud+      OpenTelemetry.Resource.Container+      OpenTelemetry.Resource.DeploymentEnvironment+      OpenTelemetry.Resource.Device+      OpenTelemetry.Resource.FaaS+      OpenTelemetry.Resource.Host+      OpenTelemetry.Resource.Kubernetes+      OpenTelemetry.Resource.OperatingSystem+      OpenTelemetry.Resource.Process+      OpenTelemetry.Resource.Service+      OpenTelemetry.Resource.Telemetry+      OpenTelemetry.Resource.Webengine+      OpenTelemetry.Trace.Core+      OpenTelemetry.Trace.Id+      OpenTelemetry.Trace.Id.Generator+      OpenTelemetry.Trace.Id.Generator.Dummy+      OpenTelemetry.Trace.Monad+      OpenTelemetry.Trace.Sampler+      OpenTelemetry.Trace.TraceState+      OpenTelemetry.Util+  other-modules:+      OpenTelemetry.Context.Types+      OpenTelemetry.Internal.Trace.Types+  hs-source-dirs:+      src+  default-extensions:+      OverloadedStrings+      RecordWildCards+  ghc-options: -Wall+  build-depends:+      async+    , attoparsec+    , base >=4.7 && <5+    , binary+    , bytestring+    , charset+    , clock+    , containers+    , ghc-prim+    , hashable+    , http-types+    , memory+    , mtl+    , template-haskell+    , text+    , thread-utils-context+    , unliftio-core+    , unordered-containers+    , vault+    , vector+    , vector-builder+  default-language: Haskell2010++test-suite hs-opentelemetry-api-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      OpenTelemetry.Trace.SamplerSpec+      OpenTelemetry.Trace.TraceFlagsSpec+      Paths_hs_opentelemetry_api+  hs-source-dirs:+      test+  default-extensions:+      OverloadedStrings+      RecordWildCards+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      async+    , attoparsec+    , base >=4.7 && <5+    , binary+    , bytestring+    , charset+    , clock+    , containers+    , ghc-prim+    , hashable+    , hs-opentelemetry-api+    , hspec+    , http-types+    , memory+    , mtl+    , template-haskell+    , text+    , thread-utils-context+    , unliftio-core+    , unordered-containers+    , vault+    , vector+    , vector-builder+  default-language: Haskell2010

@@ -0,0 +1,183 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DeriveAnyClass #-}+-----------------------------------------------------------------------------+-- |+-- 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+  -- * 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+import Data.Data+import Data.Hashable++-- | 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+  }++data Attributes = Attributes+  { attributes :: !(H.HashMap Text Attribute)+  , attributesCount :: {-# UNPACK #-} !Int+  , attributesDropped :: {-# UNPACK #-} !Int+  }+  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+  Nothing -> 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++    limitPrimAttr limit_ (TextAttribute t) = TextAttribute (T.take limit_ t)+    limitPrimAttr _ attr = attr++    limitLengths attr = case attributeLengthLimit of+      Nothing -> attr+      Just limit_ -> case attr of+        AttributeValue val -> AttributeValue $ limitPrimAttr limit_ val+        AttributeArray arr -> AttributeArray $ fmap (limitPrimAttr limit_) arr+        +{-# 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)+{-# INLINE addAttributes #-}++getAttributes :: Attributes -> (Int, H.HashMap Text Attribute)+getAttributes Attributes{..} = (attributesCount, attributes)++lookupAttribute :: Attributes -> Text -> Maybe Attribute+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.+data AttributeLimits = AttributeLimits+  { attributeCountLimit :: Maybe Int+  -- ^ The number of unique attributes that may be added to an 'Attributes' structure before they are dropped.+  , attributeLengthLimit :: Maybe Int+  -- ^ The maximum length of string attributes that may be set. Longer-length string values will be truncated to the+  -- specified amount.+  }+  deriving stock (Read, Show, Eq, Ord, Data, Generic)+  deriving anyclass (Hashable)++class ToPrimitiveAttribute a where+  toPrimitiveAttribute :: a -> PrimitiveAttribute++data Attribute+  = AttributeValue PrimitiveAttribute+  | AttributeArray [PrimitiveAttribute]+  deriving stock (Read, Show, Eq, Ord, Data, Generic)+  deriving anyclass (Hashable)++data PrimitiveAttribute+  = TextAttribute Text+  | BoolAttribute Bool+  | DoubleAttribute Double+  | IntAttribute Int64+  deriving stock (Read, Show, Eq, Ord, Data, Generic)+  deriving anyclass (Hashable)+++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+  where+    hm = H.fromList l+    c = H.size hm

@@ -0,0 +1,260 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DerivingStrategies #-}+{-# 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 +  (+  -- * Constructing 'Baggage' structures+    Baggage+  , empty+  , fromHashMap+  , values+  , Token+  , token+  , mkToken+  , tokenValue+  , Element(..)+  , element+  , property+  , InvalidBaggage(..)+  -- * Modifying 'Baggage'+  , insert+  , delete+  -- * Encoding and decoding 'Baggage'+  , 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.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.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 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+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+  liftTyped (Token tok) = unsafeTExpCoerce $ bsToExp tok++-- | 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.+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 :: ByteString -> Q Exp+#if MIN_VERSION_template_haskell(2, 5, 0)+bsToExp bs =+    return $ ConE 'Token+      `AppE` (VarE 'unsafePerformIO+      `AppE` (VarE 'unsafePackAddressLen+      `AppE` LitE (IntegerL $ fromIntegral $ BS.length bs)+#if MIN_VERSION_template_haskell(2, 16, 0)+      `AppE` LitE (bytesPrimL (+                let BS.PS ptr off sz = bs+                in  mkBytes ptr (fromIntegral off) (fromIntegral sz)))))+#elif MIN_VERSION_template_haskell(2, 8, 0)+      `AppE` LitE (StringPrimL $ B.unpack bs)))+#else+      `AppE` LitE (StringPrimL $ B8.unpack bs)))+#endif+#else+bsToExp bs = do+    helper <- [| stringToBs |]+    let chars = B8.unpack bs+    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"+  }+  where+    parseExp = \str -> case mkToken $ T.pack str of+      Nothing -> fail (show str ++ " is not a valid Token.")+      Just tok -> lift tok+++data InvalidBaggage+  = BaggageTooLong+  | MemberTooLong+  | TooManyListMembers+  | Empty++-- 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++encodeBaggageHeaderB :: Baggage -> B.Builder+encodeBaggageHeaderB (Baggage 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++decodeBaggageHeader :: ByteString -> Either String Baggage+decodeBaggageHeader = P.parseOnly decodeBaggageHeaderP++decodeBaggageHeaderP :: P.Parser Baggage+decodeBaggageHeaderP = do+  owsP+  firstMember <- memberP+  otherMembers <- many (owsP >> P.char8 ',' >> owsP >> memberP)+  owsP+  pure $ Baggage $ H.fromList (firstMember : otherMembers)+  where+    owsSet = C.fromList " \t"+    owsP = P.skipWhile (`C.member` owsSet)+    memberP :: P.Parser (Token, Element)+    memberP = do+      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']+        ]+    tokenP :: P.Parser Token+    tokenP = Token <$> P.takeWhile1 (`C.member` tokenCharacters)+    valP = decodeUtf8 <$> P.takeWhile (`C.member` valueSet)+    propertyP :: P.Parser Property+    propertyP = do+      key <- tokenP+      owsP+      val <- P.option Nothing $ do+        _ <- P.char8 '='+        owsP+        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 k v (Baggage c) = Baggage (H.insert k v c)++-- | Delete a key/value pair from the 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+values :: Baggage -> H.HashMap Token Element+values (Baggage m) = m++-- | Convert a 'H.HashMap' into 'Baggage'+fromHashMap :: H.HashMap Token Element -> Baggage+fromHashMap = Baggage

@@ -0,0 +1,101 @@+{-# 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+  -- , insertWith+  , adjust+  , delete+  , union+  , insertSpan+  , lookupSpan+  , insertBaggage+  , lookupBaggage+  ) where+import Control.Monad.IO.Class+import Data.Maybe+import Data.Text (Text)+import qualified Data.Vault.Strict as V+import OpenTelemetry.Baggage (Baggage)+import OpenTelemetry.Context.Types+import OpenTelemetry.Internal.Trace.Types+import Prelude hiding (lookup)+import System.IO.Unsafe++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) +--   -- ^ new value -> old value -> result+--   -> Key a -> a -> Context -> Context+-- insertWith f (Key _ k) x (Context v) = Context $ case V.lookup k of+--   Nothing -> V.insert k x v+--   Just ox -> V.insert k (f x ox) v++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++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

@@ -0,0 +1,119 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE UnboxedTuples #-}+{-# 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.+--+-- Note that this implementation of context sharing is+-- mildly expensive for the garbage collector, hard to reason about without deep+-- knowledge of the code you are instrumenting, and has limited guarantees of behavior +-- across GHC versions due to internals usage.+--+-- Why use this implementation, then? Depending on the structure of libraries+-- that you are attempting to instrument, this may be the only way to smuggle+-- a 'Context' in without significant breaking changes to the existing library+-- interface.+--+-- The rule of thumb:+-- - Where possible, use OpenTelemetry.Context in a reader-esque monad, or+--   pass it around directly.+-- - When all else fails, use this instead.+--+-----------------------------------------------------------------------------+module OpenTelemetry.Context.ThreadLocal +  ( +  -- * Thread-local context+    getContext+  , lookupContext+  , attachContext+  , detachContext+  , adjustContext+  -- ** Generalized thread-local context functions+  , lookupContextOnThread+  , attachContextOnThread+  , detachContextFromThread+  , adjustContextOnThread+  ) where+import OpenTelemetry.Context (Context, empty)+import Control.Concurrent+-- import Control.Concurrent.Async+import Control.Concurrent.Thread.Storage+import Control.Monad.IO.Class+import Data.Maybe (fromMaybe)+-- import Control.Monad+import System.IO.Unsafe+import Prelude hiding (lookup)++type ThreadContextMap = ThreadStorageMap Context++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.+getContext :: MonadIO m => m Context+getContext = fromMaybe empty <$> lookupContext++-- | Retrieve a stored 'Context' for the current thread, if it exists.+lookupContext :: MonadIO m => m (Maybe Context)+lookupContext = lookup threadContextMap++-- | Retrieve a stored 'Context' for the provided 'ThreadId', if it exists.+lookupContextOnThread :: MonadIO m => ThreadId -> m (Maybe Context)+lookupContextOnThread = lookupOnThread threadContextMap++-- | Store a given 'Context' for the current thread, returning any context previously stored.+attachContext :: MonadIO m => Context -> m (Maybe Context)+attachContext = attach threadContextMap++-- | Store a given 'Context' for the provided 'ThreadId', returning any context previously stored.+attachContextOnThread :: MonadIO m => ThreadId -> Context -> m (Maybe Context)+attachContextOnThread = attachOnThread threadContextMap++-- | Remove a stored 'Context' for the current thread, returning any context previously stored.+detachContext :: MonadIO m => m (Maybe Context)+detachContext = detach threadContextMap++-- | Remove a stored 'Context' for the provided 'ThreadId', returning any context previously stored.+detachContextFromThread :: MonadIO m => ThreadId -> m (Maybe Context)+detachContextFromThread = detachFromThread threadContextMap++-- | Alter the context on the current thread using the provided function+adjustContext :: MonadIO m => (Context -> Context) -> m ()+adjustContext = adjust threadContextMap++-- | Alter the context+adjustContextOnThread :: MonadIO m => ThreadId -> (Context -> Context) -> m ()+adjustContextOnThread = adjustOnThread threadContextMap+

@@ -0,0 +1,22 @@+module OpenTelemetry.Context.Types where++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+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 }

@@ -0,0 +1,21 @@+-----------------------------------------------------------------------------+-- |+-- 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

@@ -0,0 +1,395 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+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.IORef (IORef, readIORef)+import Data.String ( IsString(..) )+import Data.Text (Text)+import Data.Vector (Vector)+import Data.Word (Word8)+import GHC.Generics+import Network.HTTP.Types (RequestHeaders, ResponseHeaders)+import OpenTelemetry.Attributes+import OpenTelemetry.Context.Types+import OpenTelemetry.Trace.Id+import OpenTelemetry.Resource+import OpenTelemetry.Trace.Id.Generator+import OpenTelemetry.Propagator (Propagator)+import OpenTelemetry.Trace.TraceState+import OpenTelemetry.Util+import System.Clock (TimeSpec)+++data ExportResult+  = Success+  | Failure (Maybe SomeException)++data InstrumentationLibrary = InstrumentationLibrary+  { libraryName :: {-# UNPACK #-} !Text+  , libraryVersion :: {-# UNPACK #-} !Text+  } deriving (Ord, Eq, Generic, Show)++instance Hashable InstrumentationLibrary+instance IsString InstrumentationLibrary where+  fromString str = InstrumentationLibrary (fromString str) ""++data Exporter = Exporter+  { exporterExport :: HashMap InstrumentationLibrary (Vector ImmutableSpan) -> 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.+  , processorOnEnd :: IORef ImmutableSpan -> IO ()+  -- ^ Called after a span is ended (i.e., the end timestamp is already set). This method is called synchronously within the 'OpenTelemetry.Trace.endSpan' API, therefore it should not block or throw an exception.+  , processorShutdown :: IO (Async ShutdownResult)+  -- ^ Shuts down the processor. Called when SDK is shut down. This is an opportunity for processor to do any cleanup required.+  -- +  -- Shutdown SHOULD be called only once for each SpanProcessor instance. After the call to Shutdown, subsequent calls to OnStart, OnEnd, or ForceFlush are not allowed. SDKs SHOULD ignore these calls gracefully, if possible.+  --+  -- Shutdown SHOULD let the caller know whether it succeeded, failed or timed out.+  -- +  -- Shutdown MUST include the effects of ForceFlush.+  --+  -- Shutdown SHOULD complete or abort within some timeout. Shutdown 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 shutdown timeout configurable.+  , processorForceFlush :: IO ()+  -- ^ This is a hint to ensure that any tasks associated with Spans for which the SpanProcessor had already received events prior to the call to ForceFlush SHOULD be completed as soon as possible, preferably before returning from this method.+  --+  -- In particular, if any Processor has any associated exporter, it SHOULD try to call the exporter's Export with all spans for which this was not already done and then invoke ForceFlush on it. The built-in SpanProcessors MUST do so. If a timeout is specified (see below), the SpanProcessor MUST prioritize honoring the timeout over finishing all calls. It MAY skip or abort some or all Export or ForceFlush calls it has made to achieve this goal.+  --+  -- ForceFlush SHOULD provide a way to let the caller know whether it succeeded, failed or timed out.+  --+  -- ForceFlush SHOULD only be called in cases where it is absolutely necessary, such as when using some FaaS providers that may suspend the process after an invocation, but before the SpanProcessor exports the completed spans.+  --+  -- 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 create from a 'TracerProvider'.+-}+data TracerProvider = TracerProvider +  { tracerProviderProcessors :: !(Vector Processor)+  , tracerProviderIdGenerator :: !IdGenerator+  , tracerProviderSampler :: !Sampler+  , tracerProviderResources :: !MaterializedResources+  , tracerProviderAttributeLimits :: !AttributeLimits+  , tracerProviderSpanLimits :: !SpanLimits+  , tracerProviderPropagators :: !(Propagator Context RequestHeaders ResponseHeaders)+  }++-- | 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+  , tracerProvider :: !TracerProvider+  }++newtype Timestamp = Timestamp TimeSpec+  deriving (Show, Eq, Ord)++{- |+A @Span@ may be linked to zero or more other @Spans@ (defined by @SpanContext@) that are causally related. +@Link@s can point to Spans inside a single Trace or across different Traces. @Link@s can be used to represent +batched operations where a @Span@ was initiated by multiple initiating Spans, each representing a single incoming +item being processed in the batch.++Another example of using a Link is to declare the relationship between the originating and following trace. +This can be used when a Trace enters trusted boundaries of a service and service policy requires the generation +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 +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. +It is recommended, however, to not set parent of the Span in this scenario as semantically the parent field +represents a single parent scenario, in many cases the parent Span fully encloses the child Span. +This is not the case in scatter/gather and batch scenarios.+-}+data Link = Link+  { linkContext :: !SpanContext+  -- ^ @SpanContext@ of the @Span@ to link to.+  , linkAttributes :: Attributes+  -- ^ Zero or more Attributes further describing the link.+  }+  deriving (Show)++-- | Non-name fields that may be set on initial creation of a 'Span'.+data SpanArguments = SpanArguments+  { kind :: SpanKind+  -- ^ The kind of the span. See 'SpanKind's documentation for the semantics+  -- of the various values that may be specified.+  , attributes :: [(Text, Attribute)]+  -- ^ An initial set of attributes that may be set on initial 'Span' creation.+  -- These attributes are provided to 'Processor's, so they may be useful in some+  -- scenarios where calling `addAttribute` or `addAttributes` is too late.+  , links :: [Link]+  -- ^ A collection of `Link`s that point to causally related 'Span's.+  , startTime :: Maybe Timestamp+  -- ^ 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.+  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.++The first property described by @SpanKind@ reflects whether the @Span@ is a remote child or parent. @Span@s with a remote parent are interesting because they are sources of external load. Spans with a remote child are interesting because they reflect a non-local system dependency.++The second property described by @SpanKind@ reflects whether a child @Span@ represents a synchronous call. When a child span is synchronous, the parent is expected to wait for it to complete under ordinary circumstances. It can be useful for tracing systems to know this property, since synchronous @Span@s may contribute to the overall trace latency. Asynchronous scenarios can be remote or local.++In order for @SpanKind@ to be meaningful, callers SHOULD arrange that a single @Span@ does not serve more than one purpose. For example, a server-side span SHOULD NOT be used directly as the parent of another remote span. As a simple guideline, instrumentation should create a new @Span@ prior to extracting and serializing the @SpanContext@ for a remote call.++To summarize the interpretation of these kinds+++-------------+--------------+---------------+------------------+------------------++| `SpanKind`  | Synchronous  | Asynchronous  | Remote Incoming  | Remote Outgoing  |++=============+==============+===============+==================+==================++| `Client`    | yes          |               |                  | yes              |++-------------+--------------+---------------+------------------+------------------++| `Server`    | yes          |               | yes              |                  |++-------------+--------------+---------------+------------------+------------------++| `Producer`  |              | yes           |                  | maybe            |++-------------+--------------+---------------+------------------+------------------++| `Consumer`  |              | yes           | maybe            |                  |++-------------+--------------+---------------+------------------+------------------++| `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.+  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.+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.+  deriving (Show, Eq)++instance Ord SpanStatus where+  compare Unset Unset = EQ+  compare Unset (Error _) = LT+  compare Unset Ok = LT+  compare (Error _) Unset = GT+  compare (Error _) (Error _) = GT -- This is a weird one, but last writer wins for errors+  compare (Error _) Ok = LT+  compare Ok Unset = GT+  compare Ok (Error _) = GT+  compare Ok Ok = EQ+  +data ImmutableSpan = ImmutableSpan+  { spanName :: Text+  , spanParent :: Maybe Span+  , spanContext :: SpanContext+  , spanKind :: SpanKind+  , spanStart :: Timestamp+  , spanEnd :: Maybe Timestamp+  , spanAttributes :: Attributes+  , spanLinks :: FrozenBoundedCollection Link+  , spanEvents :: AppendOnlyBoundedCollection Event+  , spanStatus :: SpanStatus+  , spanTracer :: Tracer+  -- ^ Creator of the span+  }++data Span +  = Span (IORef ImmutableSpan)+  | FrozenSpan SpanContext+  | Dropped SpanContext++-- |  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+  deriving (Show, Eq, Ord)++-- | 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.+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.+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.++-- 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+-- `TraceFlags` and system-specific `TraceState` values.++-- `TraceId` A valid trace identifier is a 16-byte array with at least one+-- non-zero byte.++-- `SpanId` A valid span identifier is an 8-byte array with at least one non-zero+-- byte.++-- `TraceFlags` 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](https://www.w3.org/TR/trace-context/#sampled-flag).++-- `TraceState` carries vendor-specific trace identification data, represented as a list+-- of key-value pairs. TraceState allows multiple tracing+-- systems to participate in the same trace. It is fully described in the [W3C Trace Context+-- specification](https://www.w3.org/TR/trace-context/#tracestate-header).++-- The API MUST implement methods to create a `SpanContext`. These methods SHOULD be the only way to+-- create a `SpanContext`. This functionality MUST be fully implemented in the API, and SHOULD NOT be+-- overridable.+data SpanContext = SpanContext+  { traceFlags :: TraceFlags+  , isRemote :: Bool+  , traceId :: TraceId+  , spanId :: SpanId+  , 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)++newtype NonRecordingSpan = NonRecordingSpan SpanContext++data NewEvent = NewEvent+  { newEventName :: Text+  -- ^ The name of an event. Ideally this should be a relatively unique, but low cardinality value.+  , newEventAttributes :: [(Text, Attribute)]+  -- ^ Additional context or metadata related to the event, (stack traces, callsites, etc.).+  , newEventTimestamp :: Maybe Timestamp+  -- ^ The time that the event occurred.+  --+  -- 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.+data Event = Event+  { eventName :: Text+  -- ^ The name of an event. Ideally this should be a relatively unique, but low cardinality value.+  , eventAttributes :: Attributes+  -- ^ Additional context or metadata related to the event, (stack traces, callsites, etc.).+  , eventTimestamp :: Timestamp+  -- ^ The time that the event occurred.+  }+  deriving (Show)++-- | Utility class to format arbitrary values to events.+class ToEvent a where+  -- | Convert a value to an 'Event'+  --+  -- @since 0.0.1.0+  toEvent :: a -> Event++-- | 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.+  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.+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+  , eventCountLimit :: Maybe Int+  , eventAttributeCountLimit :: Maybe Int+  , linkCountLimit :: Maybe Int+  , linkAttributeCountLimit :: Maybe Int+  } deriving (Show, Eq)++defaultSpanLimits :: SpanLimits+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.+getSpanContext :: MonadIO m => Span -> m SpanContext+getSpanContext (Span s) = liftIO (spanContext <$> readIORef s)+getSpanContext (FrozenSpan c) = pure c+getSpanContext (Dropped c) = pure c

@@ -0,0 +1,26 @@+-----------------------------------------------------------------------------+-- |+-- 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

@@ -0,0 +1,71 @@+{-# 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.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. +Each specific Propagator type defines its expected carrier type, such as a string map or a byte array.+-}+data Propagator context inboundCarrier outboundCarrier = Propagator+  { propagatorNames :: [Text]+  , extractor :: inboundCarrier -> context -> IO context+  , 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+    }++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 (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 (Propagator _ _ injector) c = liftIO . injector c

@@ -0,0 +1,170 @@+{-# LANGUAGE DataKinds #-}+{-# 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 +  ( +  -- * Creating resources directly+    mkResource+  , Resource+  , (.=)+  , (.=?)+  , ResourceMerge+  , mergeResources+  -- * Creating resources from data structures+  , ToResource(..)+  , materializeResources+  -- * Using resources with a 'OpenTelemetry.Trace.TracerProvider'+  , MaterializedResources+  , emptyMaterializedResources+  , getMaterializedResourcesSchema+  , getMaterializedResourcesAttributes+  ) where++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. +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+mkResource :: [Maybe (Text, Attribute)] -> Resource r+mkResource = Resource . unsafeAttributesFromListIgnoringLimits . catMaybes++-- | 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'.+(.=?) :: 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.+--+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)+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+emptyMaterializedResources :: MaterializedResources+emptyMaterializedResources = MaterializedResources Nothing emptyAttributes++-- | 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+getMaterializedResourcesAttributes :: MaterializedResources -> Attributes+getMaterializedResourcesAttributes = materializedResourcesAttributes

@@ -0,0 +1,114 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+-----------------------------------------------------------------------------+-- |+-- 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, (.=?))++-- | A cloud infrastructure (e.g. GCP, Azure, AWS).+data Cloud = Cloud+  { cloudProvider :: Maybe Text+  -- ^ Name of the cloud provider.+  --+  -- Examples: @alibaba_cloud@+  --+  -- cloud.provider MUST be one of the following or, if none of the listed values apply, a custom value:+  --+  -- +------------------+------------------------++  -- | Value            | Description            |+  -- +==================+========================++  -- | @alibaba_cloud@  | Alibaba Cloud          |+  -- +------------------+------------------------++  -- | @aws@            | Amazon Web Services    |+  -- +------------------+------------------------++  -- | @azure@          | Microsoft Azure        |+  -- +------------------+------------------------++  -- | @gcp@            | Google Cloud Platform  |+  -- +------------------+------------------------++  -- | @tencent_cloud@  | Tencent Cloud          |+  -- +------------------+------------------------++  --+  , cloudAccountId :: Maybe Text+  -- ^ The cloud account ID the resource is assigned to.+  , cloudRegion :: Maybe Text+  -- ^ The geographical region the resource is running.+  , cloudAvailabilityZone :: Maybe Text+  -- ^ Cloud regions often have multiple, isolated locations known as zones to increase availability. Availability zone represents the zone where the resource is running.+  , cloudPlatform :: Maybe Text+  -- ^ The cloud platform in use.+  --+  -- Example: @alibaba_cloud_ecs@+  --+  -- MUST be one of the following or, if none of the listed values apply, a custom value:+  --+  -- +------------------------------+-------------------------------------------------++  -- | Value                        | Description                                     |+  -- +==============================+=================================================++  -- | @alibaba_cloud_ecs@          | Alibaba Cloud Elastic Compute Service           |+  -- +------------------------------+-------------------------------------------------++  -- | @alibaba_cloud_fc@           | Alibaba Cloud Function Compute                  |+  -- +------------------------------+-------------------------------------------------++  -- | @aws_ec2@                    | AWS Elastic Compute Cloud                       |+  -- +------------------------------+-------------------------------------------------++  -- | @aws_ecs@                    | AWS Elastic Container Service                   |+  -- +------------------------------+-------------------------------------------------++  -- | @aws_eks@                    | AWS Elastic Kubernetes Service                  |+  -- +------------------------------+-------------------------------------------------++  -- | @aws_lambda@                 | AWS Lambda                                      |+  -- +------------------------------+-------------------------------------------------++  -- | @aws_elastic_beanstalk@      | AWS Elastic Beanstalk                           |+  -- +------------------------------+-------------------------------------------------++  -- | @aws_app_runner@             | AWS App Runner                                  |+  -- +------------------------------+-------------------------------------------------++  -- | @azure_vm@                   | Azure Virtual Machines                          |+  -- +------------------------------+-------------------------------------------------++  -- | @azure_container_instances@  | Azure Container Instances                       |+  -- +------------------------------+-------------------------------------------------++  -- | @azure_aks@                  | Azure Kubernetes Service                        |+  -- +------------------------------+-------------------------------------------------++  -- | @azure_functions@            | Azure Functions                                 |+  -- +------------------------------+-------------------------------------------------++  -- | @azure_app_service@          | Azure App Service                               |+  -- +------------------------------+-------------------------------------------------++  -- | @gcp_compute_engine@         | Google Cloud Compute Engine (GCE)               |+  -- +------------------------------+-------------------------------------------------++  -- | @gcp_cloud_run@              | Google Cloud Run                                |+  -- +------------------------------+-------------------------------------------------++  -- | @gcp_kubernetes_engine@      | Google Cloud Kubernetes Engine (GKE)            |+  -- +------------------------------+-------------------------------------------------++  -- | @gcp_cloud_functions@        | Google Cloud Functions (GCF)                    |+  -- +------------------------------+-------------------------------------------------++  -- | @gcp_app_engine@             | Google Cloud App Engine (GAE)                   |+  -- +------------------------------+-------------------------------------------------++  -- | @tencent_cloud_cvm@          | Tencent Cloud Cloud Virtual Machine (CVM)       |+  -- +------------------------------+-------------------------------------------------++  -- | @tencent_cloud_eks@          | Tencent Cloud Elastic Kubernetes Service (EKS)  |+  -- +------------------------------+-------------------------------------------------++  -- | @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+    ]

@@ -0,0 +1,42 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+-----------------------------------------------------------------------------+-- |+-- 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+  -- ^ Container name used by container runtime.+  --+  -- Examples: 'opentelemetry-autoconf'+  , containerId :: Maybe Text+  -- ^ Container ID. Usually a UUID, as for example used to identify Docker containers. The UUID might be abbreviated.+  , containerRuntime :: Maybe Text+  -- ^ The container runtime managing this container.+  , containerImageName :: Maybe Text+  -- ^ Name of the image the container was built on.+  , containerImageTag :: Maybe Text+  -- ^ 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+    ]

@@ -0,0 +1,34 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+-----------------------------------------------------------------------------+-- |+-- 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.+newtype DeploymentEnvironment = DeploymentEnvironment+  { deploymentEnvironment :: Maybe Text+  -- ^ 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+    ]

@@ -0,0 +1,14 @@+-----------------------------------------------------------------------------+-- |+-- 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

@@ -0,0 +1,69 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+-----------------------------------------------------------------------------+-- |+-- 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.  +  --+  --  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. +  --+  -- Depending on the cloud provider, use:+  --+  -- - AWS Lambda: The function ARN. Take care not to use the "invoked ARN" directly but replace any alias suffix with the resolved function version, as the same runtime instance may be invokable with multiple different aliases.+  -- - GCP: The URI of the resource+  -- - Azure: The Fully Qualified Resource ID.+  --+  -- Examples: 'arn:aws:lambda:us-west-2:123456789012:function:my-function'+  , faasVersion :: Maybe Text+  -- ^ The immutable version of the function being executed.+  --+  -- Depending on the cloud provider and platform, use:+  --+  -- - AWS Lambda: The function version (an integer represented as a decimal string).+  -- - Google Cloud Run: The revision (i.e., the function name plus the revision suffix).+  -- - Google Cloud Functions: The value of the K_REVISION environment variable.+  -- - Azure Functions: Not applicable. Do not set this attribute.+  --+  -- Examples: '26', 'pinkfroid-00002'+  , faasInstance :: Maybe Text+  -- ^ The execution environment ID as a string, that will be potentially reused for other invocations to the same function/function version.+  --+  -- AWS Lambda: Use the (full) log stream name.+  --+  -- Examples: '2021/06/28/[$LATEST]2f399eb14537447da05ab2a2e39309de'+  , faasMaxMemory :: Maybe Int+  -- ^ The amount of memory available to the serverless function in MiB.+  --+  -- It's recommended to set this attribute since e.g. too little memory can easily an AWS Lambda function from working correctly. On AWS Lambda, the environment variable AWS_LAMBDA_FUNCTION_MEMORY_SIZE provides this information.+  --+  -- 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+    ]

@@ -0,0 +1,48 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+-----------------------------------------------------------------------------+-- |+-- 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, (.=?))++-- | A host is defined as a general computing instance.+data Host = Host+  { hostId :: Maybe Text+  -- ^ Unique host ID. For Cloud, this must be the instance_id assigned by the cloud provider.+  , hostName :: Maybe Text+  -- ^ Name of the host. On Unix systems, it may contain what the hostname command returns, or the fully qualified hostname, or another name specified by the user.+  , hostType :: Maybe Text+  -- ^ Type of host. For Cloud, this must be the machine type.+  , hostArch :: Maybe Text+  -- ^ The CPU architecture the host system is running on.+  , hostImageName :: Maybe Text+  -- ^ Name of the VM image or OS install the host was instantiated from.+  , hostImageId :: Maybe Text+  -- ^ VM image ID. For Cloud, this value is from the provider.+  , hostImageVersion :: Maybe Text+  -- ^ 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+    ]

@@ -0,0 +1,169 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+-----------------------------------------------------------------------------+-- |+-- 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]++-- | 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+    ]++-- | 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+    ]++-- | The smallest and simplest Kubernetes object. A Pod represents a set of running containers on your cluster.+data Pod = Pod+  { podName :: Maybe Text+  -- ^ The name of the Pod.+  , podUid :: Maybe Text+  -- ^ The UID of the Pod.+  }++instance ToResource Pod where+  type ResourceSchema Pod = 'Nothing+  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).	+  , 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.	+  }++instance ToResource Container where+  type ResourceSchema Container = 'Nothing+  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+    ]++-- | 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+  -- ^ The UID of the Deployment.+  , deploymentName :: Maybe Text+  -- ^ The name of the Deployment.+  }++instance ToResource Deployment where+  type ResourceSchema Deployment = 'Nothing+  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+  -- ^ The UID of the StatefulSet.+  , statefulSetName :: Maybe Text+  -- ^ The name of the StatefulSet.+  }++instance ToResource StatefulSet where+  type ResourceSchema StatefulSet = 'Nothing+  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.	+  , 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+    ]++-- | A Job creates one or more Pods and ensures that a specified number of them successfully terminate.+data Job = Job+  { jobUid :: Maybe Text+  -- ^ The UID of the Job.+  , jobName :: Maybe Text+  -- ^ The name of the Job.+  }++instance ToResource Job where+  type ResourceSchema Job = 'Nothing+  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+  -- ^ The UID of the CronJob.+  , cronJobName :: Maybe Text+  -- ^ The name of the CronJob.+  }++instance ToResource CronJob where+  type ResourceSchema CronJob = 'Nothing+  toResource CronJob{..} = mkResource+    [ "k8s.cronjob.name" .=? cronJobName+    , "k8s.cronjob.uid" .=? cronJobUid+    ]

@@ -0,0 +1,69 @@+{-# 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 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+  -- ^ The operating system type.+  --+  -- MUST be one of the following or, if none of the listed values apply, a custom value:+  --+  -- +-----------------+---------------------------------------++  -- | Value           | Description                           |+  -- +=================+=======================================++  -- | @windows@       | Microsoft Windows                     |+  -- +-----------------+---------------------------------------++  -- | @linux@         | Linux                                 |+  -- +-----------------+---------------------------------------++  -- | @darwin@        | Apple Darwin                          |+  -- +-----------------+---------------------------------------++  -- | @freebsd@       | FreeBSD                               |+  -- +-----------------+---------------------------------------++  -- | @netbsd@        | NetBSD                                |+  -- +-----------------+---------------------------------------++  -- | @openbsd@       | OpenBSD                               |+  -- +-----------------+---------------------------------------++  -- | @dragonflybsd@  | DragonFly BSD                         |+  -- +-----------------+---------------------------------------++  -- | @hpux@          | HP-UX (Hewlett Packard Unix)          |+  -- +-----------------+---------------------------------------++  -- | @aix@           | AIX (Advanced Interactive eXecutive)  |+  -- +-----------------+---------------------------------------++  -- | @solaris@       | Oracle Solaris                        |+  -- +-----------------+---------------------------------------++  -- | @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+  -- ^ Human readable operating system name.+  , osVersion :: Maybe Text+  -- ^ 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+    ]

@@ -0,0 +1,85 @@+{-# 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 where+import Data.Text (Text)+import OpenTelemetry.Resource++-- |  An operating system process.+data Process = Process+  { processPid :: Maybe Int+  -- ^ Process identifier (PID).+  --+  -- Example: @1234@+  , processExecutableName :: Maybe Text+  -- ^ The name of the process executable. On Linux based systems, can be set to the @Name@ in @proc/[pid]/status@. On Windows, can be set to the base name of @GetProcessImageFileNameW@.+  --+  -- Example: @otelcol@+  , processExecutablePath :: Maybe Text+  -- ^ The full path to the process executable. On Linux based systems, can be set to the target of @proc/[pid]/exe@. On Windows, can be set to the result of @GetProcessImageFileNameW@.+  --+  -- Example: @/usr/bin/cmd/otelcol@+  , processCommand :: Maybe Text+  -- ^ The command used to launch the process (i.e. the command name). On Linux based systems, can be set to the zeroth string in @proc/[pid]/cmdline@. On Windows, can be set to the first parameter extracted from @GetCommandLineW@.+  --+  -- Example: @cmd/otelcol@+  , processCommandLine :: Maybe Text+  -- ^ The full command used to launch the process as a single string representing the full command. On Windows, can be set to the result of @GetCommandLineW@. Do not set this if you have to assemble it just for monitoring; use @process.command_args@ instead.+  --+  -- 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.	+  --+  -- Example: @[cmd/otecol, --config=config.yaml]@+  , processOwner :: Maybe Text+  -- ^ 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+    ]++-- | 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.	+  --+  -- Example: @OpenJDK Runtime Environment@+  , processRuntimeVersion :: Maybe Text+  -- ^ The version of the runtime of this process, as returned by the runtime without modification.	+  --+  -- Example: @14.0.2@+  , processRuntimeDescription :: Maybe Text+  -- ^ An additional description about the runtime of the process, for example a specific vendor customization of the runtime environment.+  --+  -- 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+    ]

@@ -0,0 +1,54 @@+{-# 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 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, +  -- 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+  -- @OTEL_SERVICE_NAME@ environment variable+  --+  -- Example: @shoppingcart@+  , serviceNamespace :: Maybe Text+  -- ^ A namespace for service.name.+  --+  -- A string value having a meaning that helps to distinguish a group of services, for example the team name that owns a group of services. service.name is expected to be unique within the same namespace. If service.namespace is not specified in the Resource then service.name is expected to be unique for all services that have no explicit namespace defined (so the empty/unspecified namespace is simply one more valid namespace). Zero-length namespace string is assumed equal to unspecified namespace.+  --+  -- Example: @Shop@+  , serviceInstanceId :: Maybe Text+  -- ^ The string ID of the service instance.+  --+  -- Example: @627cc493-f310-47de-96bd-71410b7dec09@+  , serviceVersion :: Maybe Text+  -- ^ The version string of the service API or implementation.+  --+  -- 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+    ]

@@ -0,0 +1,62 @@+{-# 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 where+import Data.Text ( Text )+import OpenTelemetry.Resource++-- - id: cpp+--   value: "cpp"+-- - id: dotnet+--   value: "dotnet"+-- - id: erlang+--   value: "erlang"+-- - id: go+--   value: "go"+-- - id: java+--   value: "java"+-- - id: nodejs+--   value: "nodejs"+-- - id: php+--   value: "php"+-- - id: python+--   value: "python"+-- - id: ruby+--   value: "ruby"+-- - id: webjs+--   value: "webjs"+-- other allowed++-- | The telemetry SDK used to capture data recorded by the instrumentation libraries.+data Telemetry = Telemetry+  { telemetrySdkName :: Text+  -- ^ The name of the telemetry SDK as defined above.+  , telemetrySdkLanguage :: Maybe Text+  -- ^ The name of the telemetry SDK as defined above.+  , telemetrySdkVersion :: Maybe Text+  -- ^ The version string of the telemetry SDK.+  , telemetryAutoVersion :: Maybe Text+  --- ^ The version string of the auto instrumentation agent, if used.++  }++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+    ]

@@ -0,0 +1,14 @@+-----------------------------------------------------------------------------+-- |+-- 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

@@ -0,0 +1,681 @@+{-# 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 spans in OpenTelemetry, the 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 tracers 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(..)+  , 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(..)+  , 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(..))+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.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.Exception (SomeException(..))+import Control.Monad.IO.Unlift+-- | 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+    (fn, loc):_ -> args+      { attributes = +            ("code.function", toAttribute $ T.pack fn)+          : ("code.namespace", toAttribute $ T.pack $ srcLocModule loc)+          : ("code.filepath", toAttribute $ T.pack $ srcLocFile loc)+          : ("code.lineno", toAttribute $ srcLocStartLine loc)+          : ("code.package", toAttribute $ T.pack $ srcLocPackage loc)+          : attributes 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 links+                  , spanEvents = emptyAppendOnlyBoundedCollection $ fromMaybe 128 (eventCountLimit $ tracerProviderSpanLimits $ tracerProvider t)+                  , spanStatus = Unset+                  , spanStart = st+                  , spanEnd = Nothing+                  , spanTracer = t+                  }+            s <- newIORef is+            mapM_ (\processor -> processorOnStart processor s ctxt) $ tracerProviderProcessors $ tracerProvider t+            pure $ Span s++      case samplingOutcome of+        Drop -> pure $ Dropped ctxtForSpan+        RecordOnly -> mkRecordingSpan+        RecordAndSample -> mkRecordingSpan++inSpan+  :: (MonadUnliftIO m, HasCallStack)+  => Tracer+  -> Text+  -> SpanArguments+  -> m a+  -> m a+inSpan t n args m = inSpan'' t callStack n args (const m)++inSpan'+  :: (MonadUnliftIO m, HasCallStack)+  => Tracer+  -> Text+  -> SpanArguments+  -> (Span -> m a)+  -> m a+inSpan' t = inSpan'' t callStack++inSpan''+  :: (MonadUnliftIO m, HasCallStack)+  => Tracer+  -> CallStack+  -> 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 ctx (\p -> insertSpan p 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++{- |+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.+-}+addAttribute :: MonadIO m => A.ToAttribute a => Span -> Text -> 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 ()++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 ()++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.+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+    mapM_ (`processorOnEnd` s) $ tracerProviderProcessors $ tracerProvider $ spanTracer frozenS+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+  }++emptyTracerProviderOptions :: TracerProviderOptions+emptyTracerProviderOptions = TracerProviderOptions +  dummyIdGenerator +  (parentBased $ parentBasedOptions alwaysOn) +  emptyMaterializedResources +  defaultAttributeLimits +  defaultSpanLimits+  mempty++-- | 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)++getGlobalTracerProvider :: MonadIO m => m TracerProvider+getGlobalTracerProvider = liftIO $ readIORef globalTracer++setGlobalTracerProvider :: MonadIO m => TracerProvider -> m ()+setGlobalTracerProvider = liftIO . writeIORef globalTracer++getTracerProviderResources :: TracerProvider -> MaterializedResources+getTracerProviderResources = tracerProviderResources++getTracerProviderPropagators :: TracerProvider -> Propagator Context RequestHeaders ResponseHeaders+getTracerProviderPropagators = tracerProviderPropagators++newtype TracerOptions = TracerOptions+  { tracerSchema :: Maybe Text+  }++tracerOptions :: TracerOptions+tracerOptions = TracerOptions Nothing++class HasTracer s where+  tracerL :: Lens' s Tracer++getTracer :: MonadIO m => TracerProvider -> InstrumentationLibrary -> TracerOptions -> m Tracer+getTracer tp n TracerOptions{} = liftIO $ do+  pure $ Tracer n tp++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

@@ -0,0 +1,332 @@+{-# 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+++-- | bytes pointed to by src to the hexadecimal binary representation.+toHexadecimal :: ShortByteString -- ^ source bytes+              -> ShortByteString -- ^ hexadecimal output+toHexadecimal (SBS bin) = runST $ ST $ \s ->+  case newByteArray# (n *# 2# ) s of+    (# s1, mba #) -> case loop 0# mba s1 of+      s2 -> case unsafeFreezeByteArray# mba s2 of+        (# s3, ba #) -> (# s3, SBS ba #)+  where+    !n = sizeofByteArray# bin+    loop i bout s+      | isTrue# (i ==# n) = s+      | otherwise = do+          let !w = indexWord8Array# bin i+          let !(# w1, w2 #) = convertByte w+          case writeWord8Array# bout (i *# 2#) w1 s of+            s1 -> case writeWord8Array# bout ((i *# 2#) +# 1#) w2 s1 of+              s2 -> loop (i +# 1#) bout s2++-- | Convert a value Word# to two Word#s containing+-- the hexadecimal representation of the Word#+convertByte :: Word# -> (# Word#, Word# #)+convertByte b = (# r tableHi b, r tableLo b #)+  where+        r :: Addr# -> Word# -> Word#+        r table ix = indexWord8OffAddr# table (word2Int# ix)++        !tableLo =+            "0123456789abcdef0123456789abcdef\+            \0123456789abcdef0123456789abcdef\+            \0123456789abcdef0123456789abcdef\+            \0123456789abcdef0123456789abcdef\+            \0123456789abcdef0123456789abcdef\+            \0123456789abcdef0123456789abcdef\+            \0123456789abcdef0123456789abcdef\+            \0123456789abcdef0123456789abcdef"#+        !tableHi =+            "00000000000000001111111111111111\+            \22222222222222223333333333333333\+            \44444444444444445555555555555555\+            \66666666666666667777777777777777\+            \88888888888888889999999999999999\+            \aaaaaaaaaaaaaaaabbbbbbbbbbbbbbbb\+            \ccccccccccccccccdddddddddddddddd\+            \eeeeeeeeeeeeeeeeffffffffffffffff"#+{-# INLINE convertByte #-}++-- | Convert a base16 @src to the byte equivalent.+--+-- length of the 'ShortByteString' input must be even+--+-- TODO, not working right+fromHexadecimal :: ShortByteString -> (Maybe ShortByteString)+fromHexadecimal src@(SBS sbs)+  | odd (length src) = Nothing+  | otherwise = runST $ ST $ \s -> case newByteArray# newLen# s of+      (# s1, dst #) -> case loop dst 0# 0# s1 of+        (# s2, Just _ #) -> (# s2, Nothing #)+        (# s2, Nothing #) -> case unsafeFreezeByteArray# dst s2 of+          (# s3, sbs' #) -> (# s3, Just $ SBS sbs' #)+  where+    !(I# newLen#) = length src `div` 2+    loop dst di i s+      | isTrue# (i ==# newLen#) = (# s, Nothing #)+      | otherwise = do+        let a = rHi (indexWord8Array# sbs i)+        let b = rLo (indexWord8Array# sbs (i +# 1#))+        if isTrue# (eqWord# a (int2Word# 0xff#)) || isTrue# (eqWord# b (int2Word# 0xff#))+            then (# s, Just (I# i) #)+            else+              case writeWord8Array# dst di (or# a b) s of+                s1 -> loop dst (di +# 1#) (i +# 2#) s1++    rLo ix = indexWord8OffAddr# tableLo (word2Int# ix)+    rHi ix = indexWord8OffAddr# tableHi (word2Int# ix)++    !tableLo =+            "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+              \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+              \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+              \\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\xff\xff\xff\xff\xff\xff\+              \\xff\x0a\x0b\x0c\x0d\x0e\x0f\xff\xff\xff\xff\xff\xff\xff\xff\xff\+              \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+              \\xff\x0a\x0b\x0c\x0d\x0e\x0f\xff\xff\xff\xff\xff\xff\xff\xff\xff\+              \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+              \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+              \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+              \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+              \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+              \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+              \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+              \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+              \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#+    !tableHi =+            "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+              \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+              \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+              \\x00\x10\x20\x30\x40\x50\x60\x70\x80\x90\xff\xff\xff\xff\xff\xff\+              \\xff\xa0\xb0\xc0\xd0\xe0\xf0\xff\xff\xff\xff\xff\xff\xff\xff\xff\+              \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+              \\xff\xa0\xb0\xc0\xd0\xe0\xf0\xff\xff\xff\xff\xff\xff\xff\xff\xff\+              \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+              \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+              \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+              \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+              \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+              \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+              \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+              \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+              \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#++-- | 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#+        (indexWord64Array# arr 0#)+        (indexWord64Array# arr 1#))+      (int2Word# 0#))++-- | 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+isEmptySpanId (SpanId (SBS arr)) = isTrue#+  (eqWord#+    (indexWord64Array# arr 0#)+    (int2Word# 0#))++-- | 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

@@ -0,0 +1,30 @@+-----------------------------------------------------------------------------+-- |+-- 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.+data IdGenerator = IdGenerator+  { generateSpanIdBytes :: IO ByteString+    -- ^ MUST generate exactly 8 bytes+  , generateTraceIdBytes :: IO ByteString+    -- ^ MUST generate exactly 16 bytes+  }

@@ -0,0 +1,10 @@+module OpenTelemetry.Trace.Id.Generator.Dummy where++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"+  }

@@ -0,0 +1,75 @@+{-# 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''+  -- Interacting with the span in the current context+  -- , getSpan+  -- , updateName+  -- , addAttribute+  -- , addAttributes+  -- , getAttributes+  -- , addEvent+  -- , NewEvent (..)+  -- Fundamental monad instances+  , MonadTracer(..)+  ) where++import Data.Text (Text)+import OpenTelemetry.Trace.Core+  ( Tracer+  , Span+  , SpanArguments(..)+  , inSpan''+  )+import Control.Monad.IO.Unlift+import GHC.Stack++-- | 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 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' = OpenTelemetry.Trace.Monad.inSpan'' callStack++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

@@ -0,0 +1,173 @@+-----------------------------------------------------------------------------+-- |+-- 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(..),+  parentBased,+  parentBasedOptions,+  ParentBasedOptions(..),+  traceIdRatioBased,+  alwaysOn,+  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.Context+import OpenTelemetry.Internal.Trace.Types+import OpenTelemetry.Trace.TraceState as TraceState+import OpenTelemetry.Attributes (toAttribute)++-- | 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)+  }++-- | Returns @RecordAndSample@ 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)+  }++-- | 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+  where+    safeFraction = max fraction 0+    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)+      }++-- | 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+  -- ^ default: alwaysOn+  , remoteParentNotSampled :: Sampler+  -- ^ default: alwaysOff+  , localParentSampled :: Sampler+  -- ^ default: alwaysOn+  , localParentNotSampled :: Sampler+  -- ^ 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+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+  }

@@ -0,0 +1,73 @@+-----------------------------------------------------------------------------+-- |+-- 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++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.+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)+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 :: 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)+delete :: Key -> TraceState -> TraceState+delete k (TraceState ts) = TraceState $ filter (\(k', _) -> k' /= k) ts++-- | Convert the 'TraceState' to a list.+--+-- O(1)+toList :: TraceState -> [(Key, Value)]+toList (TraceState ts) = ts

@@ -0,0 +1,144 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# 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+  -- * Data structures+  , AppendOnlyBoundedCollection+  , emptyAppendOnlyBoundedCollection+  , appendToBoundedCollection+  , appendOnlyBoundedCollectionSize+  , appendOnlyBoundedCollectionValues+  , appendOnlyBoundedCollectionDroppedElementCount+  , FrozenBoundedCollection+  , frozenBoundedCollection+  , frozenBoundedCollectionValues+  , frozenBoundedCollectionDroppedElementCount+  ) where++import Data.Foldable+import Data.Kind+import qualified Data.Vector as V+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++-- | 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++foreign import ccall unsafe "rts_getThreadId" c_getThreadId :: ThreadId# -> CInt++-- | Get an int representation of a thread id+getThreadId :: ThreadId -> Int+getThreadId (ThreadId tid#) = fromIntegral (c_getThreadId tid#)+{-# INLINE getThreadId #-}++data AppendOnlyBoundedCollection a = AppendOnlyBoundedCollection +  { collection :: Builder a+  , maxSize :: {-# UNPACK #-} !Int+  , dropped :: {-# UNPACK #-} !Int+  }++-- | Initialize a bounded collection that admits a maximum size+emptyAppendOnlyBoundedCollection :: +     Int+  -- ^ Maximum size+  -> 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)++data FrozenBoundedCollection a = FrozenBoundedCollection+  { collection :: !(V.Vector a)+  , dropped :: !Int+  }++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+bracketError :: MonadUnliftIO m => m a -> (Maybe SomeException -> a -> m b) -> (a -> m c) -> m c+bracketError before after thing = withRunInIO $ \run -> EUnsafe.mask $ \restore -> do+  x <- run before+  res1 <- EUnsafe.try $ restore $ run $ thing x+  case res1 of+    Left (e1 :: SomeException) -> do+      -- explicitly ignore exceptions from after. We know that+      -- no async exceptions were thrown there, so therefore+      -- the stronger exception must come from thing+      --+      -- https://github.com/fpco/safe-exceptions/issues/2+      _ :: Either SomeException b <-+          EUnsafe.try $ EUnsafe.uninterruptibleMask_ $ run $ after (Just e1) x+      EUnsafe.throwIO e1+    Right y -> do+      _ <- EUnsafe.uninterruptibleMask_ $ run $ after Nothing x+      return y

@@ -0,0 +1,122 @@+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++builtInNonCompositeSamplers :: [Sampler]+builtInNonCompositeSamplers =+  [ alwaysOff+  , alwaysOn+  , traceIdRatioBased 0.99+  ]++-- TODO, these would largely be good candidates for quickcheck+spec :: Spec+spec = describe "Sampler" $ do+  describe "built-in non-composite samplers" $ do+    forM_ builtInNonCompositeSamplers $ \sampler -> do+      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+              }+            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+            }+          traceParent = wrapSpanContext remoteSpan+          parentContext = Context.insertSpan traceParent Context.empty+      (res, _, _) <- shouldSample alwaysOff parentContext aTraceId "test" defaultSpanArguments+      res `shouldBe` Drop++  describe "alwaysOn" $ do+    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+            }+          traceParent = wrapSpanContext remoteSpan+          parentContext = Context.insertSpan traceParent Context.empty+      (res, _, _) <- shouldSample alwaysOn parentContext aTraceId "test" defaultSpanArguments+      res `shouldBe` RecordAndSample++  describe "traceIdRatioBased" $ do+    it "drops spans that are outside of the sample ratio" $ do+      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+            }+          traceParent = wrapSpanContext remoteSpan+          parentContext = Context.insertSpan traceParent Context.empty+      (res, _, _) <- shouldSample sampler parentContext aTraceId "test" defaultSpanArguments+      res `shouldBe` Drop+    it "samples spans that are within the sample ratio" $ do+      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+            }+          traceParent = wrapSpanContext remoteSpan+          parentContext = Context.insertSpan traceParent Context.empty+      (res, _, _) <- shouldSample sampler parentContext aTraceId "test" defaultSpanArguments+      res `shouldBe` RecordAndSample+    it "higher sample ratios sample spans that are also by lower ratios" $ do+      let conservativeSampler = traceIdRatioBased 0.5+          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+            }+          traceParent = wrapSpanContext remoteSpan+          parentContext = Context.insertSpan traceParent Context.empty+      do+        (resConservative, _, _) <- shouldSample permissiveSampler parentContext aTraceId "test" defaultSpanArguments+        (resPermissive, _, _) <- shouldSample conservativeSampler parentContext aTraceId "test" defaultSpanArguments+        resConservative `shouldBe` RecordAndSample+        resPermissive `shouldBe` RecordAndSample+    +    

@@ -0,0 +1,13 @@+module OpenTelemetry.Trace.TraceFlagsSpec where++import OpenTelemetry.Trace.Core+import Test.Hspec++spec :: Spec+spec = describe "TraceFlags" $ do+  it "starts unsampled by default" $ do+    defaultTraceFlags `shouldSatisfy` (not . isSampled)+  specify "setSampled updates flags correctly" $ do+    setSampled defaultTraceFlags `shouldSatisfy` isSampled+  specify "unsetSampled updates flags correctly" $ do+    unsetSampled (setSampled defaultTraceFlags) `shouldSatisfy` (not . isSampled)

@@ -0,0 +1,48 @@+{-# 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 Data.IORef+import Data.Maybe (isJust)+import qualified Data.Vector as V+import qualified VectorBuilder.Vector as Builder+-- Specs+import qualified OpenTelemetry.Trace.TraceFlagsSpec as TraceFlags+import qualified OpenTelemetry.Trace.SamplerSpec as Sampler+import OpenTelemetry.Util++newtype TestException = TestException String+  deriving (Show)++instance Exception TestException++exceptionTest :: IO ()+exceptionTest = do+  tp <- getGlobalTracerProvider+  t <- OpenTelemetry.Trace.Core.getTracer tp "test" tracerOptions+  spanToCheck <- newIORef undefined+  handle (\(TestException _) -> pure ()) $ do+    inSpan' t "test" defaultSpanArguments $ \span -> do+      liftIO $ writeIORef spanToCheck span+      throw $ TestException "wow"+  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")++main :: IO ()+main = hspec $ do+  -- describe "inSpan" $ do+  --   it "records exceptions" $ do+  --     exceptionTest+  Sampler.spec+  TraceFlags.spec