{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module OpenTelemetry.Propagator.W3CTraceContext where
import Data.Attoparsec.ByteString.Char8
( parseOnly, string, Parser, hexadecimal, takeWhile )
import Data.ByteString (ByteString)
import Data.Char (isHexDigit)
import Data.Word (Word8)
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Lazy as L
import Network.HTTP.Types ( RequestHeaders, ResponseHeaders )
import qualified OpenTelemetry.Context as Ctxt
import OpenTelemetry.Trace.Core
( traceFlagsFromWord8,
traceFlagsValue,
getSpanContext,
wrapSpanContext,
Span,
SpanContext(..),
TraceFlags )
import OpenTelemetry.Propagator ( Propagator(..) )
import OpenTelemetry.Trace.Id (TraceId, SpanId, Base(..), spanIdBaseEncodedBuilder, traceIdBaseEncodedBuilder, baseEncodedToTraceId, baseEncodedToSpanId)
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
(Int -> TraceParent -> ShowS)
-> (TraceParent -> String)
-> ([TraceParent] -> ShowS)
-> Show TraceParent
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
_ = Maybe SpanContext
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 -> TraceState -> Maybe TraceState
forall (f :: * -> *) a. Applicative f => a -> f a
pure TraceState
empty
Just ByteString
tracestateHeader -> TraceState -> Maybe TraceState
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TraceState -> Maybe TraceState) -> TraceState -> Maybe TraceState
forall a b. (a -> b) -> a -> b
$ ByteString -> TraceState
decodeTracestateHeader ByteString
tracestateHeader
SpanContext -> Maybe SpanContext
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SpanContext -> Maybe SpanContext)
-> SpanContext -> Maybe SpanContext
forall a b. (a -> b) -> a -> b
$ SpanContext :: TraceFlags
-> Bool -> TraceId -> SpanId -> TraceState -> SpanContext
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 Parser TraceParent -> ByteString -> Either String TraceParent
forall a. Parser a -> ByteString -> Either String a
parseOnly Parser TraceParent
traceparentParser ByteString
tp of
Left String
_ -> Maybe TraceParent
forall a. Maybe a
Nothing
Right TraceParent
ok -> TraceParent -> Maybe TraceParent
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 <- Parser Word8
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 -> String -> Parser ByteString TraceId
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
Right TraceId
ok -> TraceId -> Parser ByteString TraceId
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 -> String -> Parser ByteString SpanId
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
Right SpanId
ok -> SpanId -> Parser ByteString SpanId
forall (f :: * -> *) a. Applicative f => a -> f a
pure SpanId
ok
ByteString
_ <- ByteString -> Parser ByteString
string ByteString
"-"
TraceFlags
traceFlags <- Word8 -> TraceFlags
traceFlagsFromWord8 (Word8 -> TraceFlags)
-> Parser Word8 -> Parser ByteString TraceFlags
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Word8
forall a. (Integral a, Bits a) => Parser a
hexadecimal
TraceParent -> Parser TraceParent
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TraceParent -> Parser TraceParent)
-> TraceParent -> Parser TraceParent
forall a b. (a -> b) -> a -> b
$ TraceParent :: Word8 -> TraceId -> SpanId -> TraceFlags -> TraceParent
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 <- Span -> IO SpanContext
forall (m :: * -> *). MonadIO m => Span -> m SpanContext
getSpanContext Span
s
(ByteString, ByteString) -> IO (ByteString, ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> ByteString
L.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
B.toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
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 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
Char -> Builder
B.char7 Char
'-' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
Base -> TraceId -> Builder
traceIdBaseEncodedBuilder Base
Base16 TraceId
traceId Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
Char -> Builder
B.char7 Char
'-' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
Base -> SpanId -> Builder
spanIdBaseEncodedBuilder Base
Base16 SpanId
spanId Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
Char -> Builder
B.char7 Char
'-' Builder -> Builder -> Builder
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 :: forall context inboundCarrier outboundCarrier.
[Text]
-> (inboundCarrier -> context -> IO context)
-> (context -> outboundCarrier -> IO outboundCarrier)
-> Propagator context inboundCarrier outboundCarrier
Propagator{[Text]
RequestHeaders -> Context -> IO Context
Context -> RequestHeaders -> IO RequestHeaders
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 = a -> [(a, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
Prelude.lookup a
"traceparent" [(a, ByteString)]
hs
traceStateHeader :: Maybe ByteString
traceStateHeader = a -> [(a, ByteString)] -> Maybe ByteString
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
Context -> f Context
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Context -> f Context) -> Context -> f Context
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 -> [(a, ByteString)] -> IO [(a, ByteString)]
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
[(a, ByteString)] -> IO [(a, ByteString)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(
(a
"traceparent", ByteString
traceParentHeader) (a, ByteString) -> [(a, ByteString)] -> [(a, ByteString)]
forall a. a -> [a] -> [a]
:
(a
"tracestate", ByteString
traceStateHeader) (a, ByteString) -> [(a, ByteString)] -> [(a, ByteString)]
forall a. a -> [a] -> [a]
:
[(a, ByteString)]
hs
)