{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE Strict #-}
module OpenTelemetry.Propagator.B3.Internal (
encodeTraceId,
encodeSpanId,
decodeXb3TraceIdHeader,
decodeXb3SpanIdHeader,
decodeXb3SampledHeader,
decodeXb3FlagsHeader,
decodeB3SampleHeader,
decodeB3SingleHeader,
B3SingleHeader (..),
SamplingState (..),
samplingStateToValue,
samplingStateFromValue,
printSamplingStateSingle,
printSamplingStateMulti,
b3Header,
xb3TraceIdHeader,
xb3SpanIdHeader,
xb3SampledHeader,
xb3FlagsHeader,
) where
import Control.Applicative ((<|>))
import Control.Monad (void)
import qualified Data.Attoparsec.ByteString.Char8 as Atto
import Data.ByteString (ByteString)
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Lazy as BL
import qualified Data.Char as C
import Data.Functor (($>))
import Data.Text (Text)
import Network.HTTP.Types (HeaderName)
import OpenTelemetry.Trace.Id (Base (..), SpanId, TraceId, baseEncodedToSpanId, baseEncodedToTraceId, spanIdBaseEncodedBuilder, traceIdBaseEncodedBuilder)
import OpenTelemetry.Trace.TraceState (Value (..))
encodeTraceId
:: TraceId
-> ByteString
encodeTraceId :: TraceId -> ByteString
encodeTraceId = ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> (TraceId -> ByteString) -> TraceId -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
BB.toLazyByteString (Builder -> ByteString)
-> (TraceId -> Builder) -> TraceId -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Base -> TraceId -> Builder
traceIdBaseEncodedBuilder Base
Base16
encodeSpanId
:: SpanId
-> ByteString
encodeSpanId :: SpanId -> ByteString
encodeSpanId = ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> (SpanId -> ByteString) -> SpanId -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
BB.toLazyByteString (Builder -> ByteString)
-> (SpanId -> Builder) -> SpanId -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Base -> SpanId -> Builder
spanIdBaseEncodedBuilder Base
Base16
decodeXb3TraceIdHeader :: ByteString -> Maybe TraceId
ByteString
tp = case Parser TraceId -> ByteString -> Either String TraceId
forall a. Parser a -> ByteString -> Either String a
Atto.parseOnly Parser TraceId
parserTraceId ByteString
tp of
Left String
_ -> Maybe TraceId
forall a. Maybe a
Nothing
Right TraceId
traceId -> TraceId -> Maybe TraceId
forall a. a -> Maybe a
Just TraceId
traceId
decodeXb3SpanIdHeader :: ByteString -> Maybe SpanId
ByteString
tp = case Parser SpanId -> ByteString -> Either String SpanId
forall a. Parser a -> ByteString -> Either String a
Atto.parseOnly Parser SpanId
parserSpanId ByteString
tp of
Left String
_ -> Maybe SpanId
forall a. Maybe a
Nothing
Right SpanId
spanId -> SpanId -> Maybe SpanId
forall a. a -> Maybe a
Just SpanId
spanId
decodeXb3SampledHeader :: ByteString -> Maybe SamplingState
ByteString
tp = case Parser SamplingState -> ByteString -> Either String SamplingState
forall a. Parser a -> ByteString -> Either String a
Atto.parseOnly Parser SamplingState
parserXb3Sampled ByteString
tp of
Left String
_ -> Maybe SamplingState
forall a. Maybe a
Nothing
Right SamplingState
sampled -> SamplingState -> Maybe SamplingState
forall a. a -> Maybe a
Just SamplingState
sampled
decodeXb3FlagsHeader :: ByteString -> Maybe SamplingState
ByteString
tp = case Parser SamplingState -> ByteString -> Either String SamplingState
forall a. Parser a -> ByteString -> Either String a
Atto.parseOnly Parser SamplingState
parserXb3Flags ByteString
tp of
Left String
_ -> Maybe SamplingState
forall a. Maybe a
Nothing
Right SamplingState
flags -> SamplingState -> Maybe SamplingState
forall a. a -> Maybe a
Just SamplingState
flags
decodeB3SingleHeader :: ByteString -> Maybe B3SingleHeader
ByteString
tp = case Parser B3SingleHeader -> ByteString -> Either String B3SingleHeader
forall a. Parser a -> ByteString -> Either String a
Atto.parseOnly Parser B3SingleHeader
parserB3Single ByteString
tp of
Left String
_ -> Maybe B3SingleHeader
forall a. Maybe a
Nothing
Right B3SingleHeader
b3 -> B3SingleHeader -> Maybe B3SingleHeader
forall a. a -> Maybe a
Just B3SingleHeader
b3
decodeB3SampleHeader :: ByteString -> Maybe SamplingState
ByteString
tp = case Parser SamplingState -> ByteString -> Either String SamplingState
forall a. Parser a -> ByteString -> Either String a
Atto.parseOnly Parser SamplingState
parserSamplingState ByteString
tp of
Left String
_ -> Maybe SamplingState
forall a. Maybe a
Nothing
Right SamplingState
b3 -> SamplingState -> Maybe SamplingState
forall a. a -> Maybe a
Just SamplingState
b3
parserTraceId :: Atto.Parser TraceId
parserTraceId :: Parser TraceId
parserTraceId = do
ByteString
traceIdBs <- (Char -> Bool) -> Parser ByteString ByteString
Atto.takeWhile Char -> Bool
C.isHexDigit
case Base -> ByteString -> Either String TraceId
baseEncodedToTraceId Base
Base16 ByteString
traceIdBs of
Left String
err -> String -> Parser TraceId
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
Right TraceId
traceId -> TraceId -> Parser TraceId
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TraceId
traceId
parserSpanId :: Atto.Parser SpanId
parserSpanId :: Parser SpanId
parserSpanId = do
ByteString
parentIdBs <- (Char -> Bool) -> Parser ByteString ByteString
Atto.takeWhile Char -> Bool
C.isHexDigit
case Base -> ByteString -> Either String SpanId
baseEncodedToSpanId Base
Base16 ByteString
parentIdBs of
Left String
err -> String -> Parser SpanId
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
Right SpanId
ok -> SpanId -> Parser SpanId
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SpanId
ok
data SamplingState = Accept | Deny | Debug | Defer
deriving (SamplingState -> SamplingState -> Bool
(SamplingState -> SamplingState -> Bool)
-> (SamplingState -> SamplingState -> Bool) -> Eq SamplingState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SamplingState -> SamplingState -> Bool
== :: SamplingState -> SamplingState -> Bool
$c/= :: SamplingState -> SamplingState -> Bool
/= :: SamplingState -> SamplingState -> Bool
Eq)
parserXb3Sampled :: Atto.Parser SamplingState
parserXb3Sampled :: Parser SamplingState
parserXb3Sampled = Parser SamplingState
accept Parser SamplingState
-> Parser SamplingState -> Parser SamplingState
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser SamplingState
deny
where
accept :: Parser SamplingState
accept = Parser ByteString ByteString
"1" Parser ByteString ByteString
-> SamplingState -> Parser SamplingState
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> SamplingState
Accept
deny :: Parser SamplingState
deny = Parser ByteString ByteString
"0" Parser ByteString ByteString
-> SamplingState -> Parser SamplingState
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> SamplingState
Deny
parserXb3Flags :: Atto.Parser SamplingState
parserXb3Flags :: Parser SamplingState
parserXb3Flags = Parser ByteString ByteString
"1" Parser ByteString ByteString
-> SamplingState -> Parser SamplingState
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> SamplingState
Debug
parserSamplingState :: Atto.Parser SamplingState
parserSamplingState :: Parser SamplingState
parserSamplingState = Parser SamplingState
accept Parser SamplingState
-> Parser SamplingState -> Parser SamplingState
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser SamplingState
deny Parser SamplingState
-> Parser SamplingState -> Parser SamplingState
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser SamplingState
debug
where
accept :: Parser SamplingState
accept = Parser ByteString ByteString
"1" Parser ByteString ByteString
-> SamplingState -> Parser SamplingState
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> SamplingState
Accept
deny :: Parser SamplingState
deny = Parser ByteString ByteString
"0" Parser ByteString ByteString
-> SamplingState -> Parser SamplingState
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> SamplingState
Deny
debug :: Parser SamplingState
debug = Parser ByteString ByteString
"d" Parser ByteString ByteString
-> SamplingState -> Parser SamplingState
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> SamplingState
Debug
printSamplingStateSingle :: SamplingState -> Maybe Text
printSamplingStateSingle :: SamplingState -> Maybe Text
printSamplingStateSingle = \case
SamplingState
Accept -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"1"
SamplingState
Deny -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"0"
SamplingState
Debug -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"d"
SamplingState
Defer -> Maybe Text
forall a. Maybe a
Nothing
printSamplingStateMulti :: SamplingState -> Maybe (HeaderName, Text)
printSamplingStateMulti :: SamplingState -> Maybe (HeaderName, Text)
printSamplingStateMulti = \case
SamplingState
Accept -> (HeaderName, Text) -> Maybe (HeaderName, Text)
forall a. a -> Maybe a
Just (HeaderName
xb3SampledHeader, Text
"1")
SamplingState
Deny -> (HeaderName, Text) -> Maybe (HeaderName, Text)
forall a. a -> Maybe a
Just (HeaderName
xb3SampledHeader, Text
"0")
SamplingState
Debug -> (HeaderName, Text) -> Maybe (HeaderName, Text)
forall a. a -> Maybe a
Just (HeaderName
xb3FlagsHeader, Text
"1")
SamplingState
Defer -> Maybe (HeaderName, Text)
forall a. Maybe a
Nothing
samplingStateToValue :: SamplingState -> Value
samplingStateToValue :: SamplingState -> Value
samplingStateToValue = \case
SamplingState
Accept -> Text -> Value
Value Text
"accept"
SamplingState
Deny -> Text -> Value
Value Text
"deny"
SamplingState
Debug -> Text -> Value
Value Text
"debug"
SamplingState
Defer -> Text -> Value
Value Text
"defer"
samplingStateFromValue :: Value -> Maybe SamplingState
samplingStateFromValue :: Value -> Maybe SamplingState
samplingStateFromValue = \case
Value Text
"accept" -> SamplingState -> Maybe SamplingState
forall a. a -> Maybe a
Just SamplingState
Accept
Value Text
"deny" -> SamplingState -> Maybe SamplingState
forall a. a -> Maybe a
Just SamplingState
Deny
Value Text
"debug" -> SamplingState -> Maybe SamplingState
forall a. a -> Maybe a
Just SamplingState
Debug
Value Text
"defer" -> SamplingState -> Maybe SamplingState
forall a. a -> Maybe a
Just SamplingState
Defer
Value
_ -> Maybe SamplingState
forall a. Maybe a
Nothing
data =
{ B3SingleHeader -> TraceId
traceId :: TraceId
, B3SingleHeader -> SpanId
spanId :: SpanId
, B3SingleHeader -> SamplingState
samplingState :: SamplingState
, B3SingleHeader -> Maybe SpanId
parentSpanId :: Maybe SpanId
}
parserB3Single :: Atto.Parser B3SingleHeader
parserB3Single :: Parser B3SingleHeader
parserB3Single = do
TraceId
traceId <- Parser TraceId
parserTraceId
SpanId
spanId <- Parser ByteString ByteString -> Parser ByteString ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser ByteString ByteString
"-" Parser ByteString () -> Parser SpanId -> Parser SpanId
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser SpanId
parserSpanId
SamplingState
samplingState <- SamplingState -> Parser SamplingState -> Parser SamplingState
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
Atto.option SamplingState
Defer (Parser ByteString ByteString -> Parser ByteString ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser ByteString ByteString
"-" Parser ByteString ()
-> Parser SamplingState -> Parser SamplingState
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser SamplingState
parserSamplingState)
Maybe SpanId
parentSpanId <- Maybe SpanId
-> Parser ByteString (Maybe SpanId)
-> Parser ByteString (Maybe SpanId)
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
Atto.option Maybe SpanId
forall a. Maybe a
Nothing (Parser ByteString ByteString -> Parser ByteString ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser ByteString ByteString
"-" Parser ByteString ()
-> Parser ByteString (Maybe SpanId)
-> Parser ByteString (Maybe SpanId)
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (SpanId -> Maybe SpanId)
-> Parser SpanId -> Parser ByteString (Maybe SpanId)
forall a b. (a -> b) -> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SpanId -> Maybe SpanId
forall a. a -> Maybe a
Just Parser SpanId
parserSpanId)
B3SingleHeader -> Parser B3SingleHeader
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure B3SingleHeader {Maybe SpanId
SpanId
TraceId
SamplingState
traceId :: TraceId
spanId :: SpanId
samplingState :: SamplingState
parentSpanId :: Maybe SpanId
traceId :: TraceId
spanId :: SpanId
samplingState :: SamplingState
parentSpanId :: Maybe SpanId
..}
b3Header :: HeaderName
= HeaderName
"b3"
xb3TraceIdHeader :: HeaderName
= HeaderName
"X-B3-TraceId"
xb3SpanIdHeader :: HeaderName
= HeaderName
"X-B3-SpanId"
xb3SampledHeader :: HeaderName
= HeaderName
"X-B3-Sampled"
xb3FlagsHeader :: HeaderName
= HeaderName
"X-B3-Flags"