{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE OverloadedStrings #-}
{-|
Module      : Instana.SDK.Span.W3CTraceContext
Description : Utility module for decoding and encoding the W3C Trace Context
              headers.
-}
module Instana.SDK.Internal.W3CTraceContext
    ( Flags(..)
    , InstanaKeyValuePair(..)
    , TraceParent(..)
    , TraceState(..)
    , W3CTraceContext(..)
    , createExitContextForSuppressed
    , decode
    , exitSpanContextFromIds
    , inheritFrom
    , inheritFromForSuppressed
    , initBogusContextForSuppressedRequest
    , toHeaders
    ) where


import qualified Data.Bits                  as Bits
import qualified Data.ByteString.Char8      as BSC8
import qualified Data.List                  as List
import qualified Data.Maybe                 as Maybe
import           Data.Text                  (Text)
import qualified Data.Text                  as T
import           GHC.Generics
import qualified Network.HTTP.Types         as HTTPTypes
import           Numeric                    (readHex)

import           Instana.SDK.Internal.Id    (Id)
import qualified Instana.SDK.Internal.Id    as Id
import           Instana.SDK.Internal.Util  (leftPad, leftPadAndLimit)
import qualified Instana.SDK.TracingHeaders as TracingHeaders


-- |A representation of the W3C trace context headers traceparent and
-- tracestate.
data W3CTraceContext = W3CTraceContext
  { W3CTraceContext -> TraceParent
traceParent :: TraceParent
  , W3CTraceContext -> TraceState
traceState  :: TraceState
  } deriving (W3CTraceContext -> W3CTraceContext -> Bool
(W3CTraceContext -> W3CTraceContext -> Bool)
-> (W3CTraceContext -> W3CTraceContext -> Bool)
-> Eq W3CTraceContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: W3CTraceContext -> W3CTraceContext -> Bool
$c/= :: W3CTraceContext -> W3CTraceContext -> Bool
== :: W3CTraceContext -> W3CTraceContext -> Bool
$c== :: W3CTraceContext -> W3CTraceContext -> Bool
Eq, (forall x. W3CTraceContext -> Rep W3CTraceContext x)
-> (forall x. Rep W3CTraceContext x -> W3CTraceContext)
-> Generic W3CTraceContext
forall x. Rep W3CTraceContext x -> W3CTraceContext
forall x. W3CTraceContext -> Rep W3CTraceContext x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep W3CTraceContext x -> W3CTraceContext
$cfrom :: forall x. W3CTraceContext -> Rep W3CTraceContext x
Generic, Int -> W3CTraceContext -> ShowS
[W3CTraceContext] -> ShowS
W3CTraceContext -> String
(Int -> W3CTraceContext -> ShowS)
-> (W3CTraceContext -> String)
-> ([W3CTraceContext] -> ShowS)
-> Show W3CTraceContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [W3CTraceContext] -> ShowS
$cshowList :: [W3CTraceContext] -> ShowS
show :: W3CTraceContext -> String
$cshow :: W3CTraceContext -> String
showsPrec :: Int -> W3CTraceContext -> ShowS
$cshowsPrec :: Int -> W3CTraceContext -> ShowS
Show)


-- |A representation of the W3C trace context header traceparent.
data TraceParent = TraceParent
  { TraceParent -> Int
version  :: Int
  , TraceParent -> Id
traceId  :: Id
  , TraceParent -> Id
parentId :: Id
  , TraceParent -> Flags
flags    :: Flags
  } deriving (TraceParent -> TraceParent -> Bool
(TraceParent -> TraceParent -> Bool)
-> (TraceParent -> TraceParent -> Bool) -> Eq TraceParent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TraceParent -> TraceParent -> Bool
$c/= :: TraceParent -> TraceParent -> Bool
== :: TraceParent -> TraceParent -> Bool
$c== :: TraceParent -> TraceParent -> Bool
Eq, (forall x. TraceParent -> Rep TraceParent x)
-> (forall x. Rep TraceParent x -> TraceParent)
-> Generic TraceParent
forall x. Rep TraceParent x -> TraceParent
forall x. TraceParent -> Rep TraceParent x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TraceParent x -> TraceParent
$cfrom :: forall x. TraceParent -> Rep TraceParent x
Generic, 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)


-- |A representation of the flags part of the W3C trace context header
-- traceparent.
data Flags = Flags
  { Flags -> Bool
sampled  :: Bool
  } deriving (Flags -> Flags -> Bool
(Flags -> Flags -> Bool) -> (Flags -> Flags -> Bool) -> Eq Flags
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Flags -> Flags -> Bool
$c/= :: Flags -> Flags -> Bool
== :: Flags -> Flags -> Bool
$c== :: Flags -> Flags -> Bool
Eq, (forall x. Flags -> Rep Flags x)
-> (forall x. Rep Flags x -> Flags) -> Generic Flags
forall x. Rep Flags x -> Flags
forall x. Flags -> Rep Flags x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Flags x -> Flags
$cfrom :: forall x. Flags -> Rep Flags x
Generic, Int -> Flags -> ShowS
[Flags] -> ShowS
Flags -> String
(Int -> Flags -> ShowS)
-> (Flags -> String) -> ([Flags] -> ShowS) -> Show Flags
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Flags] -> ShowS
$cshowList :: [Flags] -> ShowS
show :: Flags -> String
$cshow :: Flags -> String
showsPrec :: Int -> Flags -> ShowS
$cshowsPrec :: Int -> Flags -> ShowS
Show)


