{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE Strict #-}

{- | Conversion of the hs-opentelemetry internal representation of the trace ID and the span ID and the B3 header representation of them each other.

|----------------+---------------------------------------+------------------------------|
|                | Trace ID                              | Span ID                      |
|----------------+---------------------------------------+------------------------------|
| Internal       | 128-bit integer                       | 64-bit integer               |
| B3 Header      | Hex text of 64-bit or 128-bit integer | Hex text of 64-bit integer   |
|----------------+---------------------------------------+------------------------------|
-}
module OpenTelemetry.Propagator.B3.Internal (
  -- * Encoders
  encodeTraceId,
  encodeSpanId,

  -- * Decoders
  decodeXb3TraceIdHeader,
  decodeXb3SpanIdHeader,
  decodeXb3SampledHeader,
  decodeXb3FlagsHeader,
  decodeB3SampleHeader,
  decodeB3SingleHeader,

  -- * B3SingleHeader
  B3SingleHeader (..),

  -- * SampleState
  SamplingState (..),

  -- ** Conversions
  samplingStateToValue,
  samplingStateFromValue,
  printSamplingStateSingle,
  printSamplingStateMulti,

  -- * Header Keys
  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
  -- ^ ASCII text of 64-bit integer
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
  -- ^ ASCII text of 64-bit integer
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
decodeXb3TraceIdHeader :: ByteString -> Maybe TraceId
decodeXb3TraceIdHeader 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
decodeXb3SpanIdHeader :: ByteString -> Maybe SpanId
decodeXb3SpanIdHeader 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
decodeXb3SampledHeader :: ByteString -> Maybe SamplingState
decodeXb3SampledHeader 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
decodeXb3FlagsHeader :: ByteString -> Maybe SamplingState
decodeXb3FlagsHeader 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
decodeB3SingleHeader :: ByteString -> Maybe B3SingleHeader
decodeB3SingleHeader 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
decodeB3SampleHeader :: ByteString -> Maybe SamplingState
decodeB3SampleHeader 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)


-- | Parser for the @x-b3-sampled@ header value.
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


{- | Note that this parser is only correct for the B3 single header
 format. In B3 Multi you can only pass a @0@ or @1@ for the sample
 state for 'Accept' and 'Deny' respectively.
-}
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


{- | Encode a 'SamplingState' as the Sampling State component of the
 @b3@ header value.
-}
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


-- | Encode a 'SamplingState' as a 'Value'.
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"


-- | Used to decode the 'SamplingState' from a 'TraceState' 'Value'.
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 = B3SingleHeader
  { 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
b3Header :: HeaderName
b3Header = HeaderName
"b3"


xb3TraceIdHeader :: HeaderName
xb3TraceIdHeader :: HeaderName
xb3TraceIdHeader = HeaderName
"X-B3-TraceId"


xb3SpanIdHeader :: HeaderName
xb3SpanIdHeader :: HeaderName
xb3SpanIdHeader = HeaderName
"X-B3-SpanId"


xb3SampledHeader :: HeaderName
xb3SampledHeader :: HeaderName
xb3SampledHeader = HeaderName
"X-B3-Sampled"


xb3FlagsHeader :: HeaderName
xb3FlagsHeader :: HeaderName
xb3FlagsHeader = HeaderName
"X-B3-Flags"