content: {-# 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 (Show, Eq, Ord)
    deriving newtype (Hashable)
  
  
  -- | Convert a 'Token' into a 'ByteString'
  tokenValue :: Token -> ByteString
  tokenValue (Token t) = t
  
  #if MIN_VERSION_template_haskell(2, 17, 0)
  instance Lift Token where
    liftTyped (Token tok) = liftCode $ unsafeTExpCoerce $ bsToExp tok
  #else
  instance Lift Token where
    liftTyped (Token tok) = unsafeTExpCoerce $ bsToExp tok
  #endif
  
  
  -- | An entry into the baggage
  data Element = Element
    { value :: Text
    , properties :: [Property]
    }
    deriving stock (Show, Eq)
  
  
  element :: Text -> Element
  element t = Element t []
  
  
  data Property = Property
    { propertyKey :: Token
    , propertyValue :: Maybe Text
    }
    deriving stock (Show, Eq)
  
  
  property :: Token -> Maybe Text -> Property
  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 (Show, Eq)
    deriving newtype (Semigroup)
  
  
  tokenCharacters :: CharSet
  tokenCharacters = C.fromList "!#$%&'*+-.^_`|~0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
  
  
  -- Ripped from file-embed-0.0.13
  bsToExp :: (Monad m) => ByteString -> m Exp
  #if MIN_VERSION_template_haskell(2, 5, 0)
  bsToExp bs =
      return $ ConE 'Token
        `AppE` (VarE 'unsafePerformIO
        `AppE` (VarE 'unsafePackAddressLen
        `AppE` LitE (IntegerL $ fromIntegral $ BS.length bs)
  #if MIN_VERSION_template_haskell(2, 16, 0)
        `AppE` LitE (bytesPrimL (
                  let BS.PS ptr off sz = bs
                  in  mkBytes ptr (fromIntegral off) (fromIntegral 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 txt
    | txt `T.compareLength` 4096 == GT = Nothing
    | T.all (`C.member` tokenCharacters) txt = Just $ Token $ encodeUtf8 txt
    | otherwise = Nothing
  
  
  token :: QuasiQuoter
  token =
    QuasiQuoter
      { quoteExp = parseExp
      , quotePat = \_ -> fail "Token as pattern not implemented"
      , quoteType = \_ -> fail "Can't use a Baggage Token as a type"
      , quoteDec = \_ -> fail "Can't use a Baggage Token as a declaration"
      }
    where
      parseExp = \str -> case mkToken $ T.pack str of
        Nothing -> fail (show str ++ " is not a valid Token.")
        Just tok -> lift 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 =
    L.toStrict
      . BS.toLazyByteStringWith (BS.untrimmedStrategy (8192 + 16) BS.smallChunkSize) L.empty
      . encodeBaggageHeaderB
  
  
  encodeBaggageHeaderB :: Baggage -> B.Builder
  encodeBaggageHeaderB (Baggage bmap) =
    mconcat $
      intersperse (B.char7 ',') $
        map go $
          H.toList bmap
    where
      go (Token k, Element v props) =
        B.byteString k
          <> B.char7 '='
          <> urlEncodeBuilder False (encodeUtf8 v)
          <> (mconcat $ intersperse (B.char7 ';') $ map propEncoder props)
      propEncoder (Property (Token k) mv) =
        B.byteString k
          <> maybe
            mempty
            (\v -> B.char7 '=' <> urlEncodeBuilder False (encodeUtf8 v))
            mv
  
  
  decodeBaggageHeader :: ByteString -> Either String Baggage
  decodeBaggageHeader = P.parseOnly decodeBaggageHeaderP
  
  
  decodeBaggageHeaderP :: P.Parser Baggage
  decodeBaggageHeaderP = do
    owsP
    firstMember <- memberP
    otherMembers <- many (owsP >> P.char8 ',' >> owsP >> memberP)
    owsP
    pure $ Baggage $ H.fromList (firstMember : otherMembers)
    where
      owsSet = C.fromList " \t"
      owsP = P.skipWhile (`C.member` owsSet)
      memberP :: P.Parser (Token, Element)
      memberP = do
        tok <- tokenP
        owsP
        _ <- P.char8 '='
        owsP
        val <- valP
        props <- many (owsP >> P.char8 ';' >> owsP >> propertyP)
        pure (tok, Element val props)
      valueSet =
        C.fromList $
          concat
            [ ['\x21']
            , ['\x23' .. '\x2B']
            , ['\x2D' .. '\x3A']
            , ['\x3C' .. '\x5B']
            , ['\x5D' .. '\x7E']
            ]
      tokenP :: P.Parser Token
      tokenP = Token <$> P.takeWhile1 (`C.member` tokenCharacters)
      valP = decodeUtf8 . urlDecode False <$> P.takeWhile (`C.member` valueSet)
      propertyP :: P.Parser Property
      propertyP = do
        key <- tokenP
        owsP
        val <- P.option Nothing $ do
          _ <- P.char8 '='
          owsP
          Just <$> valP
        pure $ Property key val
  
  
  -- | An empty initial baggage value
  empty :: Baggage
  empty = Baggage 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 k v (Baggage c) = Baggage (H.insert k v c)
  
  
  -- | Delete a key/value pair from the baggage.
  delete :: Token -> Baggage -> Baggage
  delete k (Baggage c) = Baggage (H.delete k 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 m) = m
  
  
  -- | Convert a 'H.HashMap' into 'Baggage'
  fromHashMap :: H.HashMap Token Element -> Baggage
  fromHashMap = Baggage
  