Better server-side handling of metadata and errors

demo-server/Demo/Server/Cmdline.hs

@@ -15,9 +15,10 @@ import Network.GRPC.Server.Run
 -------------------------------------------------------------------------------}
 
 data Cmdline = Cmdline {
-      cmdInsecure :: Maybe InsecureConfig
-    , cmdSecure   :: Maybe SecureConfig
-    , cmdDebug    :: Bool
+      cmdInsecure             :: Maybe InsecureConfig
+    , cmdSecure               :: Maybe SecureConfig
+    , cmdDebug                :: Bool
+    , cmdTrailersOnlyShortcut :: Bool
     }
   deriving (Show)
 
@@ -38,6 +39,10 @@ parseCmdline =
                Opt.long "debug"
              , Opt.help "Enable debug output"
              ])
+      <*> (Opt.switch $ mconcat [
+               Opt.long "trailers-only-shortcut"
+             , Opt.help "Use Trailers-Only even in non-error cases"
+             ])
 
 parseInsecure :: Opt.Parser (Maybe InsecureConfig)
 parseInsecure = asum [

demo-server/Demo/Server/API/Protobuf/Greeter.hs → demo-server/Demo/Server/Service/Greeter.hs

@@ -1,10 +1,11 @@
 {-# LANGUAGE OverloadedLabels  #-}
 {-# LANGUAGE OverloadedStrings #-}
 
-module Demo.Server.API.Protobuf.Greeter (handlers) where
+module Demo.Server.Service.Greeter (handlers) where
 
 import Control.Lens ((.~), (^.))
 import Control.Monad
+import Data.Default
 import Data.Function ((&))
 import Data.ProtoLens
 import Data.ProtoLens.Labels ()
@@ -41,14 +42,15 @@ sayHello req = return $ defMessage & #message .~ msg
 
 sayHelloStreamReply :: RpcHandler IO
 sayHelloStreamReply =
-    (mkRpcHandler (Proxy @(Protobuf Greeter "sayHelloStreamReply")) go) {
-        handlerMetadata = \_reqMetadata -> return [
-            AsciiHeader "initial-md" "initial-md-value"
-          ]
-      }
+    mkRpcHandler (Proxy @(Protobuf Greeter "sayHelloStreamReply")) go
   where
     go :: Call (Protobuf Greeter "sayHelloStreamReply") -> IO ()
     go call = do
+        setResponseMetadata call [AsciiHeader "initial-md" "initial-md-value"]
+
+        -- The client expects the metadata well before the first output
+        _ <- initiateResponse call
+
         req <- recvFinalInput call
 
         let msg :: Text -> Text
@@ -57,4 +59,4 @@ sayHelloStreamReply =
         forM_ ["0", "1", "2"] $ \i ->
           sendNextOutput call $ defMessage & #message .~ msg i
 
-        sendTrailers call []
+        sendTrailers call def

demo-server/Demo/Server/API/Protobuf/RouteGuide.hs → demo-server/Demo/Server/Service/RouteGuide.hs

@@ -1,35 +1,45 @@
 {-# LANGUAGE CPP              #-}
 {-# LANGUAGE OverloadedLabels #-}
 
-module Demo.Server.API.Protobuf.RouteGuide (handlers) where
+module Demo.Server.Service.RouteGuide (handlers) where
 
 import Control.Lens (view, (^.))
 import Control.Monad.State (StateT)
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.State qualified as State
+import Data.Default
 import Data.Map qualified as Map
 import Data.Maybe (fromMaybe)
 import Data.ProtoLens
 import Data.ProtoLens.Labels ()
+import Data.Proxy
 import Data.Time
 
+import Network.GRPC.Common.StreamElem (StreamElem(..))
 import Network.GRPC.Common.StreamElem qualified as StreamElem
 import Network.GRPC.Common.StreamType
+import Network.GRPC.Server
 import Network.GRPC.Server.Protobuf
 import Network.GRPC.Server.StreamType
 
 import Proto.RouteGuide
 
 import Demo.Server.Aux.RouteGuide
+import Demo.Server.Cmdline
 
 {-------------------------------------------------------------------------------
   Top-level
 -------------------------------------------------------------------------------}
 
-handlers :: [Feature] -> Methods IO (ProtobufMethodsOf RouteGuide)
-handlers db =
+handlers :: Cmdline -> [Feature] -> Methods IO (ProtobufMethodsOf RouteGuide)
+handlers cmdline db =
       Method (mkNonStreaming    $ getFeature   db)
-    $ Method (mkServerStreaming $ listFeatures db)
+    $ ( if cmdTrailersOnlyShortcut cmdline
+          then RawMethod $ mkRpcHandler
+                             (Proxy @(Protobuf RouteGuide "listFeatures"))
+                             (trailersOnlyShortcut db)
+          else Method (mkServerStreaming $ listFeatures db)
+      )
     $ Method (mkClientStreaming $ recordRoute  db)
     $ Method (mkBiDiStreaming   $ routeChat    db)
     $ NoMoreMethods
@@ -44,7 +54,7 @@ getFeature db p = return $ fromMaybe defMessage $ featureAt db p
 listFeatures :: [Feature] -> Rectangle -> (Feature -> IO ()) -> IO ()
 listFeatures db r send = mapM_ send $ filter (inRectangle r . view #location) db
 
-recordRoute :: [Feature] -> IO (StreamElem.StreamElem () Point) -> IO RouteSummary
+recordRoute :: [Feature] -> IO (StreamElem () Point) -> IO RouteSummary
 recordRoute db recv = do
     start <- getCurrentTime
     ps    <- StreamElem.collect recv
@@ -53,7 +63,7 @@ recordRoute db recv = do
 
 routeChat ::
      [Feature]
-  -> IO (StreamElem.StreamElem () RouteNote)
+  -> IO (StreamElem () RouteNote)
   -> (RouteNote -> IO ())
   -> IO ()
 routeChat _db recv send = do
@@ -62,6 +72,25 @@ routeChat _db recv send = do
         mapM_ send $ reverse $ Map.findWithDefault [] (n ^. #location) acc
         return $ Map.alter (Just . (n:) . fromMaybe []) (n ^. #location) acc
 
+{-------------------------------------------------------------------------------
+  Trailers-Only shortcut
+
+  See discussion in @demo-server.md@.
+-------------------------------------------------------------------------------}
+
+trailersOnlyShortcut ::
+     [Feature]
+  -> Call (Protobuf RouteGuide "listFeatures")
+  -> IO ()
+trailersOnlyShortcut db call = do
+    r <- recvFinalInput call
+    let features = filter (inRectangle r . view #location) db
+    if null features then
+      sendTrailersOnly call  $ TrailersOnly def
+    else do
+      mapM_ (sendOutput call . StreamElem) features
+      sendTrailers call def
+
 {-------------------------------------------------------------------------------
   Auxiliary
 -------------------------------------------------------------------------------}

demo-server/Main.hs

@@ -13,9 +13,9 @@ import Network.GRPC.Server.StreamType
 
 import Demo.Common.Logging
 
-import Demo.Server.API.Protobuf.Greeter    qualified as Greeter
-import Demo.Server.API.Protobuf.RouteGuide qualified as RouteGuide
 import Demo.Server.Cmdline
+import Demo.Server.Service.Greeter    qualified as Greeter
+import Demo.Server.Service.RouteGuide qualified as RouteGuide
 
 import Proto.Helloworld
 import Proto.RouteGuide
@@ -26,10 +26,13 @@ import Paths_grapesy
   All services
 -------------------------------------------------------------------------------}
 
-services :: [Feature] -> Services IO (ProtobufServices '[Greeter, RouteGuide])
-services db =
+services ::
+     Cmdline
+  -> [Feature]
+  -> Services IO (ProtobufServices '[Greeter, RouteGuide])
+services cmdline db =
       Service Greeter.handlers
-    $ Service (RouteGuide.handlers db)
+    $ Service (RouteGuide.handlers cmdline db)
     $ NoMoreServices
 
 {-------------------------------------------------------------------------------
@@ -38,22 +41,22 @@ services db =
 
 main :: IO ()
 main = do
-    cmd <- getCmdline
+    cmdline <- getCmdline
     db      <- getRouteGuideDb
 
     let serverConfig :: ServerConfig
         serverConfig = ServerConfig {
             serverTracer =
-              if cmdDebug cmd
+              if cmdDebug cmdline
                 then contramap show threadSafeTracer
                 else nullTracer
           , serverInsecure =
-              cmdInsecure cmd
+              cmdInsecure cmdline
           , serverSecure   =
-              cmdSecure   cmd
+              cmdSecure cmdline
           }
 
-    withServer (serverParams cmd) (fromServices (services db)) $
+    withServer (serverParams cmdline) (fromServices $ services cmdline db) $
       runServer serverConfig
 
 getRouteGuideDb :: IO [Feature]

docs/demo-server.md

@@ -72,4 +72,36 @@ grpc-repo/examples/python/route_guide$ python3 route_guide_client.py
 
 Currently server-side compression can be verified simply by running the Python
 hello-world client (and then looking at the communication in Wireshark), because
-the server applies compression independent of whether that saves space or not.
+the server applies compression independent of whether that saves space or not.
+
+### Trailers-Only shortcut
+
+A normal gRPC response looks like
+
+```
+<headers>
+<messages>
+<trailers>
+```
+
+If there are no messages, then this whole thing collapses to just a set of
+trailers (or headers; the distinction is no longer relevant in this case); the
+gRPC specification refers to this as `Trailers-Only`. The spec says that this
+should _only_ be used in error cases, but in practice some servers also use this
+for normal cases. For example, the Python implementation of the `ListFeatures`
+method will use `Trailers-Only` in the case that the list of features is empty.
+
+The Protobuf-specific wrappers in `grapesy` will not use `Trailers-Only` except
+in the case of errors, comform the spec; however, it is possible to use the
+lower-level server API to get the behaviour exibited by the Python example
+implementation. The command line flag `--trailers-only-shortcut` enables this
+for the demo server. The difference in server operation can only be observed
+with Wireshark; a request for a list of features in the rectangle `(0, 0, 0, 0)`
+(which is empty) will
+
+* result in three HTTP frames in the normal case (`HEADERS`, empty `DATA` to
+  separate headers from trailers, and another `HEADERS` frame with the trailers)
+* result in a single HTTP `HEADERS` frame when using `--trailers-only-shortcut`
+
+Note that this behaviour is _NOT_ conform the gRPC spec, so not all clients
+may support it.

grapesy.cabal

@@ -205,6 +205,7 @@ test-suite test-grapesy
   other-modules:
       Paths_grapesy
       Test.Driver.ClientServer
+      Test.Driver.Dialogue
       Test.Sanity.StreamingType.NonStreaming
       Test.Util.ClientServer
       Test.Util.SOP
@@ -282,10 +283,10 @@ executable demo-server
       -threaded
   other-modules:
       Demo.Common.Logging
-      Demo.Server.API.Protobuf.Greeter
-      Demo.Server.API.Protobuf.RouteGuide
       Demo.Server.Aux.RouteGuide
       Demo.Server.Cmdline
+      Demo.Server.Service.Greeter
+      Demo.Server.Service.RouteGuide
       Proto.Helloworld
       Proto.Helloworld_Fields
       Proto.RouteGuide

src/Network/GRPC/Client/Session.hs

@@ -70,7 +70,7 @@ instance IsRPC rpc => IsSession (ClientSession rpc) where
   type Outbound (ClientSession rpc) = ClientOutbound rpc
 
   buildProperTrailers _client = \() ->
-      return [] -- Request trailers are not supported by gRPC
+      [] -- Request trailers are not supported by gRPC
   parseProperTrailers _client =
       processResponseTrailers $ Resp.parseProperTrailers (Proxy @rpc)
 
@@ -105,15 +105,14 @@ instance IsRPC rpc => InitiateSession (ClientSession rpc) where
         (fmap GRPC.getTrailersOnly .  Resp.parseTrailersOnly (Proxy @rpc))
         (responseHeaders info)
 
-  buildRequestInfo _ start = do
-      return RequestInfo {
-          requestMethod  = rawMethod resourceHeaders
-        , requestPath    = rawPath resourceHeaders
-        , requestHeaders = Req.buildHeaders (Proxy @rpc) $
-              case start of
-                FlowStartRegular      headers -> outHeaders headers
-                FlowStartTrailersOnly headers ->            headers
-        }
+  buildRequestInfo _ start = RequestInfo {
+        requestMethod  = rawMethod resourceHeaders
+      , requestPath    = rawPath resourceHeaders
+      , requestHeaders = Req.buildHeaders (Proxy @rpc) $
+            case start of
+              FlowStartRegular      headers -> outHeaders headers
+              FlowStartTrailersOnly headers ->            headers
+      }
     where
       resourceHeaders :: RawResourceHeaders
       resourceHeaders = buildResourceHeaders $ ResourceHeaders {