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

{- |
Module      :  OpenTelemetry.Baggage
Copyright   :  (c) Ian Duncan, 2021-2026
License     :  BSD-3
Description :  Propagated key-value metadata for cross-service context
Stability   :  experimental

= Overview

Baggage is a set of key-value pairs that propagate alongside trace context
across service boundaries (typically via the @baggage@ HTTP header). Use it
to pass metadata like tenant IDs, feature flags, or routing hints through
your distributed system.

Baggage is /not/ for span-specific annotations. Use 'OpenTelemetry.Trace.addAttribute'
for that.

= Quick example

@
import OpenTelemetry.Baggage

-- Create baggage:
let bag = insert [token|tenant-id|] (element "abc123")
        $ insert [token|region|] (element "us-east-1")
        $ empty

-- Encode for HTTP propagation:
let headerValue = encodeBaggageHeader bag
-- "tenant-id=abc123,region=us-east-1"

-- Decode from an incoming header:
case decodeBaggageHeader headerBytes of
  Right bag -> -- use the baggage
  Left err  -> -- malformed header
@

= Thread-local baggage

Use the functions in "OpenTelemetry.Context.ThreadLocal" to get\/set baggage
on the current thread:

@
import OpenTelemetry.Context.ThreadLocal (getContext, adjustContext)
import OpenTelemetry.Context (insertBaggage, lookupBaggage)

-- Read:
mbag <- lookupBaggage \<$\> getContext
-- Write:
adjustContext (insertBaggage myBaggage)
@

= Limits

W3C Baggage specification enforces:

* Max 8192 bytes total serialized size
* Max 4096 bytes per member
* Max 180 members

'insertChecked' validates these limits and returns 'Left' 'InvalidBaggage'
on violation.

= Spec reference

<https://opentelemetry.io/docs/specs/otel/baggage/api/>
-}
module OpenTelemetry.Baggage (
  -- * Constructing 'Baggage' structures
  Baggage,
  empty,
  fromHashMap,
  values,
  Token,
  token,
  mkToken,
  tokenValue,
  Element (..),
  element,
  property,
  InvalidBaggage (..),

  -- * Limits (W3C Baggage specification)
  maxBaggageBytes,
  maxMemberBytes,
  maxMembers,

  -- * Modifying 'Baggage'
  insert,
  insertChecked,
  delete,

  -- * Querying 'Baggage'
  getValue,

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

import Control.Monad (when)
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.Char8 as B8
import qualified Data.ByteString.Internal as BS
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Unsafe (unsafePackAddressLen)
import qualified Data.HashMap.Strict as H
import Data.Hashable
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8', encodeUtf8)
import Data.Word (Word8)
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
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

 @since 0.0.1.0
-}
newtype Token = Token ByteString
  deriving stock (Int -> Token -> ShowS
[Token] -> ShowS
Token -> [Char]
(Int -> Token -> ShowS)
-> (Token -> [Char]) -> ([Token] -> ShowS) -> Show Token
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Token -> ShowS
showsPrec :: Int -> Token -> ShowS
$cshow :: Token -> [Char]
show :: Token -> [Char]
$cshowList :: [Token] -> ShowS
showList :: [Token] -> ShowS
Show, Token -> Token -> Bool
(Token -> Token -> Bool) -> (Token -> Token -> Bool) -> Eq Token
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
/= :: Token -> Token -> Bool
Eq, Eq Token
Eq Token =>
(Token -> Token -> Ordering)
-> (Token -> Token -> Bool)
-> (Token -> Token -> Bool)
-> (Token -> Token -> Bool)
-> (Token -> Token -> Bool)
-> (Token -> Token -> Token)
-> (Token -> Token -> Token)
-> Ord 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
$ccompare :: Token -> Token -> Ordering
compare :: Token -> Token -> Ordering
$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
>= :: Token -> Token -> Bool
$cmax :: Token -> Token -> Token
max :: Token -> Token -> Token
$cmin :: Token -> Token -> Token
min :: Token -> Token -> Token
Ord)
  deriving newtype (Eq Token
Eq Token =>
(Int -> Token -> Int) -> (Token -> Int) -> Hashable Token
Int -> Token -> Int
Token -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> Token -> Int
hashWithSalt :: Int -> Token -> Int
$chash :: Token -> Int
hash :: Token -> Int
Hashable)


