{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

-----------------------------------------------------------------------------

-----------------------------------------------------------------------------

{- |
 Module      :  OpenTelemetry.Propagators.W3CTraceContext
 Copyright   :  (c) Ian Duncan, 2021
 License     :  BSD-3
 Description :  Standardized trace context propagation format intended for HTTP headers
 Maintainer  :  Ian Duncan
 Stability   :  experimental
 Portability :  non-portable (GHC extensions)

 Distributed tracing is a methodology implemented by tracing tools to follow, analyze and debug a transaction across multiple software components. Typically, a distributed trace traverses more than one component which requires it to be uniquely identifiable across all participating systems. Trace context propagation passes along this unique identification. Today, trace context propagation is implemented individually by each tracing vendor. In multi-vendor environments, this causes interoperability problems, like:

 - Traces that are collected by different tracing vendors cannot be correlated as there is no shared unique identifier.
 - Traces that cross boundaries between different tracing vendors can not be propagated as there is no uniformly agreed set of identification that is forwarded.
 - Vendor specific metadata might be dropped by intermediaries.
 - Cloud platform vendors, intermediaries and service providers, cannot guarantee to support trace context propagation as there is no standard to follow.
 - In the past, these problems did not have a significant impact as most applications were monitored by a single tracing vendor and stayed within the boundaries of a single platform provider. Today, an increasing number of applications are highly distributed and leverage multiple middleware services and cloud platforms.

 - This transformation of modern applications calls for a distributed tracing context propagation standard.

 This module therefore provides support for tracing context propagation in accordance with the W3C tracing context
 propagation specifications: https://www.w3.org/TR/trace-context/
-}
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)


{-
TODO: test against the conformance spec:
https://github.com/w3c/trace-context
-}
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
$cshowsPrec :: Int -> TraceParent -> ShowS
showsPrec :: Int -> TraceParent -> ShowS
$cshow :: TraceParent -> String
show :: TraceParent -> String
$cshowList :: [TraceParent] -> ShowS
showList :: [TraceParent] -> ShowS
Show)


{- | Attempt to decode a 'SpanContext' from optional @traceparent@ and @tracestate@ header inputs.

 @since 0.0.1.0
-}
decodeSpanContext
  :: Maybe ByteString
  -- ^ @traceparent@ header value
  -> Maybe ByteString
  -- ^ @tracestate@ header value
  -> 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
TraceFlags
SpanId
TraceId
version :: TraceParent -> Word8
traceId :: TraceParent -> TraceId
parentId :: TraceParent -> SpanId
traceFlags :: TraceParent -> TraceFlags
version :: Word8
traceId :: TraceId
parentId :: SpanId
traceFlags :: TraceFlags
..} <- ByteString -> Maybe TraceParent
decodeTraceparentHeader ByteString
traceparentHeader
  TraceState
ts <- case Maybe ByteString
mTracestateHeader of
    Maybe ByteString
Nothing -> TraceState -> Maybe TraceState
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TraceState
empty
    Just ByteString
tracestateHeader -> TraceState -> Maybe TraceState
forall a. a -> Maybe a
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 a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SpanContext -> Maybe SpanContext)
-> SpanContext -> Maybe SpanContext
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 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 a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
    Right TraceId
ok -> TraceId -> Parser ByteString TraceId
forall a. a -> Parser ByteString a
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 a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
    Right SpanId
ok -> SpanId -> Parser ByteString SpanId
forall a. a -> Parser ByteString a
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
  -- Intentionally not consuming end of input in case of version > 0
  TraceParent -> Parser TraceParent
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TraceParent -> Parser TraceParent)
-> TraceParent -> Parser TraceParent
forall a b. (a -> b) -> a -> b
$ TraceParent {Word8
TraceFlags
SpanId
TraceId
version :: Word8
traceId :: TraceId
parentId :: SpanId
traceFlags :: TraceFlags
version :: Word8
traceId :: TraceId
parentId :: SpanId
traceFlags :: TraceFlags
..}


{- | Encoded the given 'Span' into a @traceparent@, @tracestate@ tuple.

 @since 0.0.1.0
-}
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
  -- TODO tracestate
  (ByteString, ByteString) -> IO (ByteString, ByteString)
forall a. a -> IO a
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
TraceFlags
SpanId
TraceId
TraceState
traceFlags :: SpanContext -> TraceFlags
isRemote :: SpanContext -> Bool
traceId :: SpanContext -> TraceId
spanId :: SpanContext -> SpanId
traceState :: SpanContext -> TraceState
traceFlags :: TraceFlags
isRemote :: Bool
traceId :: TraceId
spanId :: SpanId
traceState :: TraceState
..} =
      -- version
      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)


{- | Propagate trace context information via headers using the w3c specification format

 @since 0.0.1.0
-}
w3cTraceContextPropagator :: Propagator Ctxt.Context RequestHeaders ResponseHeaders
w3cTraceContextPropagator :: Propagator Context RequestHeaders RequestHeaders
w3cTraceContextPropagator = 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 :: forall {f :: * -> *} {a}.
(Applicative f, Eq a, IsString a) =>
[(a, ByteString)] -> Context -> f Context
injector :: forall {a}.
IsString a =>
Context -> [(a, ByteString)] -> IO [(a, ByteString)]
propagatorNames :: [Text]
extractor :: RequestHeaders -> Context -> IO Context
injector :: Context -> RequestHeaders -> IO RequestHeaders
..}
  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 a. a -> f a
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 = 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 a. a -> IO a
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 a. a -> IO a
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
          )