{-# LANGUAGE OverloadedStrings #-}
module Network.GRPC.Spec.Serialization.CustomMetadata (
buildHeaderName
, parseHeaderName
, buildAsciiValue
, parseAsciiValue
, buildBinaryValue
, parseBinaryValue
, 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)
buildHeaderName :: HeaderName -> CI Strict.ByteString
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
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'
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
buildBinaryValue :: Strict.ByteString -> Strict.ByteString
buildBinaryValue :: ByteString -> ByteString
buildBinaryValue = ByteString -> ByteString
encodeBase64
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
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)
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
return $ CustomMetadata name' value'