-- |A representation of the W3C trace context header tracestate.
data TraceState = TraceState
  { TraceState -> Maybe Text
traceStateHead      :: Maybe Text
  , TraceState -> Maybe InstanaKeyValuePair
instanaKeyValuePair :: Maybe InstanaKeyValuePair
  , TraceState -> Maybe Text
traceStateTail      :: Maybe Text
  } deriving (TraceState -> TraceState -> Bool
(TraceState -> TraceState -> Bool)
-> (TraceState -> TraceState -> Bool) -> Eq TraceState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TraceState -> TraceState -> Bool
$c/= :: TraceState -> TraceState -> Bool
== :: TraceState -> TraceState -> Bool
$c== :: TraceState -> TraceState -> Bool
Eq, (forall x. TraceState -> Rep TraceState x)
-> (forall x. Rep TraceState x -> TraceState) -> Generic TraceState
forall x. Rep TraceState x -> TraceState
forall x. TraceState -> Rep TraceState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TraceState x -> TraceState
$cfrom :: forall x. TraceState -> Rep TraceState x
Generic, Int -> TraceState -> ShowS
[TraceState] -> ShowS
TraceState -> String
(Int -> TraceState -> ShowS)
-> (TraceState -> String)
-> ([TraceState] -> ShowS)
-> Show TraceState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TraceState] -> ShowS
$cshowList :: [TraceState] -> ShowS
show :: TraceState -> String
$cshow :: TraceState -> String
showsPrec :: Int -> TraceState -> ShowS
$cshowsPrec :: Int -> TraceState -> ShowS
Show)


-- |A representation of the Instana key-value pair W3C contained in the
-- tracestate header.
data InstanaKeyValuePair = InstanaKeyValuePair
  { InstanaKeyValuePair -> Id
instanaTraceId  :: Id
  , InstanaKeyValuePair -> Id
instanaParentId :: Id
  } deriving (InstanaKeyValuePair -> InstanaKeyValuePair -> Bool
(InstanaKeyValuePair -> InstanaKeyValuePair -> Bool)
-> (InstanaKeyValuePair -> InstanaKeyValuePair -> Bool)
-> Eq InstanaKeyValuePair
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InstanaKeyValuePair -> InstanaKeyValuePair -> Bool
$c/= :: InstanaKeyValuePair -> InstanaKeyValuePair -> Bool
== :: InstanaKeyValuePair -> InstanaKeyValuePair -> Bool
$c== :: InstanaKeyValuePair -> InstanaKeyValuePair -> Bool
Eq, (forall x. InstanaKeyValuePair -> Rep InstanaKeyValuePair x)
-> (forall x. Rep InstanaKeyValuePair x -> InstanaKeyValuePair)
-> Generic InstanaKeyValuePair
forall x. Rep InstanaKeyValuePair x -> InstanaKeyValuePair
forall x. InstanaKeyValuePair -> Rep InstanaKeyValuePair x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep InstanaKeyValuePair x -> InstanaKeyValuePair
$cfrom :: forall x. InstanaKeyValuePair -> Rep InstanaKeyValuePair x
Generic, Int -> InstanaKeyValuePair -> ShowS
[InstanaKeyValuePair] -> ShowS
InstanaKeyValuePair -> String
(Int -> InstanaKeyValuePair -> ShowS)
-> (InstanaKeyValuePair -> String)
-> ([InstanaKeyValuePair] -> ShowS)
-> Show InstanaKeyValuePair
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InstanaKeyValuePair] -> ShowS
$cshowList :: [InstanaKeyValuePair] -> ShowS
show :: InstanaKeyValuePair -> String
$cshow :: InstanaKeyValuePair -> String
showsPrec :: Int -> InstanaKeyValuePair -> ShowS
$cshowsPrec :: Int -> InstanaKeyValuePair -> ShowS
Show)


maxKeyValuePairsTraceState :: Int
maxKeyValuePairsTraceState :: Int
maxKeyValuePairsTraceState = 32


-- |Decodes the raw values of traceparent and tracestate to the parsed
-- representation of the W3C trace context. If the traceparent value is invalid,
-- Nothing will be returned.
decode :: String -> Maybe String -> Maybe W3CTraceContext
decode :: String -> Maybe String -> Maybe W3CTraceContext
decode traceparentHeader :: String
traceparentHeader tracestateHeader :: Maybe String
tracestateHeader =
  let
    maybeTraceParent :: Maybe TraceParent
maybeTraceParent = String -> Maybe TraceParent
decodeTraceParent String
traceparentHeader
  in
  case Maybe TraceParent
maybeTraceParent of
    Just tp :: TraceParent
tp ->
      W3CTraceContext -> Maybe W3CTraceContext