{- | Convert a 'Token' into a 'ByteString'

@since 0.0.1.0
-}
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) = m (TExp Token) -> Code m Token
forall a (m :: * -> *). m (TExp a) -> Code m a
liftCode (m (TExp Token) -> Code m Token) -> m (TExp Token) -> Code m Token
forall a b. (a -> b) -> a -> b
$ m Exp -> m (TExp Token)
forall a (m :: * -> *). Quote m => m Exp -> m (TExp a)
unsafeTExpCoerce (m Exp -> m (TExp Token)) -> m Exp -> m (TExp Token)
forall a b. (a -> b) -> a -> b
$ ByteString -> m Exp
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

@since 0.0.1.0
-}
data Element = Element
  { Element -> Text
value :: Text
  , Element -> [Property]
properties :: [Property]
  }
  deriving stock (Int -> Element -> ShowS
[Element] -> ShowS
Element -> [Char]
(Int -> Element -> ShowS)
-> (Element -> [Char]) -> ([Element] -> ShowS) -> Show Element
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Element -> ShowS
showsPrec :: Int -> Element -> ShowS
$cshow :: Element -> [Char]
show :: Element -> [Char]
$cshowList :: [Element] -> ShowS
showList :: [Element] -> ShowS
Show, Element -> Element -> Bool
(Element -> Element -> Bool)
-> (Element -> Element -> Bool) -> Eq Element
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Element -> Element -> Bool
== :: Element -> Element -> Bool
$c/= :: Element -> Element -> Bool
/= :: Element -> Element -> Bool
Eq)


-- | @since 0.0.1.0
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 -> [Char]
(Int -> Property -> ShowS)
-> (Property -> [Char]) -> ([Property] -> ShowS) -> Show Property
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Property -> ShowS
showsPrec :: Int -> Property -> ShowS
$cshow :: Property -> [Char]
show :: Property -> [Char]
$cshowList :: [Property] -> ShowS
showList :: [Property] -> ShowS
Show, Property -> Property -> Bool
(Property -> Property -> Bool)
-> (Property -> Property -> Bool) -> Eq Property
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Property -> Property -> Bool
== :: Property -> Property -> Bool
$c/= :: Property -> Property -> Bool
/= :: Property -> Property -> Bool
Eq)


-- | @since 0.0.1.0
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.

 @since 0.0.1.0
-}
newtype Baggage = Baggage (H.HashMap Token Element)
  deriving stock (Int -> Baggage -> ShowS
[Baggage] -> ShowS
Baggage -> [Char]
(Int -> Baggage -> ShowS)
-> (Baggage -> [Char]) -> ([Baggage] -> ShowS) -> Show Baggage
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Baggage -> ShowS
showsPrec :: Int -> Baggage -> ShowS
$cshow :: Baggage -> [Char]
show :: Baggage -> [Char]
$cshowList :: [Baggage] -> ShowS
showList :: [Baggage] -> ShowS
Show, Baggage -> Baggage -> Bool
(Baggage -> Baggage -> Bool)
-> (Baggage -> Baggage -> Bool) -> Eq Baggage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Baggage -> Baggage -> Bool
== :: Baggage -> Baggage -> Bool
$c/= :: Baggage -> Baggage -> Bool
/= :: Baggage -> Baggage -> Bool
Eq)
  deriving newtype (NonEmpty Baggage -> Baggage
Baggage -> Baggage -> Baggage
(Baggage -> Baggage -> Baggage)
-> (NonEmpty Baggage -> Baggage)
-> (forall b. Integral b => b -> Baggage -> Baggage)
-> Semigroup 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
$c<> :: Baggage -> Baggage -> Baggage
<> :: Baggage -> Baggage -> Baggage
$csconcat :: NonEmpty Baggage -> Baggage
sconcat :: NonEmpty Baggage -> Baggage
$cstimes :: forall b. Integral b => b -> Baggage -> Baggage
stimes :: forall b. Integral b => b -> Baggage -> Baggage
Semigroup)


-- | RFC 2616 token character predicate (no allocation, branchless via table)
isTokenChar :: Char -> Bool
isTokenChar :: Char -> Bool
isTokenChar Char
c = Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
128 Bool -> Bool -> Bool
&& ByteString
tokenTable HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
`BS.index` Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0
  where
    w :: Int
w = Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c
{-# INLINE isTokenChar #-}


-- 128-byte lookup: 1 = valid token char, 0 = invalid
tokenTable :: ByteString
tokenTable :: ByteString
tokenTable =
  [Word8] -> ByteString
BS.pack
    [ Word8
0
    , Word8
0
    , Word8
0
    , Word8
0
    , Word8
0
    , Word8
0
    , Word8
0
    , Word8
0
    , Word8
0
    , Word8
0
    , Word8
0
    , Word8
0
    , Word8
0
    , Word8
0
    , Word8
0
    , Word8
0 -- 0x00-0x0f
    , Word8
0
    , Word8
0
    , Word8
0
    , Word8
0
    , Word8
0
    , Word8
0
    , Word8
0
    , Word8
0
    , Word8
0
    , Word8
0
    , Word8
0
    , Word8
0
    , Word8
0
    , Word8
0
    , Word8
0
    , Word8
0 -- 0x10-0x1f
    , Word8
0
    , Word8
1
    , Word8
0
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
0
    , Word8
0
    , Word8
1
    , Word8
1
    , Word8
0
    , Word8
1
    , Word8
1
    , Word8
0 --  ! # $ % & ' * + - .
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
0
    , Word8
0
    , Word8
0
    , Word8
0
    , Word8
0
    , Word8
0 -- 0-9
    , Word8
0
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1 -- A-O
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
0
    , Word8
0
    , Word8
0
    , Word8
1
    , Word8
1 -- P-Z ^ _
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1 -- ` a-o
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
1
    , Word8
0
    , Word8
1
    , Word8
0
    , Word8
1
    , Word8
0 -- p-z | ~
    ]
{-# NOINLINE tokenTable #-}


-- 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 =
    Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> m Exp) -> Exp -> m Exp
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 (Integer -> Lit) -> Integer -> Lit
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
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 (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) (Int -> Word
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


-- | @since 0.0.1.0
mkToken :: Text -> Maybe Token
mkToken :: Text -> Maybe Token
mkToken Text
txt
  | Text -> Bool
T.null Text
txt = Maybe Token
forall a. Maybe a
Nothing
  | Text
txt Text -> Int -> Ordering
`T.compareLength` Int
4096 Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
GT = Maybe Token
forall a. Maybe a
Nothing
  | (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isTokenChar Text
txt = Token -> Maybe Token
forall a. a -> Maybe a
Just (Token -> Maybe Token) -> Token -> Maybe Token
forall a b. (a -> b) -> a -> b
$ ByteString -> Token
Token (ByteString -> Token) -> ByteString -> Token
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
txt
  | Bool
otherwise = Maybe Token
forall a. Maybe a
Nothing


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


-- | @since 0.0.1.0
data InvalidBaggage
  = BaggageTooLong
  | MemberTooLong
  | TooManyListMembers
  | Empty
  deriving stock (Int -> InvalidBaggage -> ShowS
[InvalidBaggage] -> ShowS
InvalidBaggage -> [Char]
(Int -> InvalidBaggage -> ShowS)
-> (InvalidBaggage -> [Char])
-> ([InvalidBaggage] -> ShowS)
-> Show InvalidBaggage
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InvalidBaggage -> ShowS
showsPrec :: Int -> InvalidBaggage -> ShowS
$cshow :: InvalidBaggage -> [Char]
show :: InvalidBaggage -> [Char]
$cshowList :: [InvalidBaggage] -> ShowS
showList :: [InvalidBaggage] -> ShowS
Show, InvalidBaggage -> InvalidBaggage -> Bool
(InvalidBaggage -> InvalidBaggage -> Bool)
-> (InvalidBaggage -> InvalidBaggage -> Bool) -> Eq InvalidBaggage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: InvalidBaggage -> InvalidBaggage -> Bool
== :: InvalidBaggage -> InvalidBaggage -> Bool
$c/= :: InvalidBaggage -> InvalidBaggage -> Bool
/= :: InvalidBaggage -> InvalidBaggage -> Bool
Eq)


-- | @since 0.0.1.0
encodeBaggageHeader :: Baggage -> ByteString
encodeBaggageHeader :: Baggage -> ByteString
encodeBaggageHeader =
  LazyByteString -> ByteString
L.toStrict
    (LazyByteString -> ByteString)
-> (Baggage -> LazyByteString) -> Baggage -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AllocationStrategy -> LazyByteString -> Builder -> LazyByteString
BS.toLazyByteStringWith (Int -> Int -> AllocationStrategy
BS.untrimmedStrategy (Int
8192 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
16) Int
BS.smallChunkSize) LazyByteString
L.empty
    (Builder -> LazyByteString)
-> (Baggage -> Builder) -> Baggage -> LazyByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Baggage -> Builder
encodeBaggageHeaderB


-- | @since 0.0.1.0
encodeBaggageHeaderB :: Baggage -> B.Builder
encodeBaggageHeaderB :: Baggage -> Builder
encodeBaggageHeaderB (Baggage HashMap Token Element
bmap) =
  Int -> Bool -> [(Token, Element)] -> Builder
go Int
0 Bool
True (Int -> [(Token, Element)] -> [(Token, Element)]
forall a. Int -> [a] -> [a]
take Int
maxMembers ([(Token, Element)] -> [(Token, Element)])
-> [(Token, Element)] -> [(Token, Element)]
forall a b. (a -> b) -> a -> b
$ HashMap Token Element -> [(Token, Element)]
forall k v. HashMap k v -> [(k, v)]
H.toList HashMap Token Element
bmap)
  where
    go :: Int -> Bool -> [(Token, Element)] -> B.Builder
    go :: Int -> Bool -> [(Token, Element)] -> Builder
go Int
_ Bool
_ [] = Builder
forall a. Monoid a => a
mempty
    go Int
totalSoFar Bool
isFirst ((Token
tok, Element
el) : [(Token, Element)]
rest) =
      let memberBs :: ByteString
memberBs = Builder -> ByteString
builderToStrict (Token -> Element -> Builder
encodeMemberB Token
tok Element
el)
          memberLen :: Int
memberLen = ByteString -> Int
BS.length ByteString
memberBs
          sep :: Int
sep = if Bool
isFirst then Int
0 else Int
1
          newTotal :: Int
newTotal = Int
totalSoFar Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sep Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
memberLen
      in if Int
memberLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxMemberBytes
           then Int -> Bool -> [(Token, Element)] -> Builder
go Int
totalSoFar Bool
isFirst [(Token, Element)]
rest
           else
             if Int
newTotal Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxBaggageBytes
               then Builder
forall a. Monoid a => a
mempty
               else
                 (if Bool
isFirst then Builder
forall a. Monoid a => a
mempty else Char -> Builder
B.char7 Char
',')
                   Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
B.byteString ByteString
memberBs
                   Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Bool -> [(Token, Element)] -> Builder
go Int
newTotal Bool
False [(Token, Element)]
rest


encodeMemberB :: Token -> Element -> B.Builder
encodeMemberB :: Token -> Element -> Builder
encodeMemberB (Token ByteString
k) (Element Text
v [Property]
props) =
  ByteString -> Builder
B.byteString ByteString
k
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
B.char7 Char
'='
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
percentEncodeBuilder (Text -> ByteString
encodeUtf8 Text
v)
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ((Property -> Builder) -> [Property] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (\Property
p -> Char -> Builder
B.char7 Char
';' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Property -> Builder
propEncoderB Property
p) [Property]
props)


propEncoderB :: Property -> B.Builder
propEncoderB :: Property -> Builder
propEncoderB (Property (Token ByteString
k) Maybe Text
mv) =
  ByteString -> Builder
B.byteString ByteString
k
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> (Text -> Builder) -> Maybe Text -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      Builder
forall a. Monoid a => a
mempty
      (\Text
v -> Char -> Builder
B.char7 Char
'=' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
percentEncodeBuilder (Text -> ByteString
encodeUtf8 Text
v))
      Maybe Text
mv


builderToStrict :: B.Builder -> ByteString
builderToStrict :: Builder -> ByteString
builderToStrict = LazyByteString -> ByteString
L.toStrict (LazyByteString -> ByteString)
-> (Builder -> LazyByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LazyByteString
B.toLazyByteString


{- | W3C Baggage: max 8192 bytes total, max 180 members, max 4096 bytes per member

@since 0.0.1.0
-}
maxBaggageBytes, maxMemberBytes, maxMembers :: Int
maxBaggageBytes :: Int
maxBaggageBytes = Int
8192
maxMemberBytes :: Int
maxMemberBytes = Int
4096
maxMembers :: Int
maxMembers = Int
180


-- | @since 0.0.1.0
decodeBaggageHeader :: ByteString -> Either String Baggage
decodeBaggageHeader :: ByteString -> Either [Char] Baggage
decodeBaggageHeader ByteString
bs
  | ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxBaggageBytes = [Char] -> Either [Char] Baggage
forall a b. a -> Either a b
Left [Char]
"Baggage header exceeds 8192 byte limit"
  | Bool
otherwise = ByteString -> Either [Char] Baggage
parseBaggageHeader ByteString
bs


parseBaggageHeader :: ByteString -> Either String Baggage
parseBaggageHeader :: ByteString -> Either [Char] Baggage
parseBaggageHeader ByteString
input = do
  let stripped :: ByteString
stripped = ByteString -> ByteString
stripOWS ByteString
input
  Bool -> Either [Char] () -> Either [Char] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Bool
BS.null ByteString
stripped) (Either [Char] () -> Either [Char] ())
-> Either [Char] () -> Either [Char] ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left [Char]
"Empty baggage header"
  let rawMembers :: [ByteString]
rawMembers = Word8 -> ByteString -> [ByteString]
splitOnByte Word8
0x2C ByteString
stripped -- ','
  Bool -> Either [Char] () -> Either [Char] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([ByteString] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
rawMembers Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxMembers) (Either [Char] () -> Either [Char] ())
-> Either [Char] () -> Either [Char] ()
forall a b. (a -> b) -> a -> b
$
    [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left ([Char]
"Baggage has more than " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
maxMembers [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" members")
  members <- (ByteString -> Either [Char] (Token, Element))
-> [ByteString] -> Either [Char] [(Token, Element)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ByteString -> Either [Char] (Token, Element)
parseMember [ByteString]
rawMembers
  pure $ Baggage $ H.fromList members


parseMember :: ByteString -> Either String (Token, Element)
parseMember :: ByteString -> Either [Char] (Token, Element)
parseMember ByteString
raw = do
  let s :: ByteString
s = ByteString -> ByteString
stripOWS ByteString
raw
  let (ByteString
keyBs, ByteString
rest0) = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
B8.span Char -> Bool
isTokenChar ByteString
s
  Bool -> Either [Char] () -> Either [Char] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Bool
BS.null ByteString
keyBs) (Either [Char] () -> Either [Char] ())
-> Either [Char] () -> Either [Char] ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left [Char]
"Expected token in baggage member"
  let rest1 :: ByteString
rest1 = ByteString -> ByteString
stripOWS ByteString
rest0
  rest2 <- Word8 -> ByteString -> Either [Char] ByteString
expectByte Word8
0x3D ByteString
rest1 -- '='
  let rest3 = ByteString -> ByteString
stripOWS ByteString
rest2
      (valBs, rest4) = BS.span isValueByte rest3
  val <- case decodeUtf8' (percentDecode valBs) of
    Right Text
t -> Text -> Either [Char] Text
forall a b. b -> Either a b
Right Text
t
    Left UnicodeException
_ -> [Char] -> Either [Char] Text
forall a b. a -> Either a b
Left [Char]
"Invalid UTF-8 in baggage value"
  props <- parseProperties rest4
  pure (Token keyBs, Element val props)


parseProperties :: ByteString -> Either String [Property]
parseProperties :: ByteString -> Either [Char] [Property]
parseProperties ByteString
bs = ByteString -> Either [Char] [Property]
go (ByteString -> ByteString
stripOWS ByteString
bs)
  where
    go :: ByteString -> Either [Char] [Property]
go ByteString
s
      | ByteString -> Bool
BS.null ByteString
s = [Property] -> Either [Char] [Property]
forall a b. b -> Either a b
Right []
      | HasCallStack => ByteString -> Word8
ByteString -> Word8
BS.head ByteString
s Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x3B = do
          -- ';'
          let s1 :: ByteString
s1 = ByteString -> ByteString
stripOWS (HasCallStack => ByteString -> ByteString
ByteString -> ByteString
BS.tail ByteString
s)
              (ByteString
keyBs, ByteString
rest0) = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
B8.span Char -> Bool
isTokenChar ByteString
s1
          Bool -> Either [Char] () -> Either [Char] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Bool
BS.null ByteString
keyBs) (Either [Char] () -> Either [Char] ())
-> Either [Char] () -> Either [Char] ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left [Char]
"Expected token in baggage property"
          let rest1 :: ByteString
rest1 = ByteString -> ByteString
stripOWS ByteString
rest0
          if Bool -> Bool
not (ByteString -> Bool
BS.null ByteString
rest1) Bool -> Bool -> Bool
&& HasCallStack => ByteString -> Word8
ByteString -> Word8
BS.head ByteString
rest1 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x3D -- '='
            then do
              let rest2 :: ByteString
rest2 = ByteString -> ByteString
stripOWS (HasCallStack => ByteString -> ByteString
ByteString -> ByteString
BS.tail ByteString
rest1)
                  (ByteString
valBs, ByteString
rest3) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
BS.span Word8 -> Bool
isValueByte ByteString
rest2
              rest <- ByteString -> Either [Char] [Property]
go (ByteString -> ByteString
stripOWS ByteString
rest3)
              propVal <- case decodeUtf8' (percentDecode valBs) of
                Right Text
t -> Text -> Either [Char] Text
forall a b. b -> Either a b
Right Text
t
                Left UnicodeException
_ -> [Char] -> Either [Char] Text
forall a b. a -> Either a b
Left [Char]
"Invalid UTF-8 in baggage property value"
              pure $ Property (Token keyBs) (Just propVal) : rest
            else do
              rest <- ByteString -> Either [Char] [Property]
go ByteString
rest1
              pure $ Property (Token keyBs) Nothing : rest
      | Bool
otherwise = [Char] -> Either [Char] [Property]
forall a b. a -> Either a b
Left ([Char] -> Either [Char] [Property])
-> [Char] -> Either [Char] [Property]
forall a b. (a -> b) -> a -> b
$ [Char]
"Unexpected byte in baggage: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> [Char]
forall a. Show a => a -> [Char]
show (HasCallStack => ByteString -> Word8
ByteString -> Word8
BS.head ByteString
s)


isValueByte :: Word8 -> Bool
isValueByte :: Word8 -> Bool
isValueByte Word8
w =
  Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x21
    Bool -> Bool -> Bool
|| (Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
0x23 Bool -> Bool -> Bool
&& Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
0x2B)
    Bool -> Bool -> Bool
|| (Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
0x2D Bool -> Bool -> Bool
&& Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
0x3A)
    Bool -> Bool -> Bool
|| (Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
0x3C Bool -> Bool -> Bool
&& Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
0x5B)
    Bool -> Bool -> Bool
|| (Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
0x5D Bool -> Bool -> Bool
&& Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
0x7E)
{-# INLINE isValueByte #-}


stripOWS :: ByteString -> ByteString
stripOWS :: ByteString -> ByteString
stripOWS = (Char -> Bool) -> ByteString -> ByteString
B8.dropWhile (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t') (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
B8.dropWhileEnd (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t')
{-# INLINE stripOWS #-}


expectByte :: Word8 -> ByteString -> Either String ByteString
expectByte :: Word8 -> ByteString -> Either [Char] ByteString
expectByte Word8
expected ByteString
bs
  | ByteString -> Bool
BS.null ByteString
bs = [Char] -> Either [Char] ByteString
forall a b. a -> Either a b
Left ([Char] -> Either [Char] ByteString)
-> [Char] -> Either [Char] ByteString
forall a b. (a -> b) -> a -> b
$ [Char]
"Expected " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> [Char]
forall a. Show a => a -> [Char]
show Word8
expected [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" but got end of input"
  | HasCallStack => ByteString -> Word8
ByteString -> Word8
BS.head ByteString
bs Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
expected = ByteString -> Either [Char] ByteString
forall a b. b -> Either a b
Right (HasCallStack => ByteString -> ByteString
ByteString -> ByteString
BS.tail ByteString
bs)
  | Bool
otherwise = [Char] -> Either [Char] ByteString
forall a b. a -> Either a b
Left ([Char] -> Either [Char] ByteString)
-> [Char] -> Either [Char] ByteString
forall a b. (a -> b) -> a -> b
$ [Char]
"Expected " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> [Char]
forall a. Show a => a -> [Char]
show Word8
expected [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" but got " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> [Char]
forall a. Show a => a -> [Char]
show (HasCallStack => ByteString -> Word8
ByteString -> Word8
BS.head ByteString
bs)
{-# INLINE expectByte #-}


splitOnByte :: Word8 -> ByteString -> [ByteString]
splitOnByte :: Word8 -> ByteString -> [ByteString]
splitOnByte Word8
w ByteString
bs
  | ByteString -> Bool
BS.null ByteString
bs = []
  | Bool
otherwise =
      let (ByteString
before, ByteString
rest) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
BS.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
w) ByteString
bs
      in ByteString
before ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: if ByteString -> Bool
BS.null ByteString
rest then [] else Word8 -> ByteString -> [ByteString]
splitOnByte Word8
w (HasCallStack => ByteString -> ByteString
ByteString -> ByteString
BS.tail ByteString
rest)


{- | An empty initial baggage value

@since 0.0.1.0
-}
empty :: Baggage
empty :: Baggage
empty = HashMap Token Element -> Baggage
Baggage HashMap Token Element
forall k v. HashMap k v
H.empty


-- | @since 0.0.1.0
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 (Token -> Element -> HashMap Token Element -> HashMap Token Element
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)


{- | Insert a key\/value pair into the baggage with W3C limit enforcement.

Returns 'Left' 'InvalidBaggage' if adding the entry would violate:

* 'TooManyListMembers': exceeds 180 entries (W3C ABNF max)
* 'BaggageTooLong': serialized header would exceed 8192 bytes

@since 0.4.0.0
-}
insertChecked
  :: Token
  -> Element
  -> Baggage
  -> Either InvalidBaggage Baggage
insertChecked :: Token -> Element -> Baggage -> Either InvalidBaggage Baggage
insertChecked Token
k Element
v (Baggage HashMap Token Element
c) =
  let c' :: HashMap Token Element
c' = Token -> Element -> HashMap Token Element -> HashMap Token Element
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
      newCount :: Int
newCount = HashMap Token Element -> Int
forall k v. HashMap k v -> Int
H.size HashMap Token Element
c'
      newBag :: Baggage
newBag = HashMap Token Element -> Baggage
Baggage HashMap Token Element
c'
  in if Int
newCount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxMembers
       then InvalidBaggage -> Either InvalidBaggage Baggage
forall a b. a -> Either a b
Left InvalidBaggage
TooManyListMembers
       else
         let totalBytes :: Int
totalBytes = HashMap Token Element -> Int
baggageSerializedSize HashMap Token Element
c'
         in if Int
totalBytes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxBaggageBytes
              then InvalidBaggage -> Either InvalidBaggage Baggage
forall a b. a -> Either a b
Left InvalidBaggage
BaggageTooLong
              else Baggage -> Either InvalidBaggage Baggage
forall a b. b -> Either a b
Right Baggage
newBag


baggageSerializedSize :: H.HashMap Token Element -> Int
baggageSerializedSize :: HashMap Token Element -> Int
baggageSerializedSize HashMap Token Element
m =
  let entries :: [(Token, Element)]
entries = HashMap Token Element -> [(Token, Element)]
forall k v. HashMap k v -> [(k, v)]
H.toList HashMap Token Element
m
      memberSizes :: [Int]
memberSizes = ((Token, Element) -> Int) -> [(Token, Element)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\(Token
tok, Element
el) -> Token -> Element -> Int
memberByteLen Token
tok Element
el) [(Token, Element)]
entries
      separators :: Int
separators = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 ([(Token, Element)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Token, Element)]
entries Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  in [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
memberSizes Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
separators
  where
    memberByteLen :: Token -> Element -> Int
memberByteLen (Token ByteString
k) (Element Text
v [Property]
props) =
      ByteString -> Int
BS.length ByteString
k
        Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
        Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
BS.length (ByteString -> ByteString
percentEncode (Text -> ByteString
encodeUtf8 Text
v))
        Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Property -> Int) -> [Property] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Property -> Int
propLen [Property]
props)
    propLen :: Property -> Int
propLen (Property (Token ByteString
pk) Maybe Text
Nothing) = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
BS.length ByteString
pk
    propLen (Property (Token ByteString
pk) (Just Text
pv)) = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
BS.length ByteString
pk Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
BS.length (ByteString -> ByteString
percentEncode (Text -> ByteString
encodeUtf8 Text
pv))


{- | Delete a key/value pair from the baggage.

@since 0.0.1.0
-}
delete :: Token -> Baggage -> Baggage
delete :: Token -> Baggage -> Baggage
delete Token
k (Baggage HashMap Token Element
c) = HashMap Token Element -> Baggage
Baggage (Token -> HashMap Token Element -> HashMap Token Element
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
H.delete Token
k HashMap Token Element
c)


{- | Look up a baggage value by name.

Per the spec, this takes a name and returns the associated value, or
'Nothing' if the name is not present in the baggage.

@since 0.4.0.0
-}
getValue :: Token -> Baggage -> Maybe Text
getValue :: Token -> Baggage -> Maybe Text
getValue Token
k (Baggage HashMap Token Element
m) = case Token -> HashMap Token Element -> Maybe Element
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Token
k HashMap Token Element
m of
  Just (Element Text
v [Property]
_) -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
v
  Maybe Element
Nothing -> Maybe Text
forall a. Maybe a
Nothing


{- | 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'

@since 0.0.1.0
-}
fromHashMap :: H.HashMap Token Element -> Baggage
fromHashMap :: HashMap Token Element -> Baggage
fromHashMap = HashMap Token Element -> Baggage
Baggage


-- Percent-encoding (RFC 3986 unreserved characters)
-- Spaces are always encoded as %20 (not +).

isUnreserved :: Word8 -> Bool
isUnreserved :: Word8 -> Bool
isUnreserved Word8
w =
  (Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
65 Bool -> Bool -> Bool
&& Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
90) -- A-Z
    Bool -> Bool -> Bool
|| (Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
97 Bool -> Bool -> Bool
&& Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
122) -- a-z
    Bool -> Bool -> Bool
|| (Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
48 Bool -> Bool -> Bool
&& Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
57) -- 0-9
    Bool -> Bool -> Bool
|| Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
45 -- -
    Bool -> Bool -> Bool
|| Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
46 -- .
    Bool -> Bool -> Bool
|| Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
95 -- _
    Bool -> Bool -> Bool
|| Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
126 -- ~
{-# INLINE isUnreserved #-}


percentEncode :: ByteString -> ByteString
percentEncode :: ByteString -> ByteString
percentEncode = LazyByteString -> ByteString
L.toStrict (LazyByteString -> ByteString)
-> (ByteString -> LazyByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LazyByteString
B.toLazyByteString (Builder -> LazyByteString)
-> (ByteString -> Builder) -> ByteString -> LazyByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
percentEncodeBuilder
{-# INLINE percentEncode #-}


percentEncodeBuilder :: ByteString -> B.Builder
percentEncodeBuilder :: ByteString -> Builder
percentEncodeBuilder = (Builder -> Word8 -> Builder) -> Builder -> ByteString -> Builder
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' (\Builder
acc Word8
w -> Builder
acc Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word8 -> Builder
encodeWord8 Word8
w) Builder
forall a. Monoid a => a
mempty
  where
    encodeWord8 :: Word8 -> Builder
encodeWord8 Word8
w
      | Word8 -> Bool
isUnreserved Word8
w = Word8 -> Builder
B.word8 Word8
w
      | Bool
otherwise = Char -> Builder
B.char7 Char
'%' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word8 -> Builder
hexWord8 Word8
w
    hexWord8 :: Word8 -> Builder
hexWord8 Word8
w =
      let (Word8
hi, Word8
lo) = Word8
w Word8 -> Word8 -> (Word8, Word8)
forall a. Integral a => a -> a -> (a, a)
`divMod` Word8
16
      in Word8 -> Builder
B.word8 (Word8 -> Word8
forall {a}. (Ord a, Num a) => a -> a
hexDigit Word8
hi) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word8 -> Builder
B.word8 (Word8 -> Word8
forall {a}. (Ord a, Num a) => a -> a
hexDigit Word8
lo)
    hexDigit :: a -> a
hexDigit a
n
      | a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
10 = a
n a -> a -> a
forall a. Num a => a -> a -> a
+ a
48 -- '0'
      | Bool
otherwise = a
n a -> a -> a
forall a. Num a => a -> a -> a
+ a
55 -- 'A' - 10


percentDecode :: ByteString -> ByteString
percentDecode :: ByteString -> ByteString
percentDecode ByteString
bs = LazyByteString -> ByteString
L.toStrict (LazyByteString -> ByteString) -> LazyByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> LazyByteString
B.toLazyByteString (Builder -> LazyByteString) -> Builder -> LazyByteString
forall a b. (a -> b) -> a -> b
$ Int -> Builder
go Int
0
  where
    len :: Int
len = ByteString -> Int
BS.length ByteString
bs
    go :: Int -> Builder
go Int
i
      | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
len = Builder
forall a. Monoid a => a
mempty
      | HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
BS.index ByteString
bs Int
i Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x25
      , Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len -- '%'
      , Just Word8
hi <- Word8 -> Maybe Word8
forall {a}. (Ord a, Num a) => a -> Maybe a
unhex (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
BS.index ByteString
bs (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
      , Just Word8
lo <- Word8 -> Maybe Word8
forall {a}. (Ord a, Num a) => a -> Maybe a
unhex (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
BS.index ByteString
bs (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)) =
          Word8 -> Builder
B.word8 (Word8
hi Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
* Word8
16 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
lo) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3)
      | Bool
otherwise =
          Word8 -> Builder
B.word8 (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
BS.index ByteString
bs Int
i) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    unhex :: a -> Maybe a
unhex a
w
      | a
w a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
48 Bool -> Bool -> Bool
&& a
w a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
57 = a -> Maybe a
forall a. a -> Maybe a
Just (a
w a -> a -> a
forall a. Num a => a -> a -> a
- a
48) -- 0-9
      | a
w a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
65 Bool -> Bool -> Bool
&& a
w a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
70 = a -> Maybe a
forall a. a -> Maybe a
Just (a
w a -> a -> a
forall a. Num a => a -> a -> a
- a
55) -- A-F
      | a
w a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
97 Bool -> Bool -> Bool
&& a
w a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
102 = a -> Maybe a
forall a. a -> Maybe a
Just (a
w a -> a -> a
forall a. Num a => a -> a -> a
- a
87) -- a-f
      | Bool
otherwise = Maybe a
forall a. Maybe a
Nothing