{-# 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 :: HeaderName -> CI ByteString
buildHeaderName HeaderName
name =
    case HeaderName
name of
      BinaryHeader ByteString
name' -> ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
name'
      AsciiHeader  ByteString
name' -> ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
name'

parseHeaderName :: MonadError String m => CI Strict.ByteString -> m HeaderName
parseHeaderName :: forall (m :: * -> *).
MonadError String m =>
CI ByteString -> m HeaderName
parseHeaderName CI ByteString
name =
    case ByteString -> Maybe HeaderName
safeHeaderName (CI ByteString -> ByteString
forall s. CI s -> s
CI.foldedCase CI ByteString
name) of
      Maybe HeaderName
Nothing    -> String -> m HeaderName
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m HeaderName) -> String -> m HeaderName
forall a b. (a -> b) -> a -> b
$ String
"Invalid header name: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CI ByteString -> String
forall a. Show a => a -> String
show CI ByteString
name
      Just HeaderName
name' -> HeaderName -> m HeaderName
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return HeaderName
name'

{-------------------------------------------------------------------------------
  AsciiValue
-------------------------------------------------------------------------------}

buildAsciiValue :: Strict.ByteString -> Strict.ByteString
buildAsciiValue :: ByteString -> ByteString
buildAsciiValue = ByteString -> ByteString
forall a. a -> a
id

parseAsciiValue ::
     MonadError String m
  => Strict.ByteString -> m Strict.ByteString
parseAsciiValue :: forall (m :: * -> *).
MonadError String m =>
ByteString -> m ByteString
parseAsciiValue ByteString
bs = do
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
isValidAsciiValue ByteString
bs) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      String -> m ()
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Invalid ASCII header: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
bs
    ByteString -> m ByteString
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs

{-------------------------------------------------------------------------------
  BinaryValue
-------------------------------------------------------------------------------}

-- | Serialize binary value (base-64 encoding)
buildBinaryValue :: Strict.ByteString -> Strict.ByteString
buildBinaryValue :: ByteString -> ByteString
buildBinaryValue = ByteString -> ByteString
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 :: forall (m :: * -> *).
MonadError String m =>
ByteString -> m ByteString
parseBinaryValue ByteString
bs = do
    let chunks :: [ByteString]
chunks = Word8 -> ByteString -> [ByteString]
BS.Strict.split (HasCallStack => Char -> Word8
Char -> Word8
ascii Char
',') ByteString
bs
    decoded <- (ByteString -> m ByteString) -> [ByteString] -> m [ByteString]
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 -> m ByteString
decode [ByteString]
chunks
    return $ mconcat $ intersperse "," decoded
  where
    decode :: Strict.ByteString -> m Strict.ByteString
    decode :: ByteString -> m ByteString
decode ByteString
chunk =
        case ByteString -> Either String ByteString
decodeBase64 ByteString
chunk of
          Left  String
err -> String -> m ByteString
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
err
          Right ByteString
val -> ByteString -> m ByteString
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
val

{-------------------------------------------------------------------------------
  CustomMetadata
-------------------------------------------------------------------------------}

-- | Serialize t'CustomMetadata'
buildCustomMetadata :: CustomMetadata -> HTTP.Header
buildCustomMetadata :: CustomMetadata -> Header
buildCustomMetadata (CustomMetadata HeaderName
name ByteString
value) =
    case HeaderName
name of
      BinaryHeader ByteString
_ -> (HeaderName -> CI ByteString
buildHeaderName HeaderName
name, ByteString -> ByteString
buildBinaryValue ByteString
value)
      AsciiHeader  ByteString
_ -> (HeaderName -> CI ByteString
buildHeaderName HeaderName
name, ByteString -> ByteString
buildAsciiValue  ByteString
value)

-- | Parse t'CustomMetadata'
parseCustomMetadata ::
     MonadError (InvalidHeaders GrpcException) m
  => HTTP.Header -> m CustomMetadata
parseCustomMetadata :: forall (m :: * -> *).
MonadError (InvalidHeaders GrpcException) m =>
Header -> m CustomMetadata
parseCustomMetadata hdr :: Header
hdr@(CI ByteString
name, ByteString
value) = Header -> Either String CustomMetadata -> m CustomMetadata
forall e (m :: * -> *) a.
MonadError (InvalidHeaders e) m =>
Header -> Either String a -> m a
throwInvalidHeader Header
hdr (Either String CustomMetadata -> m CustomMetadata)
-> Either String CustomMetadata -> m CustomMetadata
forall a b. (a -> b) -> a -> b
$ do
    name'     <- CI ByteString -> Either String HeaderName
forall (m :: * -> *).
MonadError String m =>
CI ByteString -> m HeaderName
parseHeaderName CI ByteString
name
    value'    <- case name' of
                   AsciiHeader  ByteString
_ -> ByteString -> Either String ByteString
forall (m :: * -> *).
MonadError String m =>
ByteString -> m ByteString
parseAsciiValue  ByteString
value
                   BinaryHeader ByteString
_ -> ByteString -> Either String ByteString
forall (m :: * -> *).
MonadError String m =>
ByteString -> m ByteString
parseBinaryValue ByteString
value
    -- If parsing succeeds, that justifies the use of 'UnsafeCustomMetadata'
    return $ CustomMetadata name' value'