content: {-# LANGUAGE OverloadedStrings #-}
  
  module Network.GRPC.Spec.Serialization.CustomMetadata (
      -- * HeaderName
      buildHeaderName
    , parseHeaderName
      -- * AsciiValue
    , buildAsciiValue
    , parseAsciiValue
      -- * BinaryValue
    , buildBinaryValue
    , parseBinaryValue
      -- * CustomMetadata
    , buildCustomMetadata
    , parseCustomMetadata
    ) where
  
  import Control.Monad
  import Control.Monad.Except (MonadError(throwError))
  import Data.ByteString qualified as BS.Strict
  import Data.ByteString qualified as Strict (ByteString)
  import Data.CaseInsensitive (CI)
  import Data.CaseInsensitive qualified as CI
  import Data.List (intersperse)
  import Network.HTTP.Types qualified as HTTP
  
  import Network.GRPC.Spec
  import Network.GRPC.Spec.Serialization.Base64
  import Network.GRPC.Spec.Util.ByteString (ascii)
  
  {-------------------------------------------------------------------------------
    HeaderName
  -------------------------------------------------------------------------------}
  
  buildHeaderName :: HeaderName -> CI Strict.ByteString
  buildHeaderName name =
      case name of
        BinaryHeader name' -> CI.mk name'
        AsciiHeader  name' -> CI.mk name'
  
  parseHeaderName :: MonadError String m => CI Strict.ByteString -> m HeaderName
  parseHeaderName name =
      case safeHeaderName (CI.foldedCase name) of
        Nothing    -> throwError $ "Invalid header name: " ++ show name
        Just name' -> return name'
  
  {-------------------------------------------------------------------------------
    AsciiValue
  -------------------------------------------------------------------------------}
  
  buildAsciiValue :: Strict.ByteString -> Strict.ByteString
  buildAsciiValue = id
  
  parseAsciiValue ::
       MonadError String m
    => Strict.ByteString -> m Strict.ByteString
  parseAsciiValue bs = do
      unless (isValidAsciiValue bs) $
        throwError $ "Invalid ASCII header: " ++ show bs
      return bs
  
  {-------------------------------------------------------------------------------
    BinaryValue
  -------------------------------------------------------------------------------}
  
  -- | Serialize binary value (base-64 encoding)
  buildBinaryValue :: Strict.ByteString -> Strict.ByteString
  buildBinaryValue = encodeBase64
  
  -- | Parse binary value
  --
  -- The presence of duplicate headers makes this a bit subtle. Let's consider an
  -- example. Suppose we have two duplicate headers
  --
  -- > foo-bin: YWJj    -- encoding of "abc"
  -- > foo-bin: ZGVm    -- encoding of "def"
  --
  -- The spec says
  --
  -- > Custom-Metadata header order is not guaranteed to be preserved except for
  -- > values with duplicate header names. Duplicate header names may have their
  -- > values joined with "," as the delimiter and be considered semantically
  -- > equivalent.
  --
  -- We will do the decoding of both headers /prior/ to joining duplicate headers,
  -- and so the value we will reconstruct for @foo-bin@ is \"abc,def\".
  --
  -- However, suppose we deal with a (non-compliant) peer which is unaware of
  -- binary headers and has applied the joining rule /without/ decoding:
  --
  -- > foo-bin: YWJj,ZGVm
  --
  -- The spec is a bit vague about this case, saying only:
  --
  -- > Implementations must split Binary-Headers on "," before decoding the
  -- > Base64-encoded values.
  --
  -- Here we assume that this case must be treated the same way as if the headers
  -- /had/ been decoded prior to joining. Therefore, we split the input on commas,
  -- decode each result separately, and join the results with commas again.
  parseBinaryValue :: forall m.
       MonadError String m
    => Strict.ByteString -> m Strict.ByteString
  parseBinaryValue bs = do
      let chunks = BS.Strict.split (ascii ',') bs
      decoded <- mapM decode chunks
      return $ mconcat $ intersperse "," decoded
    where
      decode :: Strict.ByteString -> m Strict.ByteString
      decode chunk =
          case decodeBase64 chunk of
            Left  err -> throwError err
            Right val -> return val
  
  {-------------------------------------------------------------------------------
    CustomMetadata
  -------------------------------------------------------------------------------}
  
  -- | Serialize t'CustomMetadata'
  buildCustomMetadata :: CustomMetadata -> HTTP.Header
  buildCustomMetadata (CustomMetadata name value) =
      case name of
        BinaryHeader _ -> (buildHeaderName name, buildBinaryValue value)
        AsciiHeader  _ -> (buildHeaderName name, buildAsciiValue  value)
  
  -- | Parse t'CustomMetadata'
  parseCustomMetadata ::
       MonadError (InvalidHeaders GrpcException) m
    => HTTP.Header -> m CustomMetadata
  parseCustomMetadata hdr@(name, value) = throwInvalidHeader hdr $ do
      name'     <- parseHeaderName name
      value'    <- case name' of
                     AsciiHeader  _ -> parseAsciiValue  value
                     BinaryHeader _ -> parseBinaryValue value
      -- If parsing succeeds, that justifies the use of 'UnsafeCustomMetadata'
      return $ CustomMetadata name' value'
  