{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}

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

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

{- |
 Module      :  OpenTelemetry.Baggage
 Copyright   :  (c) Ian Duncan, 2021
 License     :  BSD-3
 Description :  Serializable annotations to add user-defined values to telemetry
 Maintainer  :  Ian Duncan
 Stability   :  experimental
 Portability :  non-portable (GHC extensions)

 Baggage is used to annotate telemetry, adding context and information to metrics, traces, and logs.
 It is a set of name/value pairs describing user-defined properties.

 Note: if you are trying to add data annotations specific to a single trace span, you should use
 'OpenTelemetry.Trace.addAttribute' and 'OpenTelemetry.Trace.addAttributes'
-}
module OpenTelemetry.Baggage (
  -- * Constructing 'Baggage' structures
  Baggage,
  empty,
  fromHashMap,
  values,
  Token,
  token,
  mkToken,
  tokenValue,
  Element (..),
  element,
  property,
  InvalidBaggage (..),

  -- * Modifying 'Baggage'
  insert,
  delete,

  -- * Encoding and decoding 'Baggage'
  encodeBaggageHeader,
  encodeBaggageHeaderB,
  decodeBaggageHeader,
  decodeBaggageHeaderP,
) where

import Control.Applicative hiding (empty)
import qualified Data.Attoparsec.ByteString.Char8 as P
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Builder.Extra as BS
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Internal as BS
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Unsafe (unsafePackAddressLen)
import Data.CharSet (CharSet)
import qualified Data.CharSet as C
import qualified Data.HashMap.Strict as H
import Data.Hashable
import Data.List (intersperse)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
import Network.HTTP.Types.URI
import System.IO.Unsafe


{- | A key for a baggage entry, restricted to the set of valid characters
 specified in the @token@ definition of RFC 2616:

 https://www.rfc-editor.org/rfc/rfc2616#section-2.2
-}
newtype Token = Token ByteString
  deriving stock (Int -> Token -> ShowS
[Token] -> ShowS
Token -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Token] -> ShowS
$cshowList :: [Token] -> ShowS
show :: Token -> String
$cshow :: Token -> String
showsPrec :: Int -> Token -> ShowS
$cshowsPrec :: Int -> Token -> ShowS
Show, Token -> Token -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c== :: Token -> Token -> Bool
Eq, Eq Token
Token -> Token -> Bool
Token -> Token -> Ordering
Token -> Token -> Token
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Token -> Token -> Token
$cmin :: Token -> Token -> Token
max :: Token -> Token -> Token
$cmax :: Token -> Token -> Token
>= :: Token -> Token -> Bool
$c>= :: Token -> Token -> Bool
> :: Token -> Token -> Bool
$c> :: Token -> Token -> Bool
<= :: Token -> Token -> Bool
$c<= :: Token -> Token -> Bool
< :: Token -> Token -> Bool
$c< :: Token -> Token -> Bool
compare :: Token -> Token -> Ordering
$ccompare :: Token -> Token -> Ordering
Ord)
  deriving newtype (Eq Token
Int -> Token -> Int
Token -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Token -> Int
$chash :: Token -> Int
hashWithSalt :: Int -> Token -> Int
$chashWithSalt :: Int -> Token -> Int
Hashable)


-- | Convert a 'Token' into a 'ByteString'
tokenValue :: Token -> ByteString
tokenValue :: Token -> ByteString
tokenValue (Token ByteString
t) = ByteString
t

#if MIN_VERSION_template_haskell(2, 17, 0)
instance Lift Token where
  liftTyped :: forall (m :: * -> *). Quote m => Token -> Code m Token
liftTyped (Token ByteString
tok) = forall a (m :: * -> *). m (TExp a) -> Code m a
liftCode forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). Quote m => m Exp -> m (TExp a)
unsafeTExpCoerce forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Monad m => ByteString -> m Exp
bsToExp ByteString
tok
#else
instance Lift Token where
  liftTyped (Token tok) = unsafeTExpCoerce $ bsToExp tok
#endif


