Request.hs

{-# LANGUAGE OverloadedStrings #-}

module Network.GRPC.Spec.Serialization.Headers.Request (
    buildRequestHeaders
    --
    -- Throws an error if any headers fail to parse; if this is not desired, see
    -- 'parseRequestHeaders'' instead.
  , parseRequestHeaders
  --
  -- Throws an error if any headers fail to parse; if this is not desired, see
  -- 'parseRequestHeaders'' instead.
  , parseRequestHeaders'
  ) where

import Control.Monad
import Control.Monad.Except (MonadError(throwError))
import Control.Monad.State (State, execState, modify)
import Data.Bifunctor
import Data.ByteString qualified as Strict (ByteString)
import Data.ByteString.Char8 qualified as BS.Strict.C8
import Data.Functor (($>))
import Data.List (intercalate)
import Data.Maybe (catMaybes)
import Data.Proxy
import Network.HTTP.Types qualified as HTTP
import Text.Read (readMaybe)

import Network.GRPC.Spec
import Network.GRPC.Spec.Serialization.CustomMetadata
import Network.GRPC.Spec.Serialization.Headers.Common
import Network.GRPC.Spec.Serialization.Timeout
import Network.GRPC.Spec.Serialization.TraceContext
import Network.GRPC.Spec.Util.HKD qualified as HKD

{-------------------------------------------------------------------------------
  Construction
-------------------------------------------------------------------------------}

-- | Request headers
--
-- > Request-Headers →
-- >   Call-Definition
-- >   *Custom-Metadata
buildRequestHeaders ::
     IsRPC rpc
  => Proxy rpc -> RequestHeaders -> [HTTP.Header]
buildRequestHeaders proxy callParams@RequestHeaders{requestMetadata} = concat [
      callDefinition proxy callParams
    , map buildCustomMetadata $ customMetadataMapToList requestMetadata
    ]

-- | Call definition
--
-- > Call-Definition →
-- >   Method
-- >   Scheme
-- >   Path
-- >   TE
-- >   [Authority]
-- >   [Timeout]
-- >   Content-Type
-- >   [Message-Type]
-- >   [Message-Encoding]
-- >   [Message-Accept-Encoding]
-- >   [User-Agent]
--
-- However, the spec additionally mandates that
--
--   HTTP2 requires that reserved headers, ones starting with ":" appear
--   before all other headers. Additionally implementations should send
--   Timeout immediately after the reserved headers and they should send the
--   Call-Definition headers before sending Custom-Metadata.
--
-- (Relevant part of the HTTP2 spec:
-- <https://www.rfc-editor.org/rfc/rfc7540#section-8.1.2.1>.) This means
-- @TE@ should come /after/ @Authority@ (if using). However, we will not include
-- the reserved headers here /at all/, as they are automatically added by
-- @http2@.
callDefinition :: forall rpc.
     IsRPC rpc
  => Proxy rpc -> RequestHeaders -> [HTTP.Header]
callDefinition proxy = \hdrs -> catMaybes [
      hdrTimeout <$> requestTimeout hdrs
    , guard (requestIncludeTE hdrs) $> buildTe
    , buildContentType . Just . chooseContentType proxy <$>
        requestContentType hdrs
    , join $ buildMessageType proxy <$> requestMessageType hdrs
    , buildMessageEncoding <$> requestCompression hdrs
    , buildMessageAcceptEncoding <$> requestAcceptCompression hdrs
    , buildUserAgent <$> requestUserAgent hdrs
    , buildGrpcTraceBin <$> requestTraceContext hdrs
    , buildPreviousRpcAttempts <$> requestPreviousRpcAttempts hdrs
    ]
  where
    hdrTimeout :: Timeout -> HTTP.Header
    hdrTimeout t = ("grpc-timeout", buildTimeout t)

    -- > TE → "te" "trailers" # Used to detect incompatible proxies
    buildTe :: HTTP.Header
    buildTe  = ("te", "trailers")

    -- > User-Agent → "user-agent" {structured user-agent string}
    --
    -- The spec says:
    --
    --   While the protocol does not require a user-agent to function it is
    --   recommended that clients provide a structured user-agent string that
    --   provides a basic description of the calling library, version & platform
    --   to facilitate issue diagnosis in heterogeneous environments. The
    --   following structure is recommended to library developers
    --
    -- > User-Agent →
    -- >   "grpc-"
    -- >   Language
    -- >   ?("-" Variant)
    -- >   "/"
    -- >   Version
    -- >   ?( " ("  *(AdditionalProperty ";") ")" )
    buildUserAgent :: Strict.ByteString -> HTTP.Header
    buildUserAgent userAgent = (
          "user-agent"
        , userAgent
        )

    buildGrpcTraceBin :: TraceContext -> HTTP.Header
    buildGrpcTraceBin ctxt = (
          "grpc-trace-bin"
        , buildBinaryValue $ buildTraceContext ctxt
        )

    buildPreviousRpcAttempts :: Int -> HTTP.Header
    buildPreviousRpcAttempts n = (
          "grpc-previous-rpc-attempts"
        , BS.Strict.C8.pack $ show n
        )

{-------------------------------------------------------------------------------
  Parsing
-------------------------------------------------------------------------------}

-- | Parse t'RequestHeaders'
--
-- Throws an error if any headers fail to parse; if this is not desired, see
-- 'parseRequestHeaders'' instead.
parseRequestHeaders :: forall rpc m.
     (IsRPC rpc, MonadError (InvalidHeaders GrpcException) m)
  => Proxy rpc
  -> [HTTP.Header] -> m RequestHeaders
parseRequestHeaders proxy = HKD.sequenceChecked . parseRequestHeaders' proxy

-- | Parse request headers
--
-- This can report invalid headers on a per-header basis; see also
-- 'parseRequestHeaders'.
parseRequestHeaders' :: forall rpc.
     IsRPC rpc
  => Proxy rpc
  -> [HTTP.Header] -> RequestHeaders' GrpcException
parseRequestHeaders' proxy =
      flip execState uninitRequestHeaders
    . mapM_ (parseHeader . second trim)
  where
    parseHeader :: HTTP.Header -> State (RequestHeaders' GrpcException) ()
    parseHeader hdr@(name, value)
      | name == "user-agent"
      = modify $ \x -> x {
           requestUserAgent = return (Just value)
          }

      | name == "grpc-timeout"
      = modify $ \x -> x {
            requestTimeout = fmap Just $
              httpError hdr $
                parseTimeout value
          }

      | name == "grpc-encoding"
      = modify $ \x -> x {
            requestCompression = fmap Just $
               parseMessageEncoding hdr
          }

      | name == "grpc-accept-encoding"
      = modify $ \x -> x {
            requestAcceptCompression = fmap Just $
               parseMessageAcceptEncoding hdr
          }

      | name == "grpc-trace-bin"
      = modify $ \x -> x {
            requestTraceContext = fmap Just $
              httpError hdr $
                parseBinaryValue value >>= parseTraceContext
          }

      | name == "content-type"
      = modify $ \x -> x {
            requestContentType = fmap Just $
              parseContentType' proxy hdr
          }

      | name == "grpc-message-type"
      = modify $ \x -> x {
            requestMessageType = return . Just $
              parseMessageType proxy hdr
          }

      | name == "te"
      = modify $ \x -> x {
            requestIncludeTE = do
              expectHeaderValue hdr ["trailers"]
              return True
          }

      | name == "grpc-previous-rpc-attempts"
      = modify $ \x -> x {
            requestPreviousRpcAttempts = do
              httpError hdr $
                maybe
                  (Left $ "grpc-previous-rpc-attempts: invalid " ++ show value)
                  (Right . Just)
                  (readMaybe $ BS.Strict.C8.unpack value)
          }

      | otherwise
      = modify $ \x ->
          case parseCustomMetadata hdr of
            Left invalid -> x {
                requestUnrecognized = Left $
                  case requestUnrecognized x of
                    Left invalid' -> invalid <> invalid'
                    Right ()      -> invalid
              }
            Right md -> x {
                requestMetadata = customMetadataMapInsert md $ requestMetadata x
              }

    uninitRequestHeaders :: RequestHeaders' GrpcException
    uninitRequestHeaders = RequestHeaders {
          requestTimeout             = return Nothing
        , requestCompression         = return Nothing
        , requestAcceptCompression   = return Nothing
        , requestIncludeTE           = return False
        , requestUserAgent           = return Nothing
        , requestTraceContext        = return Nothing
        , requestPreviousRpcAttempts = return Nothing
        , requestMetadata            = mempty
        , requestUnrecognized        = return ()

        -- Special cases

        , requestContentType =
            throwError $ missingHeader invalidContentType "content-type"
        , requestMessageType =
            -- If the default is that this header should be absent, then /start/
            -- with 'MessageTypeDefault'; if it happens to present, parse it as
            -- an override.
            case rpcMessageType proxy of
              Nothing -> return $ Just MessageTypeDefault
              Just _  -> return $ Nothing
        }

    httpError ::
         MonadError (InvalidHeaders GrpcException) m'
      => HTTP.Header -> Either String a -> m' a
    httpError _   (Right a)  = return a
    httpError hdr (Left err) = throwError $ invalidHeader Nothing hdr err

{-------------------------------------------------------------------------------
  Content type

  See 'parseContentType' for discussion.
-------------------------------------------------------------------------------}

parseContentType' ::
     IsRPC rpc
  => Proxy rpc
  -> HTTP.Header
  -> Either (InvalidHeaders GrpcException) ContentType
parseContentType' proxy hdr =
    parseContentType
      proxy
      (invalidHeader invalidContentType hdr)
      hdr

invalidContentType :: Maybe HTTP.Status
invalidContentType = Just HTTP.unsupportedMediaType415

{-------------------------------------------------------------------------------
  Internal auxiliary
-------------------------------------------------------------------------------}

expectHeaderValue ::
     MonadError (InvalidHeaders GrpcException) m
  => HTTP.Header -> [Strict.ByteString] -> m ()
expectHeaderValue hdr@(_name, actual) expected =
    unless (actual `elem` expected) $
      throwError $ invalidHeader Nothing hdr err
  where
    err :: String
    err = concat [
          "Expected "
        , intercalate " or " $
            map (\e -> "\"" ++ BS.Strict.C8.unpack e ++ "\"") expected
        , "."
        ]