{-|
Module: OpenTracing.Propagation

Types and functions for serializing and deserializing `SpanContext`s across
process boundaries.

One of the big motiviating use cases for propagation is for tracing distributed
executions through RPC calls.
-}
{-# LANGUAGE ConstraintKinds        #-}
{-# LANGUAGE DataKinds              #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase             #-}
{-# LANGUAGE OverloadedStrings      #-}
{-# LANGUAGE RankNTypes             #-}
{-# LANGUAGE RecordWildCards        #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE TupleSections          #-}
{-# LANGUAGE TypeApplications       #-}
{-# LANGUAGE TypeOperators          #-}

module OpenTracing.Propagation
    ( TextMap
    , Headers
--  , Binary

    , Propagation
    , HasPropagation(..)

    , Carrier(..)
    , HasCarrier
    , HasCarriers
    , carrier

    , inject
    , extract

    , otPropagation
    , b3Propagation

    , _OTTextMap
    , _OTHeaders
    , _B3TextMap
    , _B3Headers

    , _HeadersTextMap

    -- * Re-exports from 'Data.Vinyl'
    , Rec ((:&), RNil)
    , rappend, (<+>)
    , rcast
    )
where

import           Control.Applicative     ((<|>))
import           Control.Lens
import           Data.Bool               (bool)
import           Data.ByteString.Builder (toLazyByteString)
import qualified Data.CaseInsensitive    as CI
import           Data.HashMap.Strict     (HashMap)
import qualified Data.HashMap.Strict     as HashMap
import           Data.Maybe              (catMaybes)
import           Data.Monoid
import           Data.Proxy
import           Data.Text               (Text, isPrefixOf, toLower)
import           Data.Text.Encoding      (decodeUtf8, encodeUtf8)
import qualified Data.Text.Read          as Text
import           Data.Vinyl
import           Data.Word
import           Network.HTTP.Types      (Header)
import           OpenTracing.Span
import           OpenTracing.Types
import           URI.ByteString          (urlDecodeQuery, urlEncodeQuery)


type TextMap = HashMap Text Text
type Headers = [Header]
--type Binary  = Lazy.ByteString

-- | A `Propagation` contains the different ways that a `SpanContext` can be
-- serialized and deserialized. For example @Propagation '[TextMap, Headers]@ indicates
-- support for serializing to `Header` or to `TextMap`.
--
-- @since 0.1.0.0
type Propagation carriers = Rec Carrier carriers

-- | A typeclass for application environments that contain a `Propagation`.
--
-- @since 0.1.0.0
class HasPropagation a p | a -> p where
    propagation :: Getting r a (Propagation p)

instance HasPropagation (Propagation p) p where
    propagation :: Getting r (Propagation p) (Propagation p)
propagation = Getting r (Propagation p) (Propagation p)
forall a. a -> a
id

-- | `Carrier a` is a way to convert a `SpanContext` into or from an `a`.
--
-- @since 0.1.0.0
newtype Carrier a = Carrier { Carrier a
-> forall (p :: * -> * -> *) (f :: * -> *).
   (Choice p, Applicative f) =>
   p SpanContext (f SpanContext) -> p a (f a)
fromCarrier :: Prism' a SpanContext }

type HasCarrier  c  cs = c  ∈ cs
type HasCarriers cs ds = cs ⊆ ds

-- | Retrieve a (de)serialization lens from the application context for
-- format @c@.
--
-- @since 0.1.0.0
carrier
    :: ( HasCarrier     c cs
       , HasPropagation r cs
       )
    => proxy c -- ^ Proxy for the carrier type @c@.
    -> r -- ^ The application context
    -> Prism' c SpanContext
carrier :: proxy c -> r -> Prism' c SpanContext
carrier proxy c
_c = Carrier c -> p SpanContext (f SpanContext) -> p c (f c)
forall a.
Carrier a
-> forall (p :: * -> * -> *) (f :: * -> *).
   (Choice p, Applicative f) =>
   p SpanContext (f SpanContext) -> p a (f a)
fromCarrier (Carrier c -> p SpanContext (f SpanContext) -> p c (f c))
-> (r -> Carrier c)
-> r
-> p SpanContext (f SpanContext)
-> p c (f c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Carrier c) r (Carrier c) -> r -> Carrier c
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Carrier c) r (Propagation cs)
forall a (p :: [*]) r.
HasPropagation a p =>
Getting r a (Propagation p)
propagation Getting (Carrier c) r (Propagation cs)
-> ((Carrier c -> Const (Carrier c) (Carrier c))
    -> Propagation cs -> Const (Carrier c) (Propagation cs))
-> Getting (Carrier c) r (Carrier c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Carrier c -> Const (Carrier c) (Carrier c))
-> Propagation cs -> Const (Carrier c) (Propagation cs)
forall k (r :: k) (record :: (k -> *) -> [k] -> *) (rs :: [k])
       (f :: k -> *) (g :: * -> *).
(RecElem record r r rs rs (RIndex r rs), RecElemFCtx record f,
 Functor g) =>
(f r -> g (f r)) -> record f rs -> g (record f rs)
rlens)

-- | Serialize a `SpanContext` into the format `c` using a serializer from
-- the application context.
--
-- @since 0.1.0.0
inject
    :: forall c r p.
       ( HasCarrier     c p
       , HasPropagation r p
       )
    => r
    -> SpanContext
    -> c
inject :: r -> SpanContext -> c
inject r
r = AReview c SpanContext -> SpanContext -> c
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review (Proxy c -> r -> Prism' c SpanContext
forall c (cs :: [*]) r (proxy :: * -> *).
(HasCarrier c cs, HasPropagation r cs) =>
proxy c -> r -> Prism' c SpanContext
carrier (Proxy c
forall k (t :: k). Proxy t
Proxy @c) r
r)

-- | Attempt to deserialize a `SpanContext` from the format @c@ using a deserializer
-- from the application context
--
-- @since 0.1.0.0
extract
    :: forall c r p.
       ( HasCarrier     c p
       , HasPropagation r p
       )
    => r
    -> c
    -> Maybe SpanContext
extract :: r -> c -> Maybe SpanContext
extract r
r = Getting (First SpanContext) c SpanContext -> c -> Maybe SpanContext
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (Proxy c -> r -> Prism' c SpanContext
forall c (cs :: [*]) r (proxy :: * -> *).
(HasCarrier c cs, HasPropagation r cs) =>
proxy c -> r -> Prism' c SpanContext
carrier (Proxy c
forall k (t :: k). Proxy t
Proxy @c) r
r)


-- | A propagation using an "ot" prefix.
-- No parent span id is propagated in OT.
otPropagation :: Propagation '[TextMap, Headers]
otPropagation :: Propagation '[TextMap, Headers]
otPropagation = Prism' TextMap SpanContext -> Carrier TextMap
forall a.
(forall (p :: * -> * -> *) (f :: * -> *).
 (Choice p, Applicative f) =>
 p SpanContext (f SpanContext) -> p a (f a))
-> Carrier a
Carrier Prism' TextMap SpanContext
_OTTextMap Carrier TextMap
-> Rec Carrier '[Headers] -> Propagation '[TextMap, Headers]
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& Prism' Headers SpanContext -> Carrier Headers
forall a.
(forall (p :: * -> * -> *) (f :: * -> *).
 (Choice p, Applicative f) =>
 p SpanContext (f SpanContext) -> p a (f a))
-> Carrier a
Carrier Prism' Headers SpanContext
_OTHeaders Carrier Headers -> Rec Carrier '[] -> Rec Carrier '[Headers]
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& Rec Carrier '[]
forall u (a :: u -> *). Rec a '[]
RNil

-- | A propagation using an "x-b3" prefix for use with Zipkin.
b3Propagation :: Propagation '[TextMap, Headers]
b3Propagation :: Propagation '[TextMap, Headers]
b3Propagation = Prism' TextMap SpanContext -> Carrier TextMap
forall a.
(forall (p :: * -> * -> *) (f :: * -> *).
 (Choice p, Applicative f) =>
 p SpanContext (f SpanContext) -> p a (f a))
-> Carrier a
Carrier Prism' TextMap SpanContext
_B3TextMap Carrier TextMap
-> Rec Carrier '[Headers] -> Propagation '[TextMap, Headers]
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& Prism' Headers SpanContext -> Carrier Headers
forall a.
(forall (p :: * -> * -> *) (f :: * -> *).
 (Choice p, Applicative f) =>
 p SpanContext (f SpanContext) -> p a (f a))
-> Carrier a
Carrier Prism' Headers SpanContext
_B3Headers Carrier Headers -> Rec Carrier '[] -> Rec Carrier '[Headers]
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& Rec Carrier '[]
forall u (a :: u -> *). Rec a '[]
RNil


_OTTextMap :: Prism' TextMap SpanContext
_OTTextMap :: p SpanContext (f SpanContext) -> p TextMap (f TextMap)
_OTTextMap = (SpanContext -> TextMap)
-> (TextMap -> Maybe SpanContext) -> Prism' TextMap SpanContext
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' SpanContext -> TextMap
fromCtx TextMap -> Maybe SpanContext
toCtx
  where
    fromCtx :: SpanContext -> TextMap
fromCtx c :: SpanContext
c@SpanContext{Maybe Word64
Word64
TextMap
TraceID
Sampled
_ctxBaggage :: SpanContext -> TextMap
_ctxSampled :: SpanContext -> Sampled
ctxParentSpanID :: SpanContext -> Maybe Word64
ctxSpanID :: SpanContext -> Word64
ctxTraceID :: SpanContext -> TraceID
_ctxBaggage :: TextMap
_ctxSampled :: Sampled
ctxParentSpanID :: Maybe Word64
ctxSpanID :: Word64
ctxTraceID :: TraceID
..} = [(Text, Text)] -> TextMap
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList ([(Text, Text)] -> TextMap) -> [(Text, Text)] -> TextMap
forall a b. (a -> b) -> a -> b
$
          (Text
"ot-tracer-traceid", Getting Text TraceID Text -> TraceID -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text TraceID Text
forall a. AsHex a => Getter a Text
hexText TraceID
ctxTraceID)
        (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: (Text
"ot-tracer-spanid" , Getting Text Word64 Text -> Word64 -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text Word64 Text
forall a. AsHex a => Getter a Text
hexText Word64
ctxSpanID)
        (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: (Text
"ot-tracer-sampled", Getting Text SpanContext Text -> SpanContext -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Sampled -> Const Text Sampled)
-> SpanContext -> Const Text SpanContext
Lens' SpanContext Sampled
ctxSampled ((Sampled -> Const Text Sampled)
 -> SpanContext -> Const Text SpanContext)
-> ((Text -> Const Text Text) -> Sampled -> Const Text Sampled)
-> Getting Text SpanContext Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AReview Text Sampled -> Getter Sampled Text
forall t b. AReview t b -> Getter b t
re AReview Text Sampled
Prism' Text Sampled
_OTSampled) SpanContext
c)
        (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: ((Text, Text) -> (Text, Text)) -> [(Text, Text)] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (ASetter (Text, Text) (Text, Text) Text Text
-> (Text -> Text) -> (Text, Text) -> (Text, Text)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter (Text, Text) (Text, Text) Text Text
forall s t a b. Field1 s t a b => Lens s t a b
_1 (Text
"ot-baggage-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)) (TextMap -> [(Text, Text)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList TextMap
_ctxBaggage)

    toCtx :: TextMap -> Maybe SpanContext
toCtx TextMap
m = TraceID
-> Word64 -> Maybe Word64 -> Sampled -> TextMap -> SpanContext
SpanContext
        (TraceID
 -> Word64 -> Maybe Word64 -> Sampled -> TextMap -> SpanContext)
-> Maybe TraceID
-> Maybe
     (Word64 -> Maybe Word64 -> Sampled -> TextMap -> SpanContext)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> TextMap -> Maybe Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
"ot-tracer-traceid" TextMap
m Maybe Text -> (Text -> Maybe TraceID) -> Maybe TraceID
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Getting (First TraceID) Hex TraceID -> Hex -> Maybe TraceID
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Getting (First TraceID) Hex TraceID
forall a. AsHex a => Prism' Hex a
_Hex (Hex -> Maybe TraceID) -> (Text -> Hex) -> Text -> Maybe TraceID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Hex
knownHex)
        Maybe (Word64 -> Maybe Word64 -> Sampled -> TextMap -> SpanContext)
-> Maybe Word64
-> Maybe (Maybe Word64 -> Sampled -> TextMap -> SpanContext)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> TextMap -> Maybe Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
"ot-tracer-spanid"  TextMap
m Maybe Text -> (Text -> Maybe Word64) -> Maybe Word64
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Getting (First Word64) Hex Word64 -> Hex -> Maybe Word64
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Getting (First Word64) Hex Word64
forall a. AsHex a => Prism' Hex a
_Hex (Hex -> Maybe Word64) -> (Text -> Hex) -> Text -> Maybe Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Hex
knownHex)
        Maybe (Maybe Word64 -> Sampled -> TextMap -> SpanContext)
-> Maybe (Maybe Word64)
-> Maybe (Sampled -> TextMap -> SpanContext)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Word64 -> Maybe (Maybe Word64)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Word64
forall a. Maybe a
Nothing -- nb. parent is not propagated in OT
        Maybe (Sampled -> TextMap -> SpanContext)
-> Maybe Sampled -> Maybe (TextMap -> SpanContext)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> TextMap -> Maybe Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
"ot-tracer-sampled" TextMap
m Maybe Text -> (Text -> Maybe Sampled) -> Maybe Sampled
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Getting (First Sampled) Text Sampled -> Text -> Maybe Sampled
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Getting (First Sampled) Text Sampled
Prism' Text Sampled
_OTSampled)
        Maybe (TextMap -> SpanContext)
-> Maybe TextMap -> Maybe SpanContext
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TextMap -> Maybe TextMap
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Text -> Text -> Bool) -> TextMap -> TextMap
forall k v. (k -> v -> Bool) -> HashMap k v -> HashMap k v
HashMap.filterWithKey (\Text
k Text
_ -> Text
"ot-baggage-" Text -> Text -> Bool
`isPrefixOf` Text
k) TextMap
m)


_OTHeaders :: Prism' Headers SpanContext
_OTHeaders :: p SpanContext (f SpanContext) -> p Headers (f Headers)
_OTHeaders = p TextMap (f TextMap) -> p Headers (f Headers)
Iso' Headers TextMap
_HeadersTextMap (p TextMap (f TextMap) -> p Headers (f Headers))
-> (p SpanContext (f SpanContext) -> p TextMap (f TextMap))
-> p SpanContext (f SpanContext)
-> p Headers (f Headers)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p SpanContext (f SpanContext) -> p TextMap (f TextMap)
Prism' TextMap SpanContext
_OTTextMap

_OTSampled :: Prism' Text Sampled
_OTSampled :: p Sampled (f Sampled) -> p Text (f Text)
_OTSampled = (Sampled -> Text) -> (Text -> Maybe Sampled) -> Prism' Text Sampled
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' Sampled -> Text
enc Text -> Maybe Sampled
dec
    where
      enc :: Sampled -> Text
enc = \case Sampled
Sampled -> Text
"1"
                  Sampled
_       -> Text
"0"

      dec :: Text -> Maybe Sampled
dec = (String -> Maybe Sampled)
-> (Maybe Sampled -> Maybe Sampled)
-> Either String (Maybe Sampled)
-> Maybe Sampled
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Sampled -> String -> Maybe Sampled
forall a b. a -> b -> a
const Maybe Sampled
forall a. Maybe a
Nothing) Maybe Sampled -> Maybe Sampled
forall a. a -> a
id
          (Either String (Maybe Sampled) -> Maybe Sampled)
-> (Text -> Either String (Maybe Sampled)) -> Text -> Maybe Sampled
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Word8, Text) -> Maybe Sampled)
-> Either String (Word8, Text) -> Either String (Maybe Sampled)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Word8
x,Text
_) -> Sampled -> Maybe Sampled
forall a. a -> Maybe a
Just (Sampled -> Maybe Sampled) -> Sampled -> Maybe Sampled
forall a b. (a -> b) -> a -> b
$ if Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== (Word8
1 :: Word8) then Sampled
Sampled else Sampled
NotSampled)
          (Either String (Word8, Text) -> Either String (Maybe Sampled))
