Continue test-suite

The dialogue-based test suite is _so_ useful for discovering inconsistencies
between the server and the client API, since a _single_ description of the
communication is interpreted in "dual" ways by both the server and the client.

We still haven't actually _executed_ any of these tests (we're getting close to
that point now), but simply writing them has already proven very useful indeed.

demo-server/Demo/Server/Service/RouteGuide.hs

@@ -86,7 +86,7 @@ trailersOnlyShortcut db call = do
     r <- recvFinalInput call
     let features = filter (inRectangle r . view #location) db
     if null features then
-      sendTrailersOnly call  $ TrailersOnly def
+      sendTrailersOnly call []
     else do
       mapM_ (sendOutput call . StreamElem) features
       sendTrailers call def

grapesy.cabal

@@ -208,21 +208,21 @@ test-suite test-grapesy
       Test.Driver.Dialogue
       Test.Sanity.StreamingType.NonStreaming
       Test.Util.ClientServer
-      Test.Util.SOP
   build-depends:
       -- Internal dependencies
     , grapesy
   build-depends:
       -- External dependencies
-    , async         >= 2.2  && < 2.3
-    , containers    >= 0.6  && < 0.7
-    , contra-tracer >= 0.2  && < 0.3
-    , data-default  >= 0.7  && < 0.8
-    , sop-core      >= 0.5  && < 0.6
-    , tasty         >= 1.4  && < 1.5
-    , tasty-hunit   >= 0.10 && < 0.11
-    , text          >= 1.2  && < 2.1
-    , tls           >= 1.5  && < 1.8
+    , async            >= 2.2  && < 2.3
+    , containers       >= 0.6  && < 0.7
+    , contra-tracer    >= 0.2  && < 0.3
+    , data-default     >= 0.7  && < 0.8
+    , stm              >= 2.5  && < 2.6
+    , tasty            >= 1.4  && < 1.5
+    , tasty-hunit      >= 0.10 && < 0.11
+    , text             >= 1.2  && < 2.1
+    , tls              >= 1.5  && < 1.8
+    , unbounded-delays >= 0.1  && < 0.2
 
 executable demo-client
   import:

src/Network/GRPC/Client.hs

@@ -31,6 +31,7 @@ module Network.GRPC.Client (
   , Timeout(..)
   , TimeoutValue(TimeoutValue, getTimeoutValue)
   , TimeoutUnit(..)
+  , timeoutToMicro
 
     -- * Ongoing calls
     --

src/Network/GRPC/Client/Binary.hs

@@ -23,14 +23,14 @@ import Network.GRPC.Common.StreamElem
 {-------------------------------------------------------------------------------
   Convenience wrappers using @binary@ for serialization/deserialization
 
-  We do /not/ wrap the client handlers here, because they are not a good match.
-  The standard client streaming handlers expect a /single/ IO action that
-  produces all inputs and/or a single IO action that handles all outputs, but
-  the raw binary protocol allows message types to be different at each point in
-  the communication.
+  Unlike for the server, we do /not/ wrap the client handlers here, because they
+  are not a good match. The standard client streaming handlers expect a /single/
+  IO action that produces all inputs and/or a single IO action that handles all
+  outputs, but the raw binary protocol allows message types to be different at
+  each point in the communication.
 
-  These functions all have the type of the value sent or received as the
-  /first/ argument, to facilitate the use of type arguments.
+  These functions all have the type of the value sent or received as the /first/
+  argument, to facilitate the use of type arguments.
 -------------------------------------------------------------------------------}
 
 sendInput :: forall inp serv meth.

src/Network/GRPC/Server.hs

@@ -18,14 +18,11 @@ module Network.GRPC.Server (
 
     -- ** Protocol specific wrappers
   , recvFinalInput
-  , recvNextInput
   , sendFinalOutput
   , sendNextOutput
   , sendTrailers
 
     -- ** Low-level API
-  , ProperTrailers(..)
-  , TrailersOnly(..)
   , recvInputSTM
   , sendOutputSTM
   , initiateResponse
@@ -105,7 +102,7 @@ handleRequest handlers conn = do
 forwardException :: Call rpc -> SomeException -> IO ()
 forwardException call err =
     handle ignoreExceptions $
-      sendTrailers call trailers
+      sendProperTrailers call trailers
   where
     trailers :: ProperTrailers
     trailers

src/Network/GRPC/Server/Binary.hs

@@ -4,8 +4,13 @@
 --
 -- import Network.GRPC.Server.Binary qualified as Binary
 module Network.GRPC.Server.Binary (
+    -- | Convenience wrappers using @binary@ for serialization/deserialization
+    sendOutput
+  , sendFinalOutput
+  , recvInput
+  , recvFinalInput
     -- * Streaming types
-    mkNonStreaming
+  , mkNonStreaming
   , mkClientStreaming
   , mkServerStreaming
   , mkBiDiStreaming
@@ -14,9 +19,46 @@ module Network.GRPC.Server.Binary (
 import Control.Monad.Catch
 import Data.Binary
 
-import Network.GRPC.Common.StreamType qualified as StreamType
 import Network.GRPC.Common.Binary
+import Network.GRPC.Common.CustomMetadata (CustomMetadata)
 import Network.GRPC.Common.StreamElem
+import Network.GRPC.Common.StreamType qualified as StreamType
+import Network.GRPC.Server (Call)
+import Network.GRPC.Server qualified as Server
+
+{-------------------------------------------------------------------------------
+  Convenience wrapers using @binary@ for serialization/deserialization
+-------------------------------------------------------------------------------}
+
+sendOutput ::
+     Binary a
+  => Call (BinaryRpc serv meth)
+  -> StreamElem [CustomMetadata] a
+  -> IO ()
+sendOutput call out =
+    Server.sendOutput call (encode <$> out)
+
+sendFinalOutput ::
+     Binary a
+  => Call (BinaryRpc serv meth)
+  -> (a, [CustomMetadata])
+  -> IO ()
+sendFinalOutput call (out, trailers) =
+    Server.sendFinalOutput call (encode out, trailers)
+
+recvInput ::
+     Binary a
+  => Call (BinaryRpc serv meth)
+  -> IO (StreamElem () a)
+recvInput call = do
+    Server.recvInput call >>= traverse decodeOrThrow
+
+recvFinalInput ::
+     Binary a
+  => Call (BinaryRpc serv meth)
+  -> IO a
+recvFinalInput call =
+     Server.recvFinalInput call >>= decodeOrThrow
 
 {-------------------------------------------------------------------------------
   Handlers for specific streaming types
@@ -61,4 +103,5 @@ mkBiDiStreaming :: forall m serv meth.
     )
   -> StreamType.BiDiStreamingHandler m (BinaryRpc serv meth)
 mkBiDiStreaming f = StreamType.mkBiDiStreaming $ \recv send ->
-    f (recv >>= traverse decodeOrThrow) (send . encode)
+    f (recv >>= traverse decodeOrThrow) (send . encode)
+

src/Network/GRPC/Server/Call.hs

@@ -17,7 +17,6 @@ module Network.GRPC.Server.Call (
 
     -- ** Protocol specific wrappers
   , recvFinalInput
-  , recvNextInput
   , sendFinalOutput
   , sendNextOutput
   , sendTrailers
@@ -27,6 +26,9 @@ module Network.GRPC.Server.Call (
   , sendOutputSTM
   , initiateResponse
   , sendTrailersOnly
+
+    -- ** Internal API
+  , sendProperTrailers
   ) where
 
 import Control.Concurrent.STM
@@ -227,7 +229,12 @@ recvInput :: forall rpc. Call rpc -> IO (StreamElem () (Input rpc))
 recvInput = atomically . recvInputSTM
 
 -- | Send RPC output to the client
-sendOutput :: Call rpc -> StreamElem ProperTrailers (Output rpc) -> IO ()
+--
+-- This will send a @grpc-status@ of @0@ to the client; for anything else (i.e.,
+-- to indicate something went wrong), the server handler should throw a
+-- 'GrpcException' (the @grapesy@ client API treats this the same way: a
+-- @grpc-status@ other than @0@ will be raised as a 'GrpcException').
+sendOutput :: Call rpc -> StreamElem [CustomMetadata] (Output rpc) -> IO ()
 sendOutput call msg = do
     _updated <- initiateResponse call
     atomically $ sendOutputSTM call msg
@@ -287,12 +294,19 @@ recvInputSTM Call{callChannel} =
 -- You /MUST/ call 'initiateResponse' before calling 'sendOutputSTM'; throws
 -- 'ResponseNotInitiated' otherwise. This is a low-level API; most users can use
 -- 'sendOutput' instead.
-sendOutputSTM :: Call rpc -> StreamElem ProperTrailers (Output rpc) -> STM ()
+sendOutputSTM :: Call rpc -> StreamElem [CustomMetadata] (Output rpc) -> STM ()
 sendOutputSTM Call{callChannel, callResponseKickoff} msg = do
     mKickoff <- tryReadTMVar callResponseKickoff
     case mKickoff of
-      Just _  -> Session.send callChannel msg
+      Just _  -> Session.send callChannel (first mkTrailers msg)
       Nothing -> throwSTM $ ResponseNotInitiated
+  where
+    mkTrailers :: [CustomMetadata] -> ProperTrailers
+    mkTrailers metadata = ProperTrailers {
+          trailerGrpcStatus  = GrpcOk
+        , trailerGrpcMessage = Nothing
+        , trailerMetadata    = metadata
+        }
 
 -- | Initiate the response
 --
@@ -303,14 +317,40 @@ initiateResponse :: Call rpc -> IO Bool
 initiateResponse Call{callResponseKickoff} =
     atomically $ tryPutTMVar callResponseKickoff KickoffRegular
 
--- | TODO: Docs and test
+-- | Use the gRPC @Trailers-Only@ case for non-error responses
+--
+-- Under normal circumstances a gRPC server will respond to the client with
+-- an initial set of headers, than zero or more messages, and finally a set of
+-- trailers. When there /are/ no messages, this /can/ be collapsed into a single
+-- set of trailers (or headers, depending on your point of view); the gRPC
+-- specification refers to this as the @Trailers-Only@ case. It mandates:
+--
+-- > Most responses are expected to have both headers and trailers but
+-- > Trailers-Only is permitted for calls that produce an immediate error.
+--
+-- In @grapesy@, if a server handler throws a 'GrpcException', we will make use
+-- of this @Trailers-Only@ case if applicable, as per the specification.
+--
+-- /However/, some servers make use of @Trailers-Only@ also in non-error cases.
+-- For example, the @listFeatures@ handler in the official Python route guide
+-- example server will use @Trailers-Only@ if there are no features to report.
+-- Since this is not conform the gRPC specification, we do not do this in
+-- @grapesy@ by default, but we make the option available through
+-- 'sendTrailersOnly'.
 --
 -- Throws 'ResponseAlreadyInitiated' if the response has already been initiated.
-sendTrailersOnly :: Call rpc -> TrailersOnly -> IO ()
-sendTrailersOnly Call{callResponseKickoff} trailers = do
+sendTrailersOnly :: Call rpc -> [CustomMetadata] -> IO ()
+sendTrailersOnly Call{callResponseKickoff} metadata = do
     updated <- atomically $ tryPutTMVar callResponseKickoff $
                  KickoffTrailersOnly trailers
     unless updated $ throwIO ResponseAlreadyInitiated
+  where
+    trailers :: TrailersOnly
+    trailers = TrailersOnly $ ProperTrailers {
+          trailerGrpcStatus  = GrpcOk
+        , trailerGrpcMessage = Nothing
+        , trailerMetadata    = metadata
+        }
 
 data ResponseKickoffException =
     ResponseAlreadyInitiated
@@ -341,13 +381,10 @@ recvFinalInput call@Call{} = do
           FinalElem  inp' _ -> throwIO $ TooManyInputs @rpc inp'
           StreamElem inp'   -> throwIO $ TooManyInputs @rpc inp'
 
-recvNextInput :: Call rpc -> IO (StreamElem () (Input rpc))
-recvNextInput call = recvInput call
-
 -- | Send final output
 --
 -- See also 'sendTrailers'.
-sendFinalOutput :: Call rpc -> (Output rpc, ProperTrailers) -> IO ()
+sendFinalOutput :: Call rpc -> (Output rpc, [CustomMetadata]) -> IO ()
 sendFinalOutput call = sendOutput call . uncurry FinalElem
 
 -- | Send the next output
@@ -362,5 +399,25 @@ sendNextOutput call = sendOutput call . StreamElem
 -- this (or 'sendFinalOutput') even when there is no special information to be
 -- included in the trailers (in this case, you can use the 'Default' instance
 -- for 'ProperTrailers').
-sendTrailers :: Call rpc -> ProperTrailers -> IO ()
+sendTrailers :: Call rpc -> [CustomMetadata] -> IO ()
 sendTrailers call = sendOutput call . NoMoreElems
+
+{-------------------------------------------------------------------------------
+  Internal API
+-------------------------------------------------------------------------------}
+
+-- | Send 'ProperTrailers'
+--
+-- This function is not part of the public API: we use it the top-level
+-- exception handler in "Network.GRPC.Server" to forward exceptions in server
+-- handlers to the client.
+--
+-- If no messages have been sent yet, we make use of the @Trailers-Only@ case.
+sendProperTrailers :: Call rpc -> ProperTrailers -> IO ()
+sendProperTrailers Call{callResponseKickoff, callChannel} trailers = do
+    updated <- atomically $ tryPutTMVar callResponseKickoff $
+                 KickoffTrailersOnly (TrailersOnly trailers)
+    unless updated $
+      -- If we didn't update, then the response has already been initiated and
+      -- we cannot make use of the Trailers-Only case.
+      atomically $ Session.send callChannel (NoMoreElems trailers)

src/Network/GRPC/Server/StreamType.hs

@@ -51,7 +51,7 @@ instance StreamingRpcHandler NonStreamingHandler where
 instance StreamingRpcHandler ClientStreamingHandler where
   streamingRpcHandler proxy (UnsafeClientStreamingHandler h) =
     mkRpcHandler proxy $ \call -> do
-      out <- h (liftIO $ recvNextInput call)
+      out <- h (liftIO $ recvInput call)
       liftIO $ sendFinalOutput call (out, def)
 
 instance StreamingRpcHandler ServerStreamingHandler where
@@ -64,7 +64,7 @@ instance StreamingRpcHandler ServerStreamingHandler where
 instance StreamingRpcHandler BiDiStreamingHandler where
   streamingRpcHandler proxy (UnsafeBiDiStreamingHandler h) =
     mkRpcHandler proxy $ \call -> do
-      h (liftIO $ recvNextInput  call)
+      h (liftIO $ recvInput call)
         (liftIO . sendNextOutput call)
       liftIO $ sendTrailers call def
 

src/Network/GRPC/Spec.hs

@@ -8,6 +8,7 @@ module Network.GRPC.Spec (
   , Timeout(..)
   , TimeoutValue(TimeoutValue, getTimeoutValue)
   , TimeoutUnit(..)
+  , timeoutToMicro
     -- * Inputs (message sent to the peer)
   , RequestHeaders(..)
   , IsFinal(..)
@@ -102,6 +103,27 @@ data TimeoutUnit =
   | Nanosecond
   deriving stock (Show, Eq)
 
+-- | Translate 'Timeout' to microseconds
+--
+-- For 'Nanosecond' timeout we round up.
+timeoutToMicro :: Timeout -> Integer
+timeoutToMicro = \case
+    Timeout Hour        (TimeoutValue n) -> mult n $ 1 * 1_000 * 1_000 * 60 * 24
+    Timeout Minute      (TimeoutValue n) -> mult n $ 1 * 1_000 * 1_000 * 60
+    Timeout Second      (TimeoutValue n) -> mult n $ 1 * 1_000 * 1_000
+    Timeout Millisecond (TimeoutValue n) -> mult n $ 1 * 1_000
+    Timeout Microsecond (TimeoutValue n) -> mult n $ 1
+    Timeout Nanosecond  (TimeoutValue n) -> nano n
+  where
+    mult :: Word -> Integer -> Integer
+    mult n m = fromIntegral n * m
+
+    nano :: Word -> Integer
+    nano n = fromIntegral $
+        mu + if n' == 0 then 0 else 1
+      where
+        (mu, n') = divMod n 1_000
+
 {-------------------------------------------------------------------------------
   Inputs (message sent to the peer)
 -------------------------------------------------------------------------------}
@@ -164,14 +186,6 @@ data ProperTrailers = ProperTrailers {
   deriving stock (GHC.Generic)
   deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
 
--- | The 'Default' corresponds to a successful response
-instance Default ProperTrailers where
-  def = ProperTrailers {
-        trailerGrpcStatus  = GrpcOk
-      , trailerGrpcMessage = Nothing
-      , trailerMetadata    = []
-      }
-
 -- | Trailers sent in the gRPC Trailers-Only case
 --
 -- In the current version of the spec, the information in 'TrailersOnly' is