{-# LANGUAGE OverloadedStrings #-}

module Network.GRPC.Spec.Serialization.Headers.Common (
    -- * Content type
    buildContentType
  , parseContentType
    -- * Message type
  , buildMessageType
  , parseMessageType
    -- * Message encoding
  , buildMessageEncoding
  , buildMessageAcceptEncoding
  , parseMessageEncoding
  , parseMessageAcceptEncoding
    -- * Utilities
  , trim
  ) where

import Control.Monad
import Control.Monad.Except
import Data.ByteString qualified as BS.Strict
import Data.ByteString qualified as Strict (ByteString)
import Data.ByteString.Char8 qualified as BS.Strict.C8
import Data.Foldable (toList)
import Data.List (intersperse)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Proxy
import Data.Word
import Network.HTTP.Types qualified as HTTP

import Network.GRPC.Spec
import Network.GRPC.Spec.Util.ByteString

{-------------------------------------------------------------------------------
  > Content-Type →
  >   "content-type"
  >   "application/grpc"
  >   [("+proto" / "+json" / {custom})]
-------------------------------------------------------------------------------}

buildContentType ::
     Maybe Strict.ByteString -- ^ Content-type, if known
  -> HTTP.Header
buildContentType :: Maybe ByteString -> Header
buildContentType Maybe ByteString
mContentType = (
      HeaderName
"content-type"
    , case Maybe ByteString
mContentType of
       Maybe ByteString
Nothing -> ByteString
"application/grpc"
       Just ByteString
ct -> ByteString
ct
    )

-- | Parse @content-type@ header
--
-- The gRPC spec mandates different behaviour here for requests and responses:
-- when parsing a request (i.e., on the server), the spec requires that the
-- server responds with @415 Unsupported Media Type@. When parsing a response,
-- however (i.e., on the client), the spec mandates that we synthesize a
-- gRPC exception. We therefore take a function as parameter to construct the
-- actual error.
parseContentType :: forall m rpc.
     (MonadError (InvalidHeaders GrpcException) m, IsRPC rpc)
  => Proxy rpc
  -> (String -> InvalidHeaders GrpcException)
  -> HTTP.Header
  -> m ContentType
parseContentType :: forall {k} (m :: * -> *) (rpc :: k).
(MonadError (InvalidHeaders GrpcException) m, IsRPC rpc) =>
Proxy rpc
-> (String -> InvalidHeaders GrpcException)
-> Header
-> m ContentType
parseContentType Proxy rpc
proxy String -> InvalidHeaders GrpcException
invalid (HeaderName
_name, ByteString
value) = do
    if ByteString
value ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Proxy rpc -> ByteString
forall k (rpc :: k). IsRPC rpc => Proxy rpc -> ByteString
rpcContentType Proxy rpc
proxy then
      ContentType -> m ContentType
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ContentType
ContentTypeDefault
    else do
      -- Headers must be ASCII, justifying the use of BS.Strict.C8.
      -- See <https://www.rfc-editor.org/rfc/rfc7230#section-3.2.4>.
      -- The gRPC spec does not allow for quoted strings.
      withoutPrefix <-
        case ByteString -> ByteString -> Maybe ByteString
BS.Strict.C8.stripPrefix ByteString
"application/grpc" ByteString
value of
          Maybe ByteString
Nothing        -> String -> m ByteString
forall a. String -> m a
err String
"Missing \"application/grpc\" prefix."
          Just ByteString
remainder -> ByteString -> m ByteString
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
remainder

      -- The gRPC spec does not allow for any parameters.
      when (';' `BS.Strict.C8.elem` withoutPrefix) $
        err "Unexpected parameter."

      -- Check format
      --
      -- The only @format@ we should allow is @serializationFormat proxy@.
      -- However, some non-conforming proxies use formats such as
      -- @application/grpc+octet-stream@. We therefore ignore @format@ here.
      if BS.Strict.C8.null withoutPrefix then
        -- Accept "application/grpc"
        return $ ContentTypeOverride value
      else
        case BS.Strict.C8.stripPrefix "+" withoutPrefix of
          Just ByteString
_format ->
            -- Accept "application/grpc+<format>"
            ContentType -> m ContentType
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ContentType -> m ContentType) -> ContentType -> m ContentType
forall a b. (a -> b) -> a -> b
$ ByteString -> ContentType
ContentTypeOverride ByteString
value
          Maybe ByteString
Nothing ->
            String -> m ContentType
