{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
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
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)
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)
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)
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)
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
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
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
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
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)
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)
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)
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
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
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
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
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
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 ->
( 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
}
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
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
}
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
}
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
]
}
}
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
}
}
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
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
}
}
toHeaders :: W3CTraceContext -> [HTTPTypes.Header]
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]
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
]
encodeFlags :: Flags -> BSC8.ByteString
encodeFlags :: Flags -> ByteString
encodeFlags fl :: Flags
fl =
if Flags -> Bool
sampled Flags
fl then "01"
else "00"
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
$
([ 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
])
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