-- | An entry into the baggage
data Element = Element
  { Element -> Text
value :: Text
  , Element -> [Property]
properties :: [Property]
  }
  deriving stock (Int -> Element -> ShowS
[Element] -> ShowS
Element -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Element] -> ShowS
$cshowList :: [Element] -> ShowS
show :: Element -> String
$cshow :: Element -> String
showsPrec :: Int -> Element -> ShowS
$cshowsPrec :: Int -> Element -> ShowS
Show, Element -> Element -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Element -> Element -> Bool
$c/= :: Element -> Element -> Bool
== :: Element -> Element -> Bool
$c== :: Element -> Element -> Bool
Eq)


element :: Text -> Element
element :: Text -> Element
element Text
t = Text -> [Property] -> Element
Element Text
t []


data Property = Property
  { Property -> Token
propertyKey :: Token
  , Property -> Maybe Text
propertyValue :: Maybe Text
  }
  deriving stock (Int -> Property -> ShowS
[Property] -> ShowS
Property -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Property] -> ShowS
$cshowList :: [Property] -> ShowS
show :: Property -> String
$cshow :: Property -> String
showsPrec :: Int -> Property -> ShowS
$cshowsPrec :: Int -> Property -> ShowS
Show, Property -> Property -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Property -> Property -> Bool
$c/= :: Property -> Property -> Bool
== :: Property -> Property -> Bool
$c== :: Property -> Property -> Bool
Eq)


property :: Token -> Maybe Text -> Property
property :: Token -> Maybe Text -> Property
property = Token -> Maybe Text -> Property
Property


{- | Baggage is used to annotate telemetry, adding context and information to metrics, traces, and logs.
 It is a set of name/value pairs describing user-defined properties.
 Each name in Baggage is associated with exactly one value.
-}
newtype Baggage = Baggage (H.HashMap Token Element)
  deriving stock (Int -> Baggage -> ShowS
[Baggage] -> ShowS
Baggage -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Baggage] -> ShowS
$cshowList :: [Baggage] -> ShowS
show :: Baggage -> String
$cshow :: Baggage -> String
showsPrec :: Int -> Baggage -> ShowS
$cshowsPrec :: Int -> Baggage -> ShowS
Show, Baggage -> Baggage -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Baggage -> Baggage -> Bool
$c/= :: Baggage -> Baggage -> Bool
== :: Baggage -> Baggage -> Bool
$c== :: Baggage -> Baggage -> Bool
Eq)
  deriving newtype (NonEmpty Baggage -> Baggage
Baggage -> Baggage -> Baggage
forall b. Integral b => b -> Baggage -> Baggage
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Baggage -> Baggage
$cstimes :: forall b. Integral b => b -> Baggage -> Baggage
sconcat :: NonEmpty Baggage -> Baggage
$csconcat :: NonEmpty Baggage -> Baggage
<> :: Baggage -> Baggage -> Baggage
$c<> :: Baggage -> Baggage -> Baggage
Semigroup)


tokenCharacters :: CharSet
tokenCharacters :: CharSet
tokenCharacters = String -> CharSet
C.fromList String
"!#$%&'*+-.^_`|~0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"


-- Ripped from file-embed-0.0.13
bsToExp :: (Monad m) => ByteString -> m Exp
#if MIN_VERSION_template_haskell(2, 5, 0)
bsToExp :: forall (m :: * -> *). Monad m => ByteString -> m Exp
bsToExp ByteString
bs =
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE 'Token
      Exp -> Exp -> Exp
`AppE` (Name -> Exp
VarE 'unsafePerformIO
      Exp -> Exp -> Exp
`AppE` (Name -> Exp
VarE 'unsafePackAddressLen
      Exp -> Exp -> Exp
`AppE` Lit -> Exp
LitE (Integer -> Lit
IntegerL forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
bs)
#if MIN_VERSION_template_haskell(2, 16, 0)
      Exp -> Exp -> Exp
`AppE` Lit -> Exp
LitE (Bytes -> Lit
bytesPrimL (
                let BS.PS ForeignPtr Word8
ptr Int
off Int
sz = ByteString
bs
                in  ForeignPtr Word8 -> Word -> Word -> Bytes
mkBytes ForeignPtr Word8
ptr (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz)))))
#elif MIN_VERSION_template_haskell(2, 8, 0)
      `AppE` LitE (StringPrimL $ B.unpack bs)))
#else
      `AppE` LitE (StringPrimL $ B8.unpack bs)))
#endif
#else
bsToExp bs = do
    helper <- [| stringToBs |]
    let chars = B8.unpack bs
    return $! AppE helper $! LitE $! StringL chars