-> (Text -> Either String (Word8, Text))
-> Text
-> Either String (Maybe Sampled)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String (Word8, Text)
forall a. Integral a => Reader a
Text.decimal

_B3TextMap :: Prism' TextMap SpanContext
_B3TextMap :: p SpanContext (f SpanContext) -> p TextMap (f TextMap)
_B3TextMap = (SpanContext -> TextMap)
-> (TextMap -> Maybe SpanContext) -> Prism' TextMap SpanContext
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' SpanContext -> TextMap
fromCtx TextMap -> Maybe SpanContext
toCtx
  where
    fromCtx :: SpanContext -> TextMap
fromCtx ctx :: SpanContext
ctx@SpanContext{Maybe Word64
Word64
TextMap
TraceID
Sampled
_ctxBaggage :: TextMap
_ctxSampled :: Sampled
ctxParentSpanID :: Maybe Word64
ctxSpanID :: Word64
ctxTraceID :: TraceID
_ctxBaggage :: SpanContext -> TextMap
_ctxSampled :: SpanContext -> Sampled
ctxParentSpanID :: SpanContext -> Maybe Word64
ctxSpanID :: SpanContext -> Word64
ctxTraceID :: SpanContext -> TraceID
..} = [(Text, Text)] -> TextMap
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList ([(Text, Text)] -> TextMap)
-> ([Maybe (Text, Text)] -> [(Text, Text)])
-> [Maybe (Text, Text)]
-> TextMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (Text, Text)] -> [(Text, Text)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Text, Text)] -> TextMap)
-> [Maybe (Text, Text)] -> TextMap
forall a b. (a -> b) -> a -> b
$
          (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
"x-b3-traceid", Getting Text TraceID Text -> TraceID -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text TraceID Text
forall a. AsHex a => Getter a Text
hexText TraceID
ctxTraceID)
        Maybe (Text, Text) -> [Maybe (Text, Text)] -> [Maybe (Text, Text)]
