Deal with HTTP status codes other than 200

grapesy.cabal

@@ -301,6 +301,7 @@ test-suite test-grapesy
       Test.Prop.Dialogue
       Test.Prop.IncrementalParsing
       Test.Prop.Serialization
+      Test.Sanity.BrokenDeployments
       Test.Sanity.EndOfStream
       Test.Sanity.Interop
       Test.Sanity.StreamingType.CustomFormat
@@ -340,6 +341,7 @@ test-suite test-grapesy
     , lens                        >= 5.0   && < 5.4
     , mtl                         >= 2.2   && < 2.4
     , network                     >= 3.1   && < 3.3
+    , network-run                 >= 0.4   && < 0.5
     , prettyprinter               >= 1.7   && < 1.8
     , prettyprinter-ansi-terminal >= 1.1   && < 1.2
     , proto-lens                  >= 0.7   && < 0.8

src/Network/GRPC/Client/Session.hs

@@ -11,10 +11,6 @@ module Network.GRPC.Client.Session (
   ) where
 
 import Control.Exception
-import Control.Monad
-import Data.ByteString.Lazy qualified as BS.Lazy
-import Data.ByteString.Lazy qualified as Lazy (ByteString)
-import Data.Maybe (fromMaybe)
 import Data.Proxy
 import Data.Void
 import Network.HTTP.Types qualified as HTTP
@@ -70,33 +66,38 @@ instance SupportsClientRpc rpc => IsSession (ClientSession rpc) where
   type Outbound (ClientSession rpc) = ClientOutbound rpc
 
   buildOutboundTrailers _ = \NoMetadata -> []