#endif


mkToken :: Text -> Maybe Token
mkToken :: Text -> Maybe Token
mkToken Text
txt
  | Text
txt Text -> Int -> Ordering
`T.compareLength` Int
4096 forall a. Eq a => a -> a -> Bool
== Ordering
GT = forall a. Maybe a
Nothing
  | (Char -> Bool) -> Text -> Bool
T.all (Char -> CharSet -> Bool
`C.member` CharSet
tokenCharacters) Text
txt = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ByteString -> Token
Token forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
txt
  | Bool
otherwise = forall a. Maybe a
Nothing


token :: QuasiQuoter
token :: QuasiQuoter
token =
  QuasiQuoter
    { quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
parseExp
    , quotePat :: String -> Q Pat
quotePat = \String
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Token as pattern not implemented"
    , quoteType :: String -> Q Type
quoteType = \String
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Can't use a Baggage Token as a type"
    , quoteDec :: String -> Q [Dec]
quoteDec = \String
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Can't use a Baggage Token as a declaration"
    }
  where
    parseExp :: String -> Q Exp
parseExp = \String
str -> case Text -> Maybe Token
mkToken forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
str of
      Maybe Token
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail (forall a. Show a => a -> String
show String
str forall a. [a] -> [a] -> [a]
++ String
" is not a valid Token.")
      Just Token
tok -> forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift Token
tok


data InvalidBaggage
  = BaggageTooLong
  | MemberTooLong
  | TooManyListMembers
  | Empty


-- TODO: The fact that this can be a max of 8192 bytes
-- should allow this to optimized pretty heavily
encodeBaggageHeader :: Baggage -> ByteString
encodeBaggageHeader :: Baggage -> ByteString
encodeBaggageHeader =
  ByteString -> ByteString
L.toStrict
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. AllocationStrategy -> ByteString -> Builder -> ByteString
BS.toLazyByteStringWith (Int -> Int -> AllocationStrategy
BS.untrimmedStrategy (Int
8192 forall a. Num a => a -> a -> a
+ Int
16) Int
BS.smallChunkSize) ByteString
L.empty
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Baggage -> Builder
encodeBaggageHeaderB


encodeBaggageHeaderB :: Baggage -> B.Builder
encodeBaggageHeaderB :: Baggage -> Builder
encodeBaggageHeaderB (Baggage HashMap Token Element
bmap) =
  forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$
    forall a. a -> [a] -> [a]
intersperse (Char -> Builder
B.char7 Char
',') forall a b. (a -> b) -> a -> b
$
      forall a b. (a -> b) -> [a] -> [b]
map (Token, Element) -> Builder
go forall a b. (a -> b) -> a -> b
$
        forall k v. HashMap k v -> [(k, v)]
H.toList HashMap Token Element
bmap
  where
    go :: (Token, Element) -> Builder
go (Token ByteString
k, Element Text
v [Property]
props) =
      ByteString -> Builder
B.byteString ByteString
k
        forall a. Semigroup a => a -> a -> a
<> Char -> Builder
B.char7 Char
'='
        forall a. Semigroup a => a -> a -> a
<> Bool -> ByteString -> Builder
urlEncodeBuilder Bool
False (Text -> ByteString
encodeUtf8 Text
v)
        forall a. Semigroup a => a -> a -> a
<> (forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse (Char -> Builder
B.char7 Char
';') forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Property -> Builder
propEncoder [Property]
props)
    propEncoder :: Property -> Builder
propEncoder (Property (Token ByteString
k) Maybe Text
mv) =
      ByteString -> Builder
B.byteString ByteString
k
        forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          forall a. Monoid a => a
mempty
          (\Text
v -> Char -> Builder
B.char7 Char
'=' forall a. Semigroup a => a -> a -> a
<> Bool -> ByteString -> Builder
urlEncodeBuilder Bool
False (Text -> ByteString
encodeUtf8 Text
v))
          Maybe Text
mv


decodeBaggageHeader :: ByteString -> Either String Baggage
decodeBaggageHeader :: ByteString -> Either String Baggage
decodeBaggageHeader = forall a. Parser a -> ByteString -> Either String a
P.parseOnly Parser Baggage
decodeBaggageHeaderP


