Common.hs

{-# 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 mContentType = (
      "content-type"
    , case mContentType of
       Nothing -> "application/grpc"
       Just ct -> 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 proxy invalid (_name, value) = do
    if value == rpcContentType proxy then
      return 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 BS.Strict.C8.stripPrefix "application/grpc" value of
          Nothing        -> err "Missing \"application/grpc\" prefix."
          Just remainder -> return 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 _format ->
            -- Accept "application/grpc+<format>"
            return $ ContentTypeOverride value
          Nothing ->
            err "Invalid subtype."
  where
    err :: String -> m a
    err reason = throwError . invalid . concat $ [
          reason
        , " Expected \"application/grpc\" or \""
        , BS.Strict.C8.unpack $
            rpcContentType proxy
        , "\", with \""
        , "application/grpc+{other_format}"
        , "\" also accepted."
        ]

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

buildMessageType ::
     IsRPC rpc
  => Proxy rpc
  -> MessageType
  -> Maybe HTTP.Header
buildMessageType proxy messageType =
    mkHeader <$> chooseMessageType proxy messageType
  where
    mkHeader :: Strict.ByteString -> HTTP.Header
    mkHeader = ("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 proxy (_name, given) =
    case rpcMessageType proxy of
      Nothing ->
        -- We expected no message type at all, but did get one
        MessageTypeOverride given
      Just expected ->
        if expected == given
          then MessageTypeDefault
          else MessageTypeOverride given

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

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

parseMessageEncoding ::
     MonadError (InvalidHeaders GrpcException) m
  => HTTP.Header
  -> m CompressionId
parseMessageEncoding (_name, value) =
    return $ deserializeCompressionId value

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

buildMessageAcceptEncoding :: NonEmpty CompressionId -> HTTP.Header
buildMessageAcceptEncoding compr = (
      "grpc-accept-encoding"
    , mconcat . intersperse "," . map serializeCompressionId $ toList compr
    )

parseMessageAcceptEncoding :: forall m.
     MonadError (InvalidHeaders GrpcException) m
  => HTTP.Header
  -> m (NonEmpty CompressionId)
parseMessageAcceptEncoding hdr@(_name, value) =
      atLeastOne
    . map (deserializeCompressionId . strip)
    . BS.Strict.splitWith (== ascii ',')
    $ value
  where
    atLeastOne :: forall a. [a] -> m (NonEmpty a)
    atLeastOne (x : xs) = return (x :| xs)
    atLeastOne []       = throwError $ invalidHeader Nothing hdr $
                            "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 = ltrim . rtrim
  where
    ltrim, rtrim :: Strict.ByteString -> Strict.ByteString
    ltrim = BS.Strict.dropWhile    isSpace
    rtrim = BS.Strict.dropWhileEnd isSpace

    isSpace :: Word8 -> Bool
    isSpace x = x == 32 || x == 9