forall a. String -> m a
err String
"Invalid subtype."
  where
    err :: String -> m a
    err :: forall a. String -> m a
err String
reason = InvalidHeaders GrpcException -> m a
forall a. InvalidHeaders GrpcException -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (InvalidHeaders GrpcException -> m a)
-> ([String] -> InvalidHeaders GrpcException) -> [String] -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> InvalidHeaders GrpcException
invalid (String -> InvalidHeaders GrpcException)
-> ([String] -> String) -> [String] -> InvalidHeaders GrpcException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> m a) -> [String] -> m a
forall a b. (a -> b) -> a -> b
$ [
          String
reason
        , String
" Expected \"application/grpc\" or \""
        , ByteString -> String
BS.Strict.C8.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$
            Proxy rpc -> ByteString
forall k (rpc :: k). IsRPC rpc => Proxy rpc -> ByteString
rpcContentType Proxy rpc
proxy
        , String
"\", with \""
        , String
"application/grpc+{other_format}"
        , String
"\" also accepted."
        ]

{-------------------------------------------------------------------------------
  > Message-Type → "grpc-message-type" {type name for message schema}
-------------------------------------------------------------------------------}

buildMessageType ::
     IsRPC rpc
  => Proxy rpc
  -> MessageType
  -> Maybe HTTP.Header
buildMessageType :: forall {k} (rpc :: k).
IsRPC rpc =>
Proxy rpc -> MessageType -> Maybe Header
buildMessageType Proxy rpc
proxy MessageType
messageType =
    ByteString -> Header
mkHeader (ByteString -> Header) -> Maybe ByteString -> Maybe Header
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy rpc -> MessageType -> Maybe ByteString
forall {k} (rpc :: k).
IsRPC rpc =>
Proxy rpc -> MessageType -> Maybe ByteString
chooseMessageType Proxy rpc
proxy MessageType
messageType
  where
    mkHeader :: Strict.ByteString -> HTTP.Header
    mkHeader :: ByteString -> Header
mkHeader = (HeaderName
"grpc-message-type",)

-- | Parse message type
--
-- We do not need the @grpc-message-type@ header in order to know the message
-- type, because the /path/ determines the service and method, and that in turn
-- determines the message type. Therefore, if the value is not what we expect,
-- we merely record this fact ('MessageTypeOverride') but don't otherwise do
-- anything differently.
parseMessageType :: forall rpc.
     IsRPC rpc
  => Proxy rpc
  -> HTTP.Header
  -> MessageType
parseMessageType :: forall {k} (rpc :: k).
IsRPC rpc =>
Proxy rpc -> Header -> MessageType
parseMessageType Proxy rpc
proxy (HeaderName
_name, ByteString
given) =
    case Proxy rpc -> Maybe ByteString
forall k (rpc :: k).
(IsRPC rpc, HasCallStack) =>
Proxy rpc -> Maybe ByteString
rpcMessageType Proxy rpc
proxy of
      Maybe ByteString
Nothing ->
        -- We expected no message type at all, but did get one
        ByteString -> MessageType
MessageTypeOverride ByteString
given
      Just ByteString
expected ->
        if ByteString
expected ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
given
          then MessageType
MessageTypeDefault
          else ByteString -> MessageType
MessageTypeOverride ByteString
given

{-------------------------------------------------------------------------------
  > Message-Encoding → "grpc-encoding" Content-Coding
  > Content-Coding → "identity" / "gzip" / "deflate" / "snappy" / {custom}
-------------------------------------------------------------------------------}

buildMessageEncoding :: CompressionId -> HTTP.Header
buildMessageEncoding :: CompressionId -> Header
buildMessageEncoding CompressionId
compr = (
      HeaderName
"grpc-encoding"
    , CompressionId -> ByteString
serializeCompressionId CompressionId
compr
    )

parseMessageEncoding ::
     MonadError (InvalidHeaders GrpcException) m
  => HTTP.Header
  -> m CompressionId
parseMessageEncoding :: forall (m :: * -> *).
MonadError (InvalidHeaders GrpcException) m =>
Header -> m CompressionId
parseMessageEncoding (HeaderName
_name, ByteString
value) =
    CompressionId -> m CompressionId
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CompressionId -> m CompressionId)
-> CompressionId -> m CompressionId
forall a b. (a -> b) -> a -> b
$ ByteString -> CompressionId
deserializeCompressionId ByteString
value

{-------------------------------------------------------------------------------
  > Message-Accept-Encoding →
  >   "grpc-accept-encoding" Content-Coding *("," Content-Coding)
-------------------------------------------------------------------------------}