-  parseInboundTrailers  _ = parseTrailers (parseProperTrailers' (Proxy @rpc))
+  parseInboundTrailers  _ = \trailers ->
+      if null trailers then
+        -- Although we parse the trailers in a lenient fashion (like all
+        -- headers), only throwing errors for headers that we really need, if we
+        -- get no trailers at /all/, then most likely something has gone wrong;
+        -- for example, perhaps an intermediate cache has dropped the gRPC
+        -- trailers entirely. We therefore check for this case separately and
+        -- throw a different error.
+        throwIO $ CallClosedWithoutTrailers
+      else
+        return $ parseProperTrailers' (Proxy @rpc) trailers
 
   parseMsg _ = parseOutput (Proxy @rpc) . inbCompression
   buildMsg _ = buildInput  (Proxy @rpc) . outCompression
 
 instance SupportsClientRpc rpc => InitiateSession (ClientSession rpc) where
-  parseResponse session info = do
-      -- TODO: <https://github.com/well-typed/grapesy/issues/22>
-      unless (HTTP.statusCode (responseStatus info) == 200) $
-        throwIO $ CallSetupUnexpectedStatus
-                    (responseStatus info)
-                    (fromMaybe BS.Lazy.empty $ responseBody info)
-
-      if isTrailersOnly info then fmap FlowStartNoMessages $
-        parseTrailers (parseTrailersOnly' (Proxy @rpc)) (responseHeaders info)
-      else fmap FlowStartRegular $ do
-        let responseHeaders' :: ResponseHeaders'
-            responseHeaders' = parseResponseHeaders' (Proxy @rpc) $
-                                 responseHeaders info
-        cIn <- getInboundCompression session $
-                 responseCompression responseHeaders'
-        clientUpdateMeta session responseHeaders'
-
-        return $ InboundHeaders {
-            inbHeaders     = responseHeaders'
-          , inbCompression = cIn
-          }
+  parseResponse session (ResponseInfo status headers body) =
+      case classifyServerResponse (Proxy @rpc) status headers body of
+        Left trailersOnly ->
+          -- We classify the response as Trailers-Only if the grpc-status header
+          -- is present, or when the HTTP status is anything other than 200 OK
+          -- (which we treat, as per the spec, as an implicit grpc-status).
+          -- The 'CallClosedWithoutTrailers' case is therefore not relevant.
+          return $ FlowStartNoMessages trailersOnly
+        Right responseHeaders' -> do
+          cIn <- getInboundCompression session $
+                   responseCompression responseHeaders'
+          clientUpdateMeta session responseHeaders'
+          return $ FlowStartRegular $ InboundHeaders {
+              inbHeaders     = responseHeaders'
+            , inbCompression = cIn
+            }
 
   buildRequestInfo _ start = RequestInfo {
         requestMethod  = rawMethod resourceHeaders
@@ -116,29 +117,6 @@ instance SupportsClientRpc rpc => InitiateSession (ClientSession rpc) where
 instance NoTrailers (ClientSession rpc) where
   noTrailers _ = NoMetadata
 
--- | Check if we are in the Trailers-Only case
---
--- It is tempting to use the HTTP @Content-Length@ header to determine whether
--- we are in the Trailers-Only case or not, but this is doubly wrong:
---
--- * There might be servers who use the Trailers-Only case but do not set the
---   @Content-Length@ header (although such a server would not conform to the
---   HTTP spec: "An origin server SHOULD send a @Content-Length@ header field
---   when the content size is known prior to sending the complete header
---   section"; see
---   <https://www.rfc-editor.org/rfc/rfc9110.html#name-content-length>).
--- * Conversely, there might be servers or proxies who /do/ set @Content-Length@
---   header even when it's /not/ the Trailers-Only case (e.g., see
---   <https://github.com/grpc/grpc-web/issues/1101> or
---   <https://github.com/envoyproxy/envoy/issues/5554>).
---
--- We therefore check for the presence of the @grpc-status@ header instead.
-isTrailersOnly :: ResponseInfo -> Bool
-isTrailersOnly = any isGrpcStatus . responseHeaders
-  where
-    isGrpcStatus :: HTTP.Header -> Bool
-    isGrpcStatus (name, _value) = name == "grpc-status"
-
 -- | Determine compression used for messages from the peer
 getInboundCompression ::
      ClientSession rpc
@@ -152,47 +130,13 @@ getInboundCompression session = \case
         Just compr -> return compr
         Nothing    -> throwIO $ CallSetupUnsupportedCompression cid
 
-{-------------------------------------------------------------------------------
-  Internal auxiliary
--------------------------------------------------------------------------------}
-
--- | Parse proper trailers
---
--- Although we parse the trailers in a lenient fashion (like all headers),
--- only throwing errors for headers that we really need, if we get no trailers
--- at /all/, then most likely something has gone wrong; for example, perhaps
--- an intermediate cache has dropped the gRPC trailers entirely. We therefore
--- check for this case separately and throw a different error.
-parseTrailers ::
-     ([HTTP.Header] ->    trailers)
-  ->  [HTTP.Header] -> IO trailers
-parseTrailers _ []  = throwIO $ CallClosedWithoutTrailers
-parseTrailers f raw = return $ f raw
-
 {-------------------------------------------------------------------------------
   Exceptions
 -------------------------------------------------------------------------------}
 
 data CallSetupFailure =
-    -- | Server sent a HTTP status other than 200 OK
-    --
-    -- This can happen in one of two situations:
-    --
-    -- * We sent a malformed request to the server. This cannot happen in
-    --   @grapesy@ unless 'Network.GRPC.Client.ConnParams' is misconfigured.
-    -- * We are dealing with non-compliant server.
-    --
-    -- We also include the response body.
-    --
-    -- TODO: <https://github.com/well-typed/grapesy/issues/22>.
-    -- The spec /does/ require us to deal with non-compliant servers in limited
-    -- ways. For example, some non-compliant servers might return a HTTP 404
-    -- instead of a HTTP 200 with a 'GrpcStatus' of 'GrpcUnimplemented'. We do
-    -- not yet do this.
-    CallSetupUnexpectedStatus HTTP.Status Lazy.ByteString
-
     -- | Server chose an unsupported compression algorithm
-  | CallSetupUnsupportedCompression CompressionId
+    CallSetupUnsupportedCompression CompressionId
 
     -- | We failed to parse the response headers
   | CallSetupInvalidResponseHeaders InvalidHeaders

src/Network/GRPC/Spec.hs

@@ -112,6 +112,7 @@ module Network.GRPC.Spec (
   , buildResponseHeaders
   , parseResponseHeaders
   , parseResponseHeaders'
+  , classifyServerResponse
     -- ** Trailers
   , ProperTrailers_(..)
   , ProperTrailers

src/Network/GRPC/Spec/Headers/Response.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP               #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 -- | Deal with HTTP2 responses
@@ -20,6 +21,7 @@ module Network.GRPC.Spec.Headers.Response (
   , simpleProperTrailers
   , trailersOnlyToProperTrailers
   , properTrailersToTrailersOnly
+  , classifyServerResponse
     -- * gRPC termination
   , GrpcException(..)
   , throwGrpcError
@@ -49,14 +51,23 @@ import Data.Bifunctor
 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.ByteString.Lazy qualified as BS.Lazy
+import Data.ByteString.Lazy qualified as Lazy (ByteString)
 import Data.CaseInsensitive qualified as CI
 import Data.List.NonEmpty (NonEmpty)
+import Data.Maybe (isJust)
 import Data.Proxy
 import Data.Text (Text)
+import Data.Text qualified as Text
+import Data.Text.Encoding qualified as Text
 import GHC.Generics (Generic)
 import Network.HTTP.Types qualified as HTTP
 import Text.Read (readMaybe)
 
+#if !MIN_VERSION_text(2,0,0)
+import Data.Text.Encoding.Error qualified as Text
+#endif
+
 import Network.GRPC.Spec.Compression (CompressionId)
 import Network.GRPC.Spec.CustomMetadata.Map
 import Network.GRPC.Spec.CustomMetadata.Raw
@@ -252,6 +263,125 @@ trailersOnlyToProperTrailers TrailersOnly{
     , trailersOnlyContentType
     )
 
+{-------------------------------------------------------------------------------
+  Classify server response
+-------------------------------------------------------------------------------}
+
+-- | Classify server response
+--
+-- gRPC servers are supposed to respond with HTTP status @200 OK@ no matter
+-- whether the call was successful or not; if not successful, the information
+-- about the failure should be reported using @grpc-status@ and related headers
+-- (@grpc-message@, @grpc-status-details-bin@).
+--
+-- The gRPC spec mandates that if we get a non-200 status from a broken
+-- deployment, we synthesize a gRPC exception with an appropriate status and
+-- status message. The spec itself does not provide any guidance on what such an
+-- appropriate status would look like, but the official gRPC repo does provide a
+-- partial mapping between HTTP status codes and gRPC status codes at
+-- <https://github.com/grpc/grpc/blob/master/doc/http-grpc-status-mapping.md>.
+-- This is the mapping we implement here.
+classifyServerResponse :: forall rpc.
+     IsRPC rpc
+  => Proxy rpc
+  -> HTTP.Status           -- ^ HTTP status
+  -> [HTTP.Header]         -- ^ Headers
+  -> Maybe Lazy.ByteString -- ^ Response body, if known (used for errors only)
+  -> Either TrailersOnly' ResponseHeaders'
+classifyServerResponse rpc status headers mBody
+  -- The "HTTP to gRPC Status Code Mapping" is explicit:
+  --
+  -- > (..) to be used only for clients that received a response that did not
+  -- > include grpc-status. If grpc-status was provided, it must be used.
+  --
+  -- Therefore if @grpc-status@ is present, we ignore the HTTP status.
+  | hasGrpcStatus headers
+  = Left $ parseTrailersOnly' rpc headers
+
+  | 200 <- statusCode
+  = Right $ parseResponseHeaders' rpc headers
+
+  | otherwise
+  = Left $
+      case statusCode of
+        400 -> synthesize GrpcInternal         -- Bad request
+        401 -> synthesize GrpcUnauthenticated  -- Unauthorized
+        403 -> synthesize GrpcPermissionDenied -- Forbidden
+        404 -> synthesize GrpcUnimplemented    -- Not found
+        429 -> synthesize GrpcUnavailable      -- Too many requests
+        502 -> synthesize GrpcUnavailable      -- Bad gateway
+        503 -> synthesize GrpcUnavailable      -- Service unavailable
+        504 -> synthesize GrpcUnavailable      -- Gateway timeout
+        _   -> synthesize GrpcUnknown
+  where
+    HTTP.Status{statusCode, statusMessage} = status
+
+    -- The @grpc-status@ header not present, and HTTP status not @200 OK@.
+    -- We classify the response as an error response (hence 'TrailersOnly''):
+    --
+    -- * We set 'properTrailersGrpcStatus' based on the HTTP status.
+    -- * We leave 'properTrailersGrpcMessage' alone if @grpc-message@ present
+    --   and valid, and replace it with a default message otherwise.
+    --
+    -- The resulting 'TrailersOnly'' cannot contain any parse errors
+    -- (only @grpc-status@ is required, and only @grpc-message@ can fail).
+    synthesize :: GrpcError -> TrailersOnly'
+    synthesize err = parsed {
+          trailersOnlyProper = parsedTrailers {
+              properTrailersGrpcStatus = Right $
+                GrpcError err
+            , properTrailersGrpcMessage = Right $
+                case properTrailersGrpcMessage parsedTrailers of
+                  Right (Just msg) -> Just msg
+                  _otherwise       -> Just defaultMsg
+            }
+        }
+
+      where
+        parsed :: TrailersOnly'
+        parsed = parseTrailersOnly' rpc headers
+
+        parsedTrailers :: ProperTrailers'
+        parsedTrailers = trailersOnlyProper parsed
+
+        defaultMsg :: Text
+        defaultMsg = mconcat [
+              "Unexpected HTTP status code "
+            , Text.pack (show statusCode)
+            , if not (BS.Strict.null statusMessage)
+                then " (" <> decodeUtf8Lenient statusMessage <> ")"
+                else mempty
+            , case mBody of
+                Just body | not (BS.Lazy.null body) -> mconcat [
+                    "\nResponse body:\n"
+                  , decodeUtf8Lenient (BS.Lazy.toStrict body)
+                  ]
+                _otherwise ->
+                  mempty
+            ]
+
+-- | Is the @grpc-status@ header set?
+--
+-- We use this as a proxy to determine if we are in the Trailers-Only case.
+--
+-- It might be tempting to use the HTTP @Content-Length@ header instead, but
+-- this is doubly wrong:
+--
+-- * There might be servers who use the Trailers-Only case but do not set the
+--   @Content-Length@ header (although such a server would not conform to the
+--   HTTP spec: "An origin server SHOULD send a @Content-Length@ header field
+--   when the content size is known prior to sending the complete header
+--   section"; see
+--   <https://www.rfc-editor.org/rfc/rfc9110.html#name-content-length>).
+-- * Conversely, there might be servers or proxies who /do/ set @Content-Length@
+--   header even when it's /not/ the Trailers-Only case (e.g., see
+--   <https://github.com/grpc/grpc-web/issues/1101> or
+--   <https://github.com/envoyproxy/envoy/issues/5554>).
+--
+-- We therefore check for the presence of the @grpc-status@ header instead.
+hasGrpcStatus :: [HTTP.Header] -> Bool
+hasGrpcStatus = isJust . lookup "grpc-status"
+
 {-------------------------------------------------------------------------------
   Pushback
 -------------------------------------------------------------------------------}
@@ -676,3 +806,9 @@ parseTrailersOnly' proxy =
 otherInvalid :: Either InvalidHeaders () -> InvalidHeaders
 otherInvalid = either id (\() -> mempty)
 
+decodeUtf8Lenient :: BS.Strict.C8.ByteString -> Text
+#if MIN_VERSION_text(2,0,0)
+decodeUtf8Lenient = Text.decodeUtf8Lenient
+#else
+decodeUtf8Lenient = Text.decodeUtf8With Text.lenientDecode
+#endif

test-grapesy/Main.hs

@@ -16,6 +16,7 @@ import GHC.Conc.Sync (threadLabel)
 import Test.Prop.Dialogue                     qualified as Dialogue
 import Test.Prop.IncrementalParsing           qualified as IncrementalParsing
 import Test.Prop.Serialization                qualified as Serialization
+import Test.Sanity.BrokenDeployments          qualified as BrokenDeployments
 import Test.Sanity.EndOfStream                qualified as EndOfStream
 import Test.Sanity.Interop                    qualified as Interop
 import Test.Sanity.StreamingType.CustomFormat qualified as StreamingType.CustomFormat
@@ -33,6 +34,7 @@ main = do
               , StreamingType.CustomFormat.tests
               ]
           , Interop.tests
+          , BrokenDeployments.tests
           ]
       , testGroup "Prop" [
             IncrementalParsing.tests