forall a. a -> [a] -> [a]
: (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
"x-b3-spanid" , Getting Text Word64 Text -> Word64 -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text Word64 Text
forall a. AsHex a => Getter a Text
hexText Word64
ctxSpanID)
        Maybe (Text, Text) -> [Maybe (Text, Text)] -> [Maybe (Text, Text)]
forall a. a -> [a] -> [a]
: (Word64 -> (Text, Text)) -> Maybe Word64 -> Maybe (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text
"x-b3-parentspanid",) (Text -> (Text, Text))
-> (Word64 -> Text) -> Word64 -> (Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Text Word64 Text -> Word64 -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text Word64 Text
forall a. AsHex a => Getter a Text
hexText) Maybe Word64
ctxParentSpanID
        Maybe (Text, Text) -> [Maybe (Text, Text)] -> [Maybe (Text, Text)]
forall a. a -> [a] -> [a]
: (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
"x-b3-sampled", Text -> Text -> Bool -> Text
forall a. a -> a -> Bool -> a
bool Text
"false" Text
"true" (Bool -> Text) -> Bool -> Text
forall a b. (a -> b) -> a -> b
$ Getting Bool SpanContext Bool -> SpanContext -> Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Sampled -> Const Bool Sampled)
-> SpanContext -> Const Bool SpanContext
Lens' SpanContext Sampled
ctxSampled ((Sampled -> Const Bool Sampled)
 -> SpanContext -> Const Bool SpanContext)