forall a. a -> Maybe a
Just (W3CTraceContext -> Maybe W3CTraceContext)
-> W3CTraceContext -> Maybe W3CTraceContext
forall a b. (a -> b) -> a -> b
$
        W3CTraceContext :: TraceParent -> TraceState -> W3CTraceContext
W3CTraceContext
        { traceParent :: TraceParent
traceParent = TraceParent
tp
        , traceState :: TraceState
traceState = Maybe String -> TraceState
decodeTraceState Maybe String
tracestateHeader
        }
    Nothing ->
      Maybe W3CTraceContext
forall a. Maybe a
Nothing


-- |Decodes the raw traceparent value. If the traceparent value is invalid,
-- Nothing will be returned.
decodeTraceParent :: String -> Maybe TraceParent
decodeTraceParent :: String -> Maybe TraceParent
decodeTraceParent traceParentString :: String
traceParentString =
  let
    traceParentText :: Text
traceParentText = String -> Text
T.pack String
traceParentString
    components :: [Text]
components = Text -> Text -> [Text]
T.splitOn "-" Text
traceParentText
  in
  if [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
components Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 4
    then
      Maybe TraceParent
forall a. Maybe a
Nothing
    else
      [Text] -> Maybe TraceParent
decodeTraceParentComponents [Text]
components


-- |Decodes the individual traceparent fields. If any of them is invalid,
-- Nothing will be returned.
decodeTraceParentComponents :: [Text] -> Maybe TraceParent
decodeTraceParentComponents :: [Text] -> Maybe TraceParent
decodeTraceParentComponents components :: [Text]
components =
  let
    rawVersion :: Text
rawVersion = [Text]
components [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! 0
    rawTraceId :: Text
rawTraceId = [Text]
components [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! 1
    rawParentId :: Text
rawParentId = [Text]
components [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! 2
    rawFlags :: Text
rawFlags = [Text]
components [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! 3
  in
  case ( Text -> Bool
validVersion Text
rawVersion
       , Text -> Bool
validTraceId Text
rawTraceId
       , Text -> Bool
validParentId Text
rawParentId
       , Text -> Bool
validFlags Text
rawFlags) of
    (True, True, True, True) ->
      let
        tId :: Id
tId = Text -> Id
Id.fromText (Text -> Id) -> Text -> Id
forall a b. (a -> b) -> a -> b
$ Text
rawTraceId
        pId :: Id
pId = Text -> Id
Id.fromText (Text -> Id) -> Text -> Id
forall a b. (a -> b) -> a -> b
$ Text
rawParentId
        flagsReadResult :: [(Integer, String)]
flagsReadResult = ReadS Integer
forall a. (Eq a, Num a) => ReadS a
readHex ReadS Integer -> ReadS Integer
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
rawFlags
        flgs :: Maybe Integer
        flgs :: Maybe Integer
flgs = [Integer] -> Maybe Integer
forall a. [a] -> Maybe a
Maybe.listToMaybe ([Integer] -> Maybe Integer)
-> ([(Integer, String)] -> [Integer])
-> [(Integer, String)]
-> Maybe Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Integer, String) -> Integer) -> [(Integer, String)] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map (Integer, String) -> Integer
forall a b. (a, b) -> a
fst ([(Integer, String)] -> Maybe Integer)
-> [(Integer, String)] -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ [(Integer, String)]
flagsReadResult
        smpld :: Bool
        smpld :: Bool
smpld = case Maybe Integer
flgs of
          Just fl :: Integer
fl ->
            Integer -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
Bits.testBit Integer
fl 0
          Nothing ->
            Bool
False
      in
      TraceParent -> Maybe TraceParent
forall a. a -> Maybe a
Just (TraceParent -> Maybe TraceParent)
-> TraceParent -> Maybe TraceParent
forall a b. (a -> b) -> a -> b
$ TraceParent :: Int -> Id -> Id -> Flags -> TraceParent
TraceParent
        { version :: Int
version  = 0
        , traceId :: Id
traceId  = Id
tId
        , parentId :: Id
parentId = Id
pId
        , flags :: Flags
flags    = Flags :: Bool -> Flags
Flags
          { sampled :: Bool
sampled = Bool
smpld
          }
        }
    _ ->
      Maybe TraceParent
forall a. Maybe a
Nothing


-- |Checks if the version field of traceparent is valid.
validVersion :: Text -> Bool
validVersion :: Text -> Bool
validVersion rawVersion :: Text
rawVersion =
  Text -> Int
T.length Text
rawVersion Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 2 Bool -> Bool -> Bool
&&
  Text -> Bool
onlyLowerCaseHex Text
rawVersion Bool -> Bool -> Bool
&&
  Bool -> Bool
not ((Char -> Bool) -> Text -> Bool
T.all (\c :: Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 'f') Text
rawVersion)


-- |Checks if the trace ID field of traceparent is valid.
validTraceId :: Text -> Bool
validTraceId :: Text -> Bool
validTraceId rawTraceId :: Text
rawTraceId =
  Text -> Int
T.length Text
rawTraceId Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 32 Bool -> Bool -> Bool
&&
  Text -> Bool
onlyLowerCaseHex Text
rawTraceId Bool -> Bool -> Bool
&&
  Bool -> Bool
not ((Char -> Bool) -> Text -> Bool
T.all (\c :: Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '0') Text
rawTraceId)


-- |Checks if the parent ID field of traceparent is valid.
validParentId :: Text -> Bool
validParentId :: Text -> Bool
validParentId rawParentId :: Text
rawParentId =
  Text -> Int
T.length Text
rawParentId Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 16 Bool -> Bool -> Bool
&&
  Text -> Bool
onlyLowerCaseHex Text
rawParentId Bool -> Bool -> Bool
&&
  Bool -> Bool
not ((Char -> Bool) -> Text -> Bool
T.all (\c :: Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '0') Text
rawParentId)


-- |Checks if the flags field of traceparent is valid.
validFlags :: Text -> Bool
validFlags :: Text -> Bool
validFlags rawFlags :: Text
rawFlags =
  Text -> Int
T.length Text
rawFlags Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 2 Bool -> Bool -> Bool
&&
  Text -> Bool
onlyLowerCaseHex Text
rawFlags


-- |Checks if the given text contains only lower case hex strings (0-9, a-f.
onlyLowerCaseHex :: Text -> Bool
onlyLowerCaseHex :: Text -> Bool
onlyLowerCaseHex t :: Text
t =
  (Char -> Bool) -> Text -> Bool
T.all (\c :: Char
c -> Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (['0'..'9'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ ['a'..'f'])) Text
t


-- |Decodes the raw tracestate value.
decodeTraceState :: Maybe String -> TraceState
decodeTraceState :: Maybe String -> TraceState
decodeTraceState maybeTraceStateString :: Maybe String
maybeTraceStateString =
  case Maybe String
maybeTraceStateString of

    Just traceStateString :: String
traceStateString ->
      String -> TraceState
decodeTraceState' String
traceStateString

    Nothing ->
      TraceState
emptyTraceState


-- |Decodes the raw tracestate value.
decodeTraceState' :: String -> TraceState
decodeTraceState' :: String -> TraceState
decodeTraceState' traceStateString :: String
traceStateString =
  let
    traceStateText :: Text
traceStateText = Text -> Text
T.strip (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
traceStateString
  in
  if Text -> Int
T.length Text
traceStateText Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0
    then
      TraceState
emptyTraceState
    else
      Text -> TraceState
decodeNonEmptyTraceState Text
traceStateText


-- |Decodes the raw tracestate value.
decodeNonEmptyTraceState :: Text -> TraceState
decodeNonEmptyTraceState :: Text -> TraceState
decodeNonEmptyTraceState traceStateText :: Text
traceStateText =
  let
    keyValuePairs :: [Text]
keyValuePairs = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
T.strip ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
T.splitOn "," Text
traceStateText
    instanaKvPairIndex :: Maybe Int
instanaKvPairIndex =
      (Text -> Bool) -> [Text] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
List.findIndex (\kvPairString :: Text
kvPairString ->
        let
          key :: Text
key = Text -> Text
T.strip (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ (Text, Text) -> Text
forall a b. (a, b) -> a
fst ((Text, Text) -> Text) -> (Text, Text) -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> (Text, Text)
T.breakOn "=" Text
kvPairString
        in
        Text
key Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "in"
      ) [Text]
keyValuePairs

    (tsHead :: Maybe Text
tsHead, inKvPair :: Maybe InstanaKeyValuePair
inKvPair, tsTail :: Maybe Text
tsTail) =
      case Maybe Int
instanaKvPairIndex of
        Just idx :: Int
idx ->
          let
            -- Use at most 31 non-Instana key-value pairs plus the Instana
            -- key-value pair, since 32 key-value pairs is the limit imposed by
            -- the W3C trace context spec.
            numKvPairsBeforeInstanaKvPair :: Int
numKvPairsBeforeInstanaKvPair =
              Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
maxKeyValuePairsTraceState Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Int
idx
            maxKvPairsAfterInstanaKvPair :: Int
maxKvPairsAfterInstanaKvPair =
              Int
maxKeyValuePairsTraceState Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numKvPairsBeforeInstanaKvPair Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
            kvPairsBeforeInstanaKvPair :: [Text]
kvPairsBeforeInstanaKvPair =
              Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
take Int
numKvPairsBeforeInstanaKvPair [Text]
keyValuePairs
            allKvPairsAfterInstanaKvPair :: [Text]
allKvPairsAfterInstanaKvPair = Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) [Text]
keyValuePairs
            limitedKvPairsAfterInstanaKvPair :: [Text]
limitedKvPairsAfterInstanaKvPair =
              Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
take Int
maxKvPairsAfterInstanaKvPair [Text]
allKvPairsAfterInstanaKvPair
            tsHd :: Maybe Text
tsHd =
              if [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
kvPairsBeforeInstanaKvPair
                then Maybe Text
forall a. Maybe a
Nothing
                else Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate "," [Text]
kvPairsBeforeInstanaKvPair
            tsTl :: Maybe Text
tsTl =
              if [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
limitedKvPairsAfterInstanaKvPair
                then Maybe Text
forall a. Maybe a
Nothing
                else Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate "," [Text]
limitedKvPairsAfterInstanaKvPair
          in
          ( Maybe Text
tsHd
          , Text -> Maybe InstanaKeyValuePair
decodeInKeyValuePair (Text -> Maybe InstanaKeyValuePair)
-> Text -> Maybe InstanaKeyValuePair
forall a b. (a -> b) -> a -> b
$ [Text]
keyValuePairs [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! Int
idx
          , Maybe Text
tsTl
          )
        Nothing ->
          -- Limit the number of key-value pairs in tracestate to 32 as per
          -- W3C trace context spec.
          ( Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$
              Text -> [Text] -> Text
T.intercalate "," (Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
take Int
maxKeyValuePairsTraceState [Text]
keyValuePairs)
          , Maybe InstanaKeyValuePair
forall a. Maybe a
Nothing
          , Maybe Text
forall a. Maybe a
Nothing
          )

  in
  TraceState :: Maybe Text -> Maybe InstanaKeyValuePair -> Maybe Text -> TraceState
TraceState
  { traceStateHead :: Maybe Text
traceStateHead      = Maybe Text
tsHead
  , instanaKeyValuePair :: Maybe InstanaKeyValuePair
instanaKeyValuePair = Maybe InstanaKeyValuePair
inKvPair
  , traceStateTail :: Maybe Text
traceStateTail      = Maybe Text
tsTail
  }


-- |Decodes the Instana key value pair from the raw tracestate value.
decodeInKeyValuePair :: Text -> Maybe InstanaKeyValuePair
decodeInKeyValuePair :: Text -> Maybe InstanaKeyValuePair
decodeInKeyValuePair inKvPairText :: Text
inKvPairText =
  let
    value :: Text
value = Text -> Text
T.strip (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop 1 (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ (Text, Text) -> Text
forall a b. (a, b) -> b
snd ((Text, Text) -> Text) -> (Text, Text) -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> (Text, Text)
T.breakOn "=" Text
inKvPairText
    (tIdRaw :: Text
tIdRaw, pIdRaw :: Text
pIdRaw) = Text -> Text -> (Text, Text)
T.breakOn ";" Text
value
    (tId :: Text
tId, pId :: Text
pId) =
      ( Text -> Text
T.strip Text
tIdRaw
      , Text -> Text
T.strip (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop 1 (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
pIdRaw
      )
  in
  if (Text -> Int
T.length Text
tId Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 16 Bool -> Bool -> Bool
&& Text -> Int
T.length Text
pId Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 16) then
    InstanaKeyValuePair -> Maybe InstanaKeyValuePair
forall a. a -> Maybe a
Just InstanaKeyValuePair :: Id -> Id -> InstanaKeyValuePair
InstanaKeyValuePair
      { instanaTraceId :: Id
instanaTraceId  = Text -> Id
Id.fromText (Text -> Id) -> Text -> Id
forall a b. (a -> b) -> a -> b
$ Text
tId
      , instanaParentId :: Id
instanaParentId = Text -> Id
Id.fromText (Text -> Id) -> Text -> Id
forall a b. (a -> b) -> a -> b
$ Text
pId
      }
  else
    Maybe InstanaKeyValuePair
forall a. Maybe a
Nothing


-- |Creates an empty trace state value.
emptyTraceState :: TraceState
emptyTraceState :: TraceState
emptyTraceState =
  TraceState :: Maybe Text -> Maybe InstanaKeyValuePair -> Maybe Text -> TraceState
TraceState
  { traceStateHead :: Maybe Text
traceStateHead      = Maybe Text
forall a. Maybe a
Nothing
  , instanaKeyValuePair :: Maybe InstanaKeyValuePair
instanaKeyValuePair = Maybe InstanaKeyValuePair
forall a. Maybe a
Nothing
  , traceStateTail :: Maybe Text
traceStateTail      = Maybe Text
forall a. Maybe a
Nothing
  }


-- |Tests whether the given trace state represents an empty trace state.
isEmpty :: TraceState -> Bool
isEmpty :: TraceState -> Bool
isEmpty ts :: TraceState
ts =
  TraceState
ts TraceState -> TraceState -> Bool
forall a. Eq a => a -> a -> Bool
== TraceState :: Maybe Text -> Maybe InstanaKeyValuePair -> Maybe Text -> TraceState
TraceState
        { traceStateHead :: Maybe Text
traceStateHead      = Maybe Text
forall a. Maybe a
Nothing
        , instanaKeyValuePair :: Maybe InstanaKeyValuePair
instanaKeyValuePair = Maybe InstanaKeyValuePair
forall a. Maybe a
Nothing
        , traceStateTail :: Maybe Text
traceStateTail      = Maybe Text
forall a. Maybe a
Nothing
        }


-- |Creates a new W3C trace context value for an outgoing HTTP request by
-- inheriting from the given parent context.
inheritFrom :: W3CTraceContext -> Id -> Id -> W3CTraceContext
inheritFrom :: W3CTraceContext -> Id -> Id -> W3CTraceContext
inheritFrom parentW3cTraceContext :: W3CTraceContext
parentW3cTraceContext exitSpanTraceId :: Id
exitSpanTraceId exitSpanSpanId :: Id
exitSpanSpanId =
  let
    parentTp :: TraceParent
parentTp = W3CTraceContext -> TraceParent
traceParent (W3CTraceContext -> TraceParent) -> W3CTraceContext -> TraceParent
forall a b. (a -> b) -> a -> b
$ W3CTraceContext
parentW3cTraceContext
    parentTs :: TraceState
    parentTs :: TraceState
parentTs = W3CTraceContext -> TraceState
traceState (W3CTraceContext -> TraceState) -> W3CTraceContext -> TraceState
forall a b. (a -> b) -> a -> b
$ W3CTraceContext
parentW3cTraceContext
    (parentTsHead :: Maybe Text
parentTsHead, parentTsTail :: Maybe Text
parentTsTail) =
      ( TraceState -> Maybe Text
traceStateHead TraceState
parentTs
      , TraceState -> Maybe Text
traceStateTail TraceState
parentTs
      )
  in
  W3CTraceContext :: TraceParent -> TraceState -> W3CTraceContext
W3CTraceContext
  { traceParent :: TraceParent
traceParent = TraceParent :: Int -> Id -> Id -> Flags -> TraceParent
TraceParent
    { version :: Int
version  = 0
    , traceId :: Id
traceId  = TraceParent -> Id
traceId (TraceParent -> Id) -> TraceParent -> Id
forall a b. (a -> b) -> a -> b
$ TraceParent
parentTp
    , parentId :: Id
parentId = Id
exitSpanSpanId
    , flags :: Flags
flags    = Flags :: Bool -> Flags
Flags
      { sampled :: Bool
sampled = Bool
True
      }
    }
  , traceState :: TraceState
traceState = TraceState :: Maybe Text -> Maybe InstanaKeyValuePair -> Maybe Text -> TraceState
TraceState
    { traceStateHead :: Maybe Text
traceStateHead      = Maybe Text
forall a. Maybe a
Nothing
    , instanaKeyValuePair :: Maybe InstanaKeyValuePair
instanaKeyValuePair = InstanaKeyValuePair -> Maybe InstanaKeyValuePair
forall a. a -> Maybe a
Just InstanaKeyValuePair :: Id -> Id -> InstanaKeyValuePair
InstanaKeyValuePair
      { instanaTraceId :: Id
instanaTraceId  = Id
exitSpanTraceId
      , instanaParentId :: Id
instanaParentId = Id
exitSpanSpanId
      }
    , traceStateTail :: Maybe Text
traceStateTail =
        case (Maybe Text
parentTsHead, Maybe Text
parentTsTail) of
          (Nothing, Nothing) ->
            Maybe Text
forall a. Maybe a
Nothing
          _ ->
            Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate "," ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
              [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
Maybe.catMaybes
               [ Maybe Text
parentTsHead
               , Maybe Text
parentTsTail
               ]
    }
  }


-- |Creates a new W3C trace context value for an outgoing HTTP request when
-- tracing is suppressed.
inheritFromForSuppressed :: W3CTraceContext -> Id -> W3CTraceContext
inheritFromForSuppressed :: W3CTraceContext -> Id -> W3CTraceContext
inheritFromForSuppressed parentW3cTraceContext :: W3CTraceContext
parentW3cTraceContext exitSpanSpanId :: Id
exitSpanSpanId =
  let
    parentTp :: TraceParent
parentTp = W3CTraceContext -> TraceParent
traceParent (W3CTraceContext -> TraceParent) -> W3CTraceContext -> TraceParent
forall a b. (a -> b) -> a -> b
$ W3CTraceContext
parentW3cTraceContext
    parentTs :: TraceState
    parentTs :: TraceState
parentTs = W3CTraceContext -> TraceState
traceState (W3CTraceContext -> TraceState) -> W3CTraceContext -> TraceState
forall a b. (a -> b) -> a -> b
$ W3CTraceContext
parentW3cTraceContext
    parentTsHead :: Maybe Text
parentTsHead = TraceState -> Maybe Text
traceStateHead TraceState
parentTs
    parentTsTail :: Maybe Text
parentTsTail = TraceState -> Maybe Text
traceStateTail TraceState
parentTs
  in
  W3CTraceContext :: TraceParent -> TraceState -> W3CTraceContext
W3CTraceContext
  { traceParent :: TraceParent
traceParent = TraceParent :: Int -> Id -> Id -> Flags -> TraceParent
TraceParent
    { version :: Int
version  = 0
    , traceId :: Id
traceId  = TraceParent -> Id
traceId (TraceParent -> Id) -> TraceParent -> Id
forall a b. (a -> b) -> a -> b
$ TraceParent
parentTp
    , parentId :: Id
parentId = Id
exitSpanSpanId
    , flags :: Flags
flags    = Flags :: Bool -> Flags
Flags
      { sampled :: Bool
sampled = Bool
False
      }
    }
  , traceState :: TraceState
traceState = TraceState :: Maybe Text -> Maybe InstanaKeyValuePair -> Maybe Text -> TraceState
TraceState
    { traceStateHead :: Maybe Text
traceStateHead      = Maybe Text
parentTsHead
    , instanaKeyValuePair :: Maybe InstanaKeyValuePair
instanaKeyValuePair = Maybe InstanaKeyValuePair
forall a. Maybe a
Nothing
    , traceStateTail :: Maybe Text
traceStateTail      = Maybe Text
parentTsTail
    }
  }


-- |Creates a new W3C trace context value for an outgoing HTTP request from the
-- given trace ID and span ID, without inheriting from an existing context.
exitSpanContextFromIds :: Id -> Id -> W3CTraceContext
exitSpanContextFromIds :: Id -> Id -> W3CTraceContext
exitSpanContextFromIds exitSpanTraceId :: Id
exitSpanTraceId exitSpanSpanId :: Id
exitSpanSpanId =
  W3CTraceContext :: TraceParent -> TraceState -> W3CTraceContext
W3CTraceContext
  { traceParent :: TraceParent
traceParent = TraceParent :: Int -> Id -> Id -> Flags -> TraceParent
TraceParent
    { version :: Int
version  = 0
    , traceId :: Id
traceId  = Id
exitSpanTraceId
    , parentId :: Id
parentId = Id
exitSpanSpanId
    , flags :: Flags
flags    = Flags :: Bool -> Flags
Flags
      { sampled :: Bool
sampled = Bool
True
      }
    }
  , traceState :: TraceState
traceState = TraceState :: Maybe Text -> Maybe InstanaKeyValuePair -> Maybe Text -> TraceState
TraceState
    { traceStateHead :: Maybe Text
traceStateHead      = Maybe Text
forall a. Maybe a
Nothing
    , instanaKeyValuePair :: Maybe InstanaKeyValuePair
instanaKeyValuePair = InstanaKeyValuePair -> Maybe InstanaKeyValuePair
forall a. a -> Maybe a
Just InstanaKeyValuePair :: Id -> Id -> InstanaKeyValuePair
InstanaKeyValuePair
      { instanaTraceId :: Id
instanaTraceId  = Id
exitSpanTraceId
      , instanaParentId :: Id
instanaParentId = Id
exitSpanSpanId
      }
    , traceStateTail :: Maybe Text
traceStateTail      = Maybe Text
forall a. Maybe a
Nothing
    }
  }


initBogusContextForSuppressedRequest :: IO W3CTraceContext
initBogusContextForSuppressedRequest :: IO W3CTraceContext
initBogusContextForSuppressedRequest = do
  Id
bogusId <- IO Id
Id.generate
  W3CTraceContext -> IO W3CTraceContext
forall (m :: * -> *) a. Monad m => a -> m a
return (W3CTraceContext -> IO W3CTraceContext)
-> W3CTraceContext -> IO W3CTraceContext
forall a b. (a -> b) -> a -> b
$ Id -> Id -> W3CTraceContext
createExitContextForSuppressed Id
bogusId Id
bogusId


-- |When tracing is suppressed but no W3C trace context is incoming , we still
-- need to send down W3C trace context headers to signal sampled=false to
-- downstream services.
createExitContextForSuppressed :: Id -> Id -> W3CTraceContext
createExitContextForSuppressed :: Id -> Id -> W3CTraceContext
createExitContextForSuppressed bogusTraceId :: Id
bogusTraceId bogusParentId :: Id
bogusParentId =
  W3CTraceContext :: TraceParent -> TraceState -> W3CTraceContext
W3CTraceContext
  { traceParent :: TraceParent
traceParent = TraceParent :: Int -> Id -> Id -> Flags -> TraceParent
TraceParent
    { version :: Int
version  = 0
    , traceId :: Id
traceId  = Id
bogusTraceId
    , parentId :: Id
parentId = Id
bogusParentId
    , flags :: Flags
flags    = Flags :: Bool -> Flags
Flags
      { sampled :: Bool
sampled = Bool
False
      }
    }
  , traceState :: TraceState
traceState = TraceState :: Maybe Text -> Maybe InstanaKeyValuePair -> Maybe Text -> TraceState
TraceState
    { traceStateHead :: Maybe Text
traceStateHead      = Maybe Text
forall a. Maybe a
Nothing
    , instanaKeyValuePair :: Maybe InstanaKeyValuePair
instanaKeyValuePair = Maybe InstanaKeyValuePair
forall a. Maybe a
Nothing
    , traceStateTail :: Maybe Text
traceStateTail      = Maybe Text
forall a. Maybe a
Nothing
    }
  }


-- |Serializes the given W3C trace context to a pair of HTTP headers.
toHeaders :: W3CTraceContext -> [HTTPTypes.Header]
toHeaders :: W3CTraceContext -> [Header]
toHeaders w3cTraceContext :: W3CTraceContext
w3cTraceContext =
  let
    tp :: TraceParent
tp = W3CTraceContext -> TraceParent
traceParent W3CTraceContext
w3cTraceContext
    traceparentHeader :: Maybe Header
traceparentHeader =
      Header -> Maybe Header
forall a. a -> Maybe a
Just
        ( HeaderName
TracingHeaders.traceparentHeaderName
        , TraceParent -> ByteString
encodeTraceParent TraceParent
tp
        )
    ts :: TraceState
ts = W3CTraceContext -> TraceState
traceState W3CTraceContext
w3cTraceContext
    tracestateHeader :: Maybe Header
tracestateHeader =
      if TraceState -> Bool
isEmpty TraceState
ts then
        Maybe Header
forall a. Maybe a
Nothing
      else
        Header -> Maybe Header
forall a. a -> Maybe a
Just
          ( HeaderName
TracingHeaders.tracestateHeaderName
          , TraceState -> ByteString
encodeTraceState TraceState
ts
          )
  in
  [Maybe Header] -> [Header]
forall a. [Maybe a] -> [a]
Maybe.catMaybes [Maybe Header
traceparentHeader, Maybe Header
tracestateHeader]


-- |Encodes the traceparent header value.
encodeTraceParent :: TraceParent -> BSC8.ByteString
encodeTraceParent :: TraceParent -> ByteString
encodeTraceParent tp :: TraceParent
tp =
  [ByteString] -> ByteString
BSC8.concat
    [ String -> ByteString
BSC8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
leftPad 2 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ TraceParent -> Int
version TraceParent
tp
    , "-"
    , String -> ByteString
BSC8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
leftPadAndLimit 32 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Id -> String
Id.toStringUnshortened (Id -> String) -> Id -> String
forall a b. (a -> b) -> a -> b
$ TraceParent -> Id
traceId TraceParent
tp
    , "-"
    , String -> ByteString
BSC8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
leftPadAndLimit 16 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Id -> String
Id.toString (Id -> String) -> Id -> String
forall a b. (a -> b) -> a -> b
$ TraceParent -> Id
parentId TraceParent
tp
    , "-"
    , Flags -> ByteString
encodeFlags (Flags -> ByteString) -> Flags -> ByteString
forall a b. (a -> b) -> a -> b
$ TraceParent -> Flags
flags TraceParent
tp
    ]


-- |Encodes the traceparent flag field.
encodeFlags :: Flags -> BSC8.ByteString
encodeFlags :: Flags -> ByteString
encodeFlags fl :: Flags
fl =
  if Flags -> Bool
sampled Flags
fl then "01"
  else "00"


-- |Encodes the tracestate header value.
encodeTraceState :: TraceState -> BSC8.ByteString
encodeTraceState :: TraceState -> ByteString
encodeTraceState ts :: TraceState
ts =
  ByteString -> [ByteString] -> ByteString
BSC8.intercalate "," ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$
    [Maybe ByteString] -> [ByteString]
forall a. [Maybe a] -> [a]
Maybe.catMaybes ([Maybe ByteString] -> [ByteString])
-> [Maybe ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$
      -- We only encode for outgoing headers and for those we always move the
      -- Instana key value pair to the front in compliance with the W3C
      -- trace context specification
      ([ TraceState -> Maybe ByteString
encodeInstanaKeyValuePair TraceState
ts
       , (String -> ByteString
BSC8.pack (String -> ByteString) -> (Text -> String) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) (Text -> ByteString) -> Maybe Text -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TraceState -> Maybe Text
traceStateHead TraceState
ts
       , (String -> ByteString
BSC8.pack (String -> ByteString) -> (Text -> String) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) (Text -> ByteString) -> Maybe Text -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TraceState -> Maybe Text
traceStateTail TraceState
ts
      ])


-- |Encodes the Instana key-value pair for the tracestate header value.
encodeInstanaKeyValuePair :: TraceState -> Maybe BSC8.ByteString
encodeInstanaKeyValuePair :: TraceState -> Maybe ByteString
encodeInstanaKeyValuePair ts :: TraceState
ts =
  let
    inKvPair :: Maybe InstanaKeyValuePair
inKvPair = TraceState -> Maybe InstanaKeyValuePair
instanaKeyValuePair TraceState
ts
    inTId :: Maybe Id
inTId = InstanaKeyValuePair -> Id
instanaTraceId (InstanaKeyValuePair -> Id)
-> Maybe InstanaKeyValuePair -> Maybe Id
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe InstanaKeyValuePair
inKvPair
    inPId :: Maybe Id
inPId = InstanaKeyValuePair -> Id
instanaParentId (InstanaKeyValuePair -> Id)
-> Maybe InstanaKeyValuePair -> Maybe Id
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe InstanaKeyValuePair
inKvPair
  in
  case (Maybe Id
inTId, Maybe Id
inPId) of
    (Just t :: Id
t, Just p :: Id
p) ->
      ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$
        [ByteString] -> ByteString
BSC8.concat
          [ "in="
          , String -> ByteString
BSC8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
leftPad 16 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Id -> String
Id.toString Id
t
          , ";"
          , String -> ByteString
BSC8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
leftPad 16 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Id -> String
Id.toString Id
p
          ]

    _ ->
      Maybe ByteString
forall a. Maybe a
Nothing