buildMessageAcceptEncoding :: NonEmpty CompressionId -> HTTP.Header
buildMessageAcceptEncoding :: NonEmpty CompressionId -> Header
buildMessageAcceptEncoding NonEmpty CompressionId
compr = (
      HeaderName
"grpc-accept-encoding"
    , [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat ([ByteString] -> ByteString)
-> ([CompressionId] -> [ByteString])
-> [CompressionId]
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
intersperse ByteString
"," ([ByteString] -> [ByteString])
-> ([CompressionId] -> [ByteString])
-> [CompressionId]
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CompressionId -> ByteString) -> [CompressionId] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map CompressionId -> ByteString
serializeCompressionId ([CompressionId] -> ByteString) -> [CompressionId] -> ByteString
forall a b. (a -> b) -> a -> b
$ NonEmpty CompressionId -> [CompressionId]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty CompressionId
compr
    )

parseMessageAcceptEncoding :: forall m.
     MonadError (InvalidHeaders GrpcException) m
  => HTTP.Header
  -> m (NonEmpty CompressionId)
parseMessageAcceptEncoding :: forall (m :: * -> *).
MonadError (InvalidHeaders GrpcException) m =>
Header -> m (NonEmpty CompressionId)
parseMessageAcceptEncoding hdr :: Header
hdr@(HeaderName
_name, ByteString
value) =
      [CompressionId] -> m (NonEmpty CompressionId)
forall a. [a] -> m (NonEmpty a)
atLeastOne
    ([CompressionId] -> m (NonEmpty CompressionId))
-> (ByteString -> [CompressionId])
-> ByteString
-> m (NonEmpty CompressionId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> CompressionId) -> [ByteString] -> [CompressionId]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> CompressionId
deserializeCompressionId (ByteString -> CompressionId)
-> (ByteString -> ByteString) -> ByteString -> CompressionId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
strip)
    ([ByteString] -> [CompressionId])
-> (ByteString -> [ByteString]) -> ByteString -> [CompressionId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Bool) -> ByteString -> [ByteString]
BS.Strict.splitWith (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== HasCallStack => Char -> Word8
Char -> Word8
ascii Char
',')
    (ByteString -> m (NonEmpty CompressionId))
-> ByteString -> m (NonEmpty CompressionId)
forall a b. (a -> b) -> a -> b
$ ByteString
value
  where
    atLeastOne :: forall a. [a] -> m (NonEmpty a)
    atLeastOne :: forall a. [a] -> m (NonEmpty a)
atLeastOne (a
x : [a]
xs) = NonEmpty a -> m (NonEmpty a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
xs)
    atLeastOne []       = InvalidHeaders GrpcException -> m (NonEmpty a)
forall a. InvalidHeaders GrpcException -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (InvalidHeaders GrpcException -> m (NonEmpty a))
-> InvalidHeaders GrpcException -> m (NonEmpty a)
forall a b. (a -> b) -> a -> b
$ Maybe Status -> Header -> String -> InvalidHeaders GrpcException
forall e. Maybe Status -> Header -> String -> InvalidHeaders e
invalidHeader Maybe Status
forall a. Maybe a
Nothing Header
hdr (String -> InvalidHeaders GrpcException)
-> String -> InvalidHeaders GrpcException
forall a b. (a -> b) -> a -> b
$
                            String
"Expected at least one compresion ID"

{-------------------------------------------------------------------------------
  Utilities
-------------------------------------------------------------------------------}

-- | Trim leading or trailing whitespace
--
-- We only allow for space and tab, based on
-- <https://www.rfc-editor.org/rfc/rfc9110.html#name-whitespace>.
trim :: Strict.ByteString -> Strict.ByteString
trim :: ByteString -> ByteString
trim = ByteString -> ByteString
ltrim (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
rtrim
  where
    ltrim, rtrim :: Strict.ByteString -> Strict.ByteString
    ltrim :: ByteString -> ByteString
ltrim = (Word8 -> Bool) -> ByteString -> ByteString
BS.Strict.dropWhile    Word8 -> Bool
isSpace
    rtrim :: ByteString -> ByteString
rtrim = (Word8 -> Bool) -> ByteString -> ByteString
BS.Strict.dropWhileEnd Word8 -> Bool
isSpace

    isSpace :: Word8 -> Bool
    isSpace :: Word8 -> Bool
isSpace Word8
x = Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
32 Bool -> Bool -> Bool
|| Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
9