-> ((Bool -> Const Bool Bool) -> Sampled -> Const Bool Sampled)
-> Getting Bool SpanContext Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AReview Bool Sampled -> Getter Sampled Bool
forall t b. AReview t b -> Getter b t
re AReview Bool Sampled
Iso' Bool Sampled
_IsSampled) SpanContext
ctx)
        Maybe (Text, Text) -> [Maybe (Text, Text)] -> [Maybe (Text, Text)]
forall a. a -> [a] -> [a]
: ((Text, Text) -> Maybe (Text, Text))
-> [(Text, Text)] -> [Maybe (Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just ((Text, Text) -> Maybe (Text, Text))
-> ((Text, Text) -> (Text, Text))
-> (Text, Text)
-> Maybe (Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter (Text, Text) (Text, Text) Text Text
-> (Text -> Text) -> (Text, Text) -> (Text, Text)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter (Text, Text) (Text, Text) Text Text
forall s t a b. Field1 s t a b => Lens s t a b
_1 (Text
"ot-baggage-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)) (TextMap -> [(Text, Text)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList TextMap
_ctxBaggage)

    toCtx :: TextMap -> Maybe SpanContext
toCtx TextMap
m = TraceID
-> Word64 -> Maybe Word64 -> Sampled -> TextMap -> SpanContext
SpanContext
        (TraceID
 -> Word64 -> Maybe Word64 -> Sampled -> TextMap -> SpanContext)
-> Maybe TraceID
-> Maybe
     (Word64 -> Maybe Word64 -> Sampled -> TextMap -> SpanContext)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> TextMap -> Maybe Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
"x-b3-traceid" TextMap
m Maybe Text -> (Text -> Maybe TraceID) -> Maybe TraceID
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Getting (First TraceID) Hex TraceID -> Hex -> Maybe TraceID
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Getting (First TraceID) Hex TraceID
forall a. AsHex a => Prism' Hex a
_Hex (Hex -> Maybe TraceID) -> (Text -> Hex) -> Text -> Maybe TraceID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Hex
knownHex)
        Maybe (Word64 -> Maybe Word64 -> Sampled -> TextMap -> SpanContext)
-> Maybe Word64
-> Maybe (Maybe Word64 -> Sampled -> TextMap -> SpanContext)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> TextMap -> Maybe Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
"x-b3-spanid"  TextMap
m Maybe Text -> (Text -> Maybe Word64) -> Maybe Word64
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Getting (First Word64) Hex Word64 -> Hex -> Maybe Word64
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Getting (First Word64) Hex Word64
forall a. AsHex a => Prism' Hex a
_Hex (Hex -> Maybe Word64) -> (Text -> Hex) -> Text -> Maybe Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Hex
knownHex)
        Maybe (Maybe Word64 -> Sampled -> TextMap -> SpanContext)
-> Maybe (Maybe Word64)
-> Maybe (Sampled -> TextMap -> SpanContext)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Maybe Word64 -> Maybe (Maybe Word64)
forall a. a -> Maybe a
Just (Maybe Word64 -> Maybe (Maybe Word64))
-> Maybe Word64 -> Maybe (Maybe Word64)
forall a b. (a -> b) -> a -> b
$ Text -> TextMap -> Maybe Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
"x-b3-parentspanid" TextMap
m Maybe Text -> (Text -> Maybe Word64) -> Maybe Word64
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Getting (First Word64) Hex Word64 -> Hex -> Maybe Word64
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Getting (First Word64) Hex Word64
forall a. AsHex a => Prism' Hex a
_Hex (Hex -> Maybe Word64) -> (Text -> Hex) -> Text -> Maybe Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Hex
knownHex)
        Maybe (Sampled -> TextMap -> SpanContext)
