diff --git a/grapesy.cabal b/grapesy.cabal index 6a11227b..4b112f13 100644 --- a/grapesy.cabal +++ b/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 diff --git a/src/Network/GRPC/Client/Session.hs b/src/Network/GRPC/Client/Session.hs index eb68671d..e3e56e51 100644 --- a/src/Network/GRPC/Client/Session.hs +++ b/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: - 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 --- ). --- * 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 --- or --- ). --- --- 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: . - -- 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 diff --git a/src/Network/GRPC/Spec.hs b/src/Network/GRPC/Spec.hs index dbdeda2f..2d997486 100644 --- a/src/Network/GRPC/Spec.hs +++ b/src/Network/GRPC/Spec.hs @@ -112,6 +112,7 @@ module Network.GRPC.Spec ( , buildResponseHeaders , parseResponseHeaders , parseResponseHeaders' + , classifyServerResponse -- ** Trailers , ProperTrailers_(..) , ProperTrailers diff --git a/src/Network/GRPC/Spec/Headers/Response.hs b/src/Network/GRPC/Spec/Headers/Response.hs index 1ae57ac6..e24ccba1 100644 --- a/src/Network/GRPC/Spec/Headers/Response.hs +++ b/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 +-- . +-- 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 +-- ). +-- * 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 +-- or +-- ). +-- +-- 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 diff --git a/test-grapesy/Main.hs b/test-grapesy/Main.hs index a0b069b8..a3575150 100644 --- a/test-grapesy/Main.hs +++ b/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 diff --git a/test-grapesy/Test/Driver/ClientServer.hs b/test-grapesy/Test/Driver/ClientServer.hs index 200bf3ad..81771e74 100644 --- a/test-grapesy/Test/Driver/ClientServer.hs +++ b/test-grapesy/Test/Driver/ClientServer.hs @@ -29,7 +29,6 @@ import Data.Map qualified as Map import Data.Set (Set) import Data.Set qualified as Set import Data.Text qualified as Text -import Network.HTTP.Types qualified as HTTP import Network.HTTP2.Server qualified as HTTP2.Server import Network.Socket (PortNumber) import Network.TLS @@ -265,9 +264,11 @@ isExpectedClientException cfg e -- Call setup failure -- - | Just (Client.CallSetupUnexpectedStatus status _body) <- fromException e + | Just grpcException <- fromException e + , GrpcUnknown <- grpcError grpcException + , Just msg <- grpcErrorMessage grpcException + , "415" `Text.isInfixOf` msg , InvalidOverride _ <- clientContentType cfg - , status == HTTP.unsupportedMediaType415 = True -- @@ -275,9 +276,12 @@ isExpectedClientException cfg e -- -- Client choose unsupported compression - | Just (Client.CallSetupUnexpectedStatus status _body) <- fromException e + -- + -- We respond with 400 Bad Request, which gets turned into GrpcInternal + -- by 'classifyServerResponse'. + | Just grpcException <- fromException e + , GrpcInternal <- grpcError grpcException , compressionNegotationFailure cfg - , status == HTTP.badRequest400 = True -- Server chose unsupported compression diff --git a/test-grapesy/Test/Sanity/BrokenDeployments.hs b/test-grapesy/Test/Sanity/BrokenDeployments.hs new file mode 100644 index 00000000..c0a7f2d8 --- /dev/null +++ b/test-grapesy/Test/Sanity/BrokenDeployments.hs @@ -0,0 +1,90 @@ +module Test.Sanity.BrokenDeployments (tests) where + +import Control.Concurrent +import Control.Concurrent.Async +import Control.Exception +import Network.HTTP.Types qualified as HTTP +import Network.HTTP2.Server qualified as HTTP2 +import Network.Run.TCP qualified as NetworkRun +import Test.Tasty +import Test.Tasty.HUnit + +import Network.GRPC.Client qualified as Client +import Network.GRPC.Common +import Network.GRPC.Common.Protobuf + +import Proto.API.Ping +import Network.Socket + +{------------------------------------------------------------------------------- + Top-level +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "Test.Sanity.BrokenDeployments" [ + testCase "non200" test_non200 + ] + +{------------------------------------------------------------------------------- + Tests +-------------------------------------------------------------------------------} + +-- | Test HTTP to gRPC status code mapping +-- +-- We don't test all codes here; we'd just end up duplicating the logic in +-- 'classifyServerResponse'. We just check one representative value. +test_non200 :: Assertion +test_non200 = do + serverPort <- newEmptyMVar + withAsync (respondWith HTTP.badRequest400 serverPort) $ \_server -> do + port <- readMVar serverPort + let addr :: Client.Address + addr = Client.Address { + addressHost = "127.0.0.1" + , addressPort = port + , addressAuthority = Nothing + } + mResp :: Either GrpcException (Proto PongMessage) <- try $ + Client.withConnection def (Client.ServerInsecure addr) $ \conn -> + Client.withRPC conn def (Proxy @Ping) $ \call -> do + Client.sendFinalInput call defMessage + fst <$> Client.recvFinalOutput call + case mResp of + Left err | grpcError err == GrpcInternal -> + return () + _otherwise -> + assertFailure $ "Unexpected response: " ++ show mResp + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +-- | Server that always responses with given status to every request +respondWith :: HTTP.Status -> MVar PortNumber -> IO () +respondWith status = testServer $ \_req _aux respond -> + respond (HTTP2.responseNoBody status []) [] + +-- | Low-level test server +-- +-- We bypass the entire grapesy machinery for constructing the server, because +-- we need to mock a broken deployment. +-- +-- The grapesy client can auto reconnect when the server is not (yet) up and +-- running, but to keep things simple, and since the server anyway runs in the +-- same process, we just signal when the server is ready. This also allows us +-- to avoid binding to a specific port in the tests (which might already be in +-- use on the machine running the tests, leading to spurious test failures). +testServer :: HTTP2.Server -> MVar PortNumber -> IO () +testServer server serverPort = do + addr <- NetworkRun.resolve Stream (Just "127.0.0.1") "0" [AI_PASSIVE] + bracket (NetworkRun.openTCPServerSocket addr) close $ \listenSock -> do + addr' <- getSocketName listenSock + port <- case addr' of + SockAddrInet port _host -> return port + SockAddrInet6 port _ _host _ -> return port + SockAddrUnix{} -> error "respondWith: unexpected unix socket" + putMVar serverPort port + NetworkRun.runTCPServerWithSocket listenSock $ \clientSock -> + bracket (HTTP2.allocSimpleConfig clientSock 4096) + HTTP2.freeSimpleConfig $ \config -> + HTTP2.run HTTP2.defaultServerConfig config server