decodeBaggageHeaderP :: P.Parser Baggage
decodeBaggageHeaderP :: Parser Baggage
decodeBaggageHeaderP = do
  Parser ()
owsP
  (Token, Element)
firstMember <- Parser (Token, Element)
memberP
  [(Token, Element)]
otherMembers <- forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser ()
owsP forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Parser ByteString Word8
P.char8 Char
',' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
owsP forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser (Token, Element)
memberP)
  Parser ()
owsP
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ HashMap Token Element -> Baggage
Baggage forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
H.fromList ((Token, Element)
firstMember forall a. a -> [a] -> [a]
: [(Token, Element)]
otherMembers)
  where
    owsSet :: CharSet
owsSet = String -> CharSet
C.fromList String
" \t"
    owsP :: Parser ()
owsP = (Char -> Bool) -> Parser ()
P.skipWhile (Char -> CharSet -> Bool
`C.member` CharSet
owsSet)
    memberP :: P.Parser (Token, Element)
    memberP :: Parser (Token, Element)
memberP = do
      Token
tok <- Parser Token
tokenP
      Parser ()
owsP
      Word8
_ <- Char -> Parser ByteString Word8
P.char8 Char
'='
      Parser ()
owsP
      Text
val <- Parser ByteString Text
valP
      [Property]
props <- forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser ()
owsP forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Parser ByteString Word8
P.char8 Char
';' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
owsP forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ByteString Property
propertyP)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (Token
tok, Text -> [Property] -> Element
Element Text
val [Property]
props)
    valueSet :: CharSet
valueSet =
      String -> CharSet
C.fromList forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [ [Char
'\x21']
          , [Char
'\x23' .. Char
'\x2B']
          , [Char
'\x2D' .. Char
'\x3A']
          , [Char
'\x3C' .. Char
'\x5B']
          , [Char
'\x5D' .. Char
'\x7E']
          ]
    tokenP :: P.Parser Token
    tokenP :: Parser Token
tokenP = ByteString -> Token
Token forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser ByteString
P.takeWhile1 (Char -> CharSet -> Bool
`C.member` CharSet
tokenCharacters)
    valP :: Parser ByteString Text
valP = ByteString -> Text
decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ByteString -> ByteString
urlDecode Bool
False forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser ByteString
P.takeWhile (Char -> CharSet -> Bool
`C.member` CharSet
valueSet)
    propertyP :: P.Parser Property
    propertyP :: Parser ByteString Property
propertyP = do
      Token
key <- Parser Token
tokenP
      Parser ()
owsP
      Maybe Text
val <- forall (f :: * -> *) a. Alternative f => a -> f a -> f a
P.option forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ do
        Word8
_ <- Char -> Parser ByteString Word8
P.char8 Char
'='
        Parser ()
owsP
        forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Text
valP
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Token -> Maybe Text -> Property
Property Token
key Maybe Text
val


-- | An empty initial baggage value
empty :: Baggage
empty :: Baggage
empty = HashMap Token Element -> Baggage
Baggage forall k v. HashMap k v
H.empty


insert
  :: Token
  -- ^ The name for which to set the value
  -> Element
  -- ^ The value to set. Use 'element' to construct a well-formed element value.
  -> Baggage
  -> Baggage
insert :: Token -> Element -> Baggage -> Baggage
insert Token
k Element
v (Baggage HashMap Token Element
c) = HashMap Token Element -> Baggage
Baggage (forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
H.insert Token
k Element
v HashMap Token Element
c)


-- | Delete a key/value pair from the baggage.
delete :: Token -> Baggage -> Baggage
delete :: Token -> Baggage -> Baggage
delete Token
k (Baggage HashMap Token Element
c) = HashMap Token Element -> Baggage
Baggage (forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
H.delete Token
k HashMap Token Element
c)


{- | Returns the name/value pairs in the `Baggage`. The order of name/value pairs
 is not significant.

 @since 0.0.1.0
-}
values :: Baggage -> H.HashMap Token Element
values :: Baggage -> HashMap Token Element
values (Baggage HashMap Token Element
m) = HashMap Token Element
m


-- | Convert a 'H.HashMap' into 'Baggage'
fromHashMap :: H.HashMap Token Element -> Baggage
fromHashMap :: HashMap Token Element -> Baggage
fromHashMap = HashMap Token Element -> Baggage
Baggage