-> Maybe Sampled -> Maybe (TextMap -> SpanContext)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TextMap -> Maybe Sampled
forall k a.
(Hashable k, Eq k, Eq a, IsString k, IsString a) =>
HashMap k a -> Maybe Sampled
b3Sampled TextMap
m Maybe Sampled -> Maybe Sampled -> Maybe Sampled
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TextMap -> Maybe Sampled
forall k a.
(Hashable k, Eq k, Eq a, IsString k, IsString a) =>
HashMap k a -> Maybe Sampled
b3Debug TextMap
m Maybe Sampled -> Maybe Sampled -> Maybe Sampled
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Sampled -> Maybe Sampled
forall a. a -> Maybe a
Just Sampled
NotSampled)
        Maybe (TextMap -> SpanContext)
-> Maybe TextMap -> Maybe SpanContext
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TextMap -> Maybe TextMap
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Text -> Text -> Bool) -> TextMap -> TextMap
forall k v. (k -> v -> Bool) -> HashMap k v -> HashMap k v
HashMap.filterWithKey (\Text
k Text
_ -> Text
"ot-baggage-" Text -> Text -> Bool
`isPrefixOf` Text
k) TextMap
m)

    b3Sampled :: HashMap k a -> Maybe Sampled
b3Sampled HashMap k a
m = k -> HashMap k a -> Maybe a
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup k
"x-b3-sampled" HashMap k a
m Maybe a -> (a -> Maybe Sampled) -> Maybe Sampled
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        a
"true" -> Sampled -> Maybe Sampled
forall a. a -> Maybe a
Just Sampled
Sampled
        a
