{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module OpenTelemetry.Propagator.W3CTraceContext where
import Data.Attoparsec.ByteString.Char8 (
Parser,
hexadecimal,
parseOnly,
string,
takeWhile,
)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Lazy as L
import Data.Char (isHexDigit)
import Data.Word (Word8)
import Network.HTTP.Types (RequestHeaders, ResponseHeaders)
import qualified OpenTelemetry.Context as Ctxt
import OpenTelemetry.Propagator (Propagator (..))
import OpenTelemetry.Trace.Core (
Span,
SpanContext (..),
TraceFlags,
getSpanContext,
traceFlagsFromWord8,
traceFlagsValue,
wrapSpanContext,
)
import OpenTelemetry.Trace.Id (Base (..), SpanId, TraceId, baseEncodedToSpanId, baseEncodedToTraceId, spanIdBaseEncodedBuilder, traceIdBaseEncodedBuilder)
import OpenTelemetry.Trace.TraceState (TraceState, empty)
import Prelude hiding (takeWhile)
data TraceParent = TraceParent
{ TraceParent -> Word8
version :: {-# UNPACK #-} !Word8
, TraceParent -> TraceId
traceId :: {-# UNPACK #-} !TraceId
, TraceParent -> SpanId
parentId :: {-# UNPACK #-} !SpanId
, TraceParent -> TraceFlags
traceFlags :: {-# UNPACK #-} !TraceFlags
}
deriving (Int -> TraceParent -> ShowS
[TraceParent] -> ShowS
TraceParent -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TraceParent] -> ShowS
$cshowList :: [TraceParent] -> ShowS
show :: TraceParent -> String
$cshow :: TraceParent -> String
showsPrec :: Int -> TraceParent -> ShowS
$cshowsPrec :: Int -> TraceParent -> ShowS
Show)
decodeSpanContext
:: Maybe ByteString
-> Maybe ByteString
-> Maybe SpanContext
decodeSpanContext :: Maybe ByteString -> Maybe ByteString -> Maybe SpanContext
decodeSpanContext Maybe ByteString
Nothing Maybe ByteString
_ = forall a. Maybe a
Nothing
decodeSpanContext (Just ByteString
traceparentHeader) Maybe ByteString
mTracestateHeader = do
TraceParent {Word8
TraceId
SpanId
TraceFlags
traceFlags :: TraceFlags
parentId :: SpanId
traceId :: TraceId
version :: Word8
traceFlags :: TraceParent -> TraceFlags
parentId :: TraceParent -> SpanId
traceId :: TraceParent -> TraceId
version :: TraceParent -> Word8
..} <- ByteString -> Maybe TraceParent
decodeTraceparentHeader ByteString
traceparentHeader
TraceState
ts <- case Maybe ByteString
mTracestateHeader of
Maybe ByteString
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TraceState
empty
Just ByteString
tracestateHeader -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ByteString -> TraceState
decodeTracestateHeader ByteString
tracestateHeader
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
SpanContext
{ traceFlags :: TraceFlags
traceFlags = TraceFlags
traceFlags
, isRemote :: Bool
isRemote = Bool
True
, traceId :: TraceId
traceId = TraceId
traceId
, spanId :: SpanId
spanId = SpanId
parentId
, traceState :: TraceState
traceState = TraceState
ts
}
where
decodeTraceparentHeader :: ByteString -> Maybe TraceParent
decodeTraceparentHeader :: ByteString -> Maybe TraceParent
decodeTraceparentHeader ByteString
tp = case forall a. Parser a -> ByteString -> Either String a
parseOnly Parser TraceParent
traceparentParser ByteString
tp of
Left String
_ -> forall a. Maybe a
Nothing
Right TraceParent
ok -> forall a. a -> Maybe a
Just TraceParent
ok
decodeTracestateHeader :: ByteString -> TraceState
decodeTracestateHeader :: ByteString -> TraceState
decodeTracestateHeader ByteString
_ = TraceState
empty
traceparentParser :: Parser TraceParent
traceparentParser :: Parser TraceParent
traceparentParser = do
Word8
version <- forall a. (Integral a, Bits a) => Parser a
hexadecimal
ByteString
_ <- ByteString -> Parser ByteString
string ByteString
"-"
ByteString
traceIdBs <- (Char -> Bool) -> Parser ByteString
takeWhile Char -> Bool
isHexDigit
TraceId
traceId <- case Base -> ByteString -> Either String TraceId
baseEncodedToTraceId Base
Base16 ByteString
traceIdBs of
Left String
err -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
Right TraceId
ok -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TraceId
ok
ByteString
_ <- ByteString -> Parser ByteString
string ByteString
"-"
ByteString
parentIdBs <- (Char -> Bool) -> Parser ByteString
takeWhile Char -> Bool
isHexDigit
SpanId
parentId <- case Base -> ByteString -> Either String SpanId
baseEncodedToSpanId Base
Base16 ByteString
parentIdBs of
Left String
err -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
Right SpanId
ok -> forall (f :: * -> *) a. Applicative f => a -> f a
pure SpanId
ok
ByteString
_ <- ByteString -> Parser ByteString
string ByteString
"-"
TraceFlags
traceFlags <- Word8 -> TraceFlags
traceFlagsFromWord8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Integral a, Bits a) => Parser a
hexadecimal
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ TraceParent {Word8
TraceId
SpanId
TraceFlags
traceFlags :: TraceFlags
parentId :: SpanId
traceId :: TraceId
version :: Word8
traceFlags :: TraceFlags
parentId :: SpanId
traceId :: TraceId
version :: Word8
..}
encodeSpanContext :: Span -> IO (ByteString, ByteString)
encodeSpanContext :: Span -> IO (ByteString, ByteString)
encodeSpanContext Span
s = do
SpanContext
ctxt <- forall (m :: * -> *). MonadIO m => Span -> m SpanContext
getSpanContext Span
s
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> ByteString
L.toStrict forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
B.toLazyByteString forall a b. (a -> b) -> a -> b
$ SpanContext -> Builder
traceparentHeader SpanContext
ctxt, ByteString
"")
where
traceparentHeader :: SpanContext -> Builder
traceparentHeader SpanContext {Bool
TraceState
TraceId
SpanId
TraceFlags
traceState :: TraceState
spanId :: SpanId
traceId :: TraceId
isRemote :: Bool
traceFlags :: TraceFlags
traceState :: SpanContext -> TraceState
spanId :: SpanContext -> SpanId
traceId :: SpanContext -> TraceId
isRemote :: SpanContext -> Bool
traceFlags :: SpanContext -> TraceFlags
..} =
Word8 -> Builder
B.word8HexFixed Word8
0
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
B.char7 Char
'-'
forall a. Semigroup a => a -> a -> a
<> Base -> TraceId -> Builder
traceIdBaseEncodedBuilder Base
Base16 TraceId
traceId
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
B.char7 Char
'-'
forall a. Semigroup a => a -> a -> a
<> Base -> SpanId -> Builder
spanIdBaseEncodedBuilder Base
Base16 SpanId
spanId
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
B.char7 Char
'-'
forall a. Semigroup a => a -> a -> a
<> Word8 -> Builder
B.word8HexFixed (TraceFlags -> Word8
traceFlagsValue TraceFlags
traceFlags)
w3cTraceContextPropagator :: Propagator Ctxt.Context RequestHeaders ResponseHeaders
w3cTraceContextPropagator :: Propagator Context RequestHeaders RequestHeaders
w3cTraceContextPropagator = Propagator {[Text]
forall {a}.
IsString a =>
Context -> [(a, ByteString)] -> IO [(a, ByteString)]
forall {f :: * -> *} {a}.
(Applicative f, Eq a, IsString a) =>
[(a, ByteString)] -> Context -> f Context
propagatorNames :: [Text]
extractor :: RequestHeaders -> Context -> IO Context
injector :: Context -> RequestHeaders -> IO RequestHeaders
injector :: forall {a}.
IsString a =>
Context -> [(a, ByteString)] -> IO [(a, ByteString)]
extractor :: forall {f :: * -> *} {a}.
(Applicative f, Eq a, IsString a) =>
[(a, ByteString)] -> Context -> f Context
propagatorNames :: [Text]
..}
where
propagatorNames :: [Text]
propagatorNames = [Text
"tracecontext"]
extractor :: [(a, ByteString)] -> Context -> f Context
extractor [(a, ByteString)]
hs Context
c = do
let traceParentHeader :: Maybe ByteString
traceParentHeader = forall a b. Eq a => a -> [(a, b)] -> Maybe b
Prelude.lookup a
"traceparent" [(a, ByteString)]
hs
traceStateHeader :: Maybe ByteString
traceStateHeader = forall a b. Eq a => a -> [(a, b)] -> Maybe b
Prelude.lookup a
"tracestate" [(a, ByteString)]
hs
mspanContext :: Maybe SpanContext
mspanContext = Maybe ByteString -> Maybe ByteString -> Maybe SpanContext
decodeSpanContext Maybe ByteString
traceParentHeader Maybe ByteString
traceStateHeader
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! case Maybe SpanContext
mspanContext of
Maybe SpanContext
Nothing -> Context
c
Just SpanContext
s -> Span -> Context -> Context
Ctxt.insertSpan (SpanContext -> Span
wrapSpanContext (SpanContext
s {isRemote :: Bool
isRemote = Bool
True})) Context
c
injector :: Context -> [(a, ByteString)] -> IO [(a, ByteString)]
injector Context
c [(a, ByteString)]
hs = case Context -> Maybe Span
Ctxt.lookupSpan Context
c of
Maybe Span
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [(a, ByteString)]
hs
Just Span
s -> do
(ByteString
traceParentHeader, ByteString
traceStateHeader) <- Span -> IO (ByteString, ByteString)
encodeSpanContext Span
s
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( (a
"traceparent", ByteString
traceParentHeader)
forall a. a -> [a] -> [a]
: (a
"tracestate", ByteString
traceStateHeader)
forall a. a -> [a] -> [a]
: [(a, ByteString)]
hs
)