_      -> Maybe Sampled
forall a. Maybe a
Nothing

    b3Debug :: HashMap k a -> Maybe Sampled
b3Debug HashMap k a
m = k -> HashMap k a -> Maybe a
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup k
"x-b3-flags" HashMap k a
m Maybe a -> (a -> Maybe Sampled) -> Maybe Sampled
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        a
"1" -> Sampled -> Maybe Sampled
forall a. a -> Maybe a
Just Sampled
Sampled
        a
_   -> Maybe Sampled
forall a. Maybe a
Nothing

_B3Headers :: Prism' Headers SpanContext
_B3Headers :: p SpanContext (f SpanContext) -> p Headers (f Headers)
_B3Headers = p TextMap (f TextMap) -> p Headers (f Headers)
Iso' Headers TextMap
_HeadersTextMap (p TextMap (f TextMap) -> p Headers (f Headers))
-> (p SpanContext (f SpanContext) -> p TextMap (f TextMap))
-> p SpanContext (f SpanContext)
-> p Headers (f Headers)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p SpanContext (f SpanContext) -> p TextMap (f TextMap)
Prism' TextMap SpanContext
_B3TextMap

-- | Convert between a 'TextMap' and 'Headers'
--
-- Header field values are URL-encoded when converting from 'TextMap' to
-- 'Headers', and URL-decoded when converting the other way.
--
-- Note: validity of header fields is not checked (RFC 7230, 3.2.4)
_HeadersTextMap :: Iso' Headers TextMap
_HeadersTextMap :: p TextMap (f TextMap) -> p Headers (f Headers)
_HeadersTextMap = (Headers -> TextMap)
-> (TextMap -> Headers) -> Iso' Headers TextMap
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso Headers -> TextMap
toTextMap TextMap -> Headers
toHeaders
  where
    toHeaders :: TextMap -> Headers
toHeaders
        = ((Text, Text) -> (CI ByteString, ByteString))
-> [(Text, Text)] -> Headers
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> CI ByteString)
-> (Text -> ByteString)
-> (Text, Text)
-> (CI ByteString, ByteString)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> CI ByteString)
-> (Text -> ByteString) -> Text -> CI ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8)
                     (Getting ByteString ByteString ByteString
-> ByteString -> ByteString
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ByteString ByteString ByteString
forall lazy strict. Strict lazy strict => Iso' lazy strict
strict (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> (Text -> Builder) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
urlEncodeQuery (ByteString -> Builder) -> (Text -> ByteString) -> Text -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8))
        ([(Text, Text)] -> Headers)
-> (TextMap -> [(Text, Text)]) -> TextMap -> Headers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextMap -> [(Text, Text)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList

    toTextMap :: Headers -> TextMap
toTextMap
        = [(Text, Text)] -> TextMap
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList
        ([(Text, Text)] -> TextMap)
-> (Headers -> [(Text, Text)]) -> Headers -> TextMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((CI ByteString, ByteString) -> (Text, Text))
-> Headers -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map ((CI ByteString -> Text)
-> (ByteString -> Text)
-> (CI ByteString, ByteString)
-> (Text, Text)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Text -> Text
toLower (Text -> Text) -> (CI ByteString -> Text) -> CI ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> (CI ByteString -> ByteString) -> CI ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI ByteString -> ByteString
forall s. CI s -> s
CI.original)
                     (ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
urlDecodeQuery))