Merge pull request #235 from well-typed/edsko/serialize-outputs

    Check that messages are well-formed before enqueueing

grapesy/grapesy.cabal

@@ -351,6 +351,7 @@ test-suite test-grapesy
     , bytestring                  >= 0.10  && < 0.13
     , case-insensitive            >= 1.2   && < 1.3
     , containers                  >= 0.6   && < 0.8
+    , deepseq                     >= 1.4   && < 1.6
     , exceptions                  >= 0.10  && < 0.11
     , http-types                  >= 0.12  && < 0.13
     , http2                       >= 5.3.4 && < 5.4
@@ -636,6 +637,7 @@ benchmark grapesy-kvstore
     , base64-bytestring    >= 1.2  && < 1.3
     , bytestring           >= 0.10 && < 0.13
     , containers           >= 0.6  && < 0.8
+    , deepseq              >= 1.4  && < 1.6
     , hashable             >= 1.3  && < 1.5
     , optparse-applicative >= 0.16 && < 0.19
     , proto-lens-runtime   >= 0.7  && < 0.8

grapesy/kvstore/KVStore/API.hs

@@ -8,6 +8,7 @@ module KVStore.API (
   , KVStore(..)
   ) where
 
+import Control.DeepSeq (NFData)
 import Control.Monad
 import Data.Aeson.Types qualified as Aeson
 import Data.ByteString (ByteString)
@@ -25,13 +26,14 @@ newtype Key = Key {
        getKey :: ByteString
      }
   deriving stock (Show, Eq, Ord)
-  deriving newtype (Hashable)
+  deriving newtype (Hashable, NFData)
   deriving (ToJSON, FromJSON) via Base64
 
 newtype Value = Value {
       getValue :: ByteString
     }
   deriving stock (Show, Eq, Ord)
+  deriving newtype (NFData)
   deriving (ToJSON, FromJSON) via Base64
 
 {-------------------------------------------------------------------------------

grapesy/src/Network/GRPC/Common/NextElem.hs

@@ -26,7 +26,7 @@ import Network.GRPC.Common.StreamElem (StreamElem(..))
 -- | Is there a next element in a stream?
 --
 -- Does not record metadata, unlike 'Network.GRPC.Common.StreamElem.StreamElem'.
-data NextElem a = NoNextElem | NextElem a
+data NextElem a = NoNextElem | NextElem !a
   deriving stock (Show, Eq, Functor, Foldable, Traversable)
 
 {-------------------------------------------------------------------------------

grapesy/src/Network/GRPC/Common/StreamElem.hs

@@ -45,12 +45,12 @@ data StreamElem b a =
     --
     --   In this case, this element is /not/ final (and the final element, when
     --   we receive it, will be tagged as 'Final').
-    StreamElem a
+    StreamElem !a
 
     -- | We received the final element
     --
     -- The final element is annotated with some additional information.
-  | FinalElem a b
+  | FinalElem !a !b
 
     -- | There are no more elements
     --
@@ -59,7 +59,7 @@ data StreamElem b a =
     -- * The stream didn't contain any elements at all.
     -- * The final element was not marked as final.
     --   See 'StreamElem' for detailed additional discussion.
-  | NoMoreElems b
+  | NoMoreElems !b
   deriving stock (Show, Eq, Functor, Foldable, Traversable)
 
 instance Bifunctor StreamElem where

grapesy/src/Network/GRPC/Server/StreamType.hs

@@ -288,6 +288,14 @@ data Services m (servs :: [[k]]) where
 --
 -- > Server.fromMethod @EmptyCall $ ServerHandler $ \(_ ::Empty) ->
 -- >   return (defMessage :: Empty)
+--
+-- If the streaming type cannot be deduced, you might need to specify that also:
+--
+-- > Server.fromMethod @Ping @NonStreaming $ ServerHandler $ ..
+--
+-- Alternatively, use one of the handler construction functions, such as
+--
+-- > Server.fromMethod @Ping $ Server.mkNonStreaming $ ..
 fromMethod :: forall rpc styp m.
      ( SupportsServerRpc rpc
      , ValidStreamingType styp

grapesy/src/Network/GRPC/Spec/MessageMeta.hs

@@ -4,8 +4,10 @@ module Network.GRPC.Spec.MessageMeta (
   , InboundMeta(..)
   ) where
 
+import Control.DeepSeq (NFData)
 import Data.Default
 import Data.Word
+import GHC.Generics (Generic)
 
 {-------------------------------------------------------------------------------
   Outbound messages
@@ -18,7 +20,8 @@ data OutboundMeta = OutboundMeta {
       -- smaller message.
       outboundEnableCompression :: Bool
     }
-  deriving stock (Show)
+  deriving stock (Show, Generic)
+  deriving anyclass (NFData)
 
 instance Default OutboundMeta where
   def = OutboundMeta {

grapesy/src/Network/GRPC/Spec/RPC.hs

@@ -9,6 +9,7 @@ module Network.GRPC.Spec.RPC (
   , defaultRpcContentType
   ) where
 
+import Control.DeepSeq (NFData)
 import Data.ByteString qualified as Strict (ByteString)
 import Data.ByteString.Lazy qualified as Lazy
 import Data.Kind
@@ -36,13 +37,22 @@ type family Output (rpc :: k) :: Type
 -- We therefore punt on the encoding issue here, and use bytestrings. /If/
 -- applications want to use non-ASCII characters, they can choose their own
 -- encoding.
-class ( -- Debug constraints
+class ( -- Serialization
+        --
+        -- We force messages to NF before enqueueing them. This ensures that
+        -- if those messages contain any pure exceptions (due to a bug in a
+        -- client or a server), we detect the problem when the message is
+        -- enqueued, and can throw an appropriate exception.
+        NFData (Input rpc)
+      , NFData (Output rpc)
+
+        -- Debug constraints
         --
         -- For debugging it is useful when we have 'Show' instances in scope.
         -- This is not that strong a requirement; after all, we must be able
         -- to serialize inputs and deserialize outputs, so they must also be
         -- 'Show'able.
-        Show (Input rpc)
+      , Show (Input rpc)
       , Show (Output rpc)
       , Show (RequestMetadata rpc)
       , Show (ResponseInitialMetadata rpc)

grapesy/src/Network/GRPC/Spec/RPC/JSON.hs

@@ -9,6 +9,7 @@ module Network.GRPC.Spec.RPC.JSON (
   , Optional(..)
   ) where
 
+import Control.DeepSeq (NFData(..))
 import Data.Aeson (ToJSON(..), FromJSON(..), (.=), (.:), (.:?))
 import Data.Aeson qualified as Aeson
 import Data.Aeson.Types qualified as Aeson
@@ -59,6 +60,10 @@ data JsonRpc (serv :: Symbol) (meth :: Symbol)
 instance ( KnownSymbol serv
          , KnownSymbol meth
 
+           -- Serialization
+         , NFData (Input  (JsonRpc serv meth))
+         , NFData (Output (JsonRpc serv meth))
+
            -- Debugging constraints
          , Show (Input  (JsonRpc serv meth))
          , Show (Output (JsonRpc serv meth))
@@ -129,19 +134,28 @@ instance (Show x, Show (JsonObject fs))
       . showString " :* "
       . showsPrec 6 xs
 
+instance NFData (JsonObject '[]) where
+  rnf JsonObject = ()
+
+instance (NFData x, NFData (JsonObject fs))
+      => NFData (JsonObject ('(f, x) : fs)) where
+  rnf (x :* xs) = rnf (x, xs)
+
 -- | Required field
 newtype Required a = Required {
      getRequired :: a
    }
- deriving (Show)
+ deriving stock (Show)
+ deriving newtype (NFData)
 
 -- | Optional field
 --
 -- 'Maybe' will be represented by the /absence/ of the field in the object.
 newtype Optional a = Optional {
       getOptional :: Maybe a
     }
-  deriving (Show)
+ deriving stock (Show)
+ deriving newtype (NFData)
 
 infixr 5 :*
 

grapesy/src/Network/GRPC/Spec/RPC/Protobuf.hs

@@ -9,6 +9,7 @@ module Network.GRPC.Spec.RPC.Protobuf (
   , getProto
   ) where
 
+import Control.DeepSeq (NFData)
 import Control.Lens hiding (lens)
 import Data.ByteString qualified as Strict (ByteString)
 import Data.ByteString.Char8 qualified as BS.Char8
@@ -51,9 +52,15 @@ type instance Input  (Protobuf serv meth) = Proto (MethodInput  serv meth)
 type instance Output (Protobuf serv meth) = Proto (MethodOutput serv meth)
 
 instance ( HasMethodImpl      serv meth
+
+           -- Debugging
          , Show (MethodInput  serv meth)
          , Show (MethodOutput serv meth)
 
+           -- Serialization
+         , NFData (MethodInput  serv meth)
+         , NFData (MethodOutput serv meth)
+
            -- Metadata constraints
          , Show (RequestMetadata (Protobuf serv meth))
          , Show (ResponseInitialMetadata (Protobuf serv meth))
@@ -144,6 +151,7 @@ newtype Proto msg = Proto msg
     , Enum
     , FieldDefault
     , MessageEnum
+    , NFData
     )
 
 -- | Field accessor for 'Proto'

grapesy/test-grapesy/Test/Sanity/BrokenDeployments.hs

@@ -1,19 +1,26 @@
 -- Intentionally /NOT/ enabling OverloadedStrings.
 -- This forces us to be precise about encoding issues.
 
+{-# LANGUAGE OverloadedLabels #-}
+
 module Test.Sanity.BrokenDeployments (tests) where
 
 import Control.Exception
 import Data.ByteString.Char8 qualified as BS.Strict.Char8
 import Data.ByteString.UTF8 qualified as BS.Strict.UTF8
+import Data.IORef
 import Data.Text qualified as Text
 import Network.HTTP.Types qualified as HTTP
 import Test.Tasty
 import Test.Tasty.HUnit
 
 import Network.GRPC.Client qualified as Client
+import Network.GRPC.Client.StreamType.IO qualified as Client
 import Network.GRPC.Common
 import Network.GRPC.Common.Protobuf
+import Network.GRPC.Server.StreamType qualified as Server
+
+import Test.Driver.ClientServer
 import Test.Util.RawTestServer
 
 import Proto.API.Ping
@@ -44,6 +51,9 @@ tests = testGroup "Test.Sanity.BrokenDeployments" [
         , testCase "requestMetadata" test_invalidRequestMetadata
         , testCase "trailerMetadata" test_invalidTrailerMetadata
         ]
+    , testGroup "Undefined" [
+          testCase "output" test_undefinedOutput
+        ]
     ]
 
 connParams :: Client.ConnParams
@@ -324,3 +334,48 @@ grpcMessageContains GrpcException{grpcErrorMessage} str =
     case grpcErrorMessage of
       Just msg -> Text.pack str `Text.isInfixOf` msg
       Nothing  -> False
+
+{-------------------------------------------------------------------------------
+  Undefined values
+-------------------------------------------------------------------------------}
+
+test_undefinedOutput :: Assertion
+test_undefinedOutput = do
+    st <- newIORef 0
+    testClientServer $ ClientServerTest {
+        config = def
+      , server = [Server.fromMethod @Ping $ Server.mkNonStreaming (handler st)]
+      , client = simpleTestClient $ \conn -> do
+
+          -- The first time the handler is invoked, it attempts to enqueue a
+          -- an undefined message (one containing a pure exception). Prior to
+          -- #235 this would result in undefined behaviour, probably the server
+          -- disconnecting. What should happen instead is that this exception
+          -- is thrown in the handler, caught, sent to the client as a
+          -- 'GrpcException', and re-raised in the client.
+          mResp1 :: Either GrpcException (Proto PongMessage) <- try $
+            Client.nonStreaming conn (Client.rpc @Ping) (defMessage & #id .~ 1)
+          case mResp1 of
+            Left err | Just msg <- grpcErrorMessage err ->
+              assertBool "" $ Text.pack "uhoh" `Text.isInfixOf` msg
+            _otherwise ->
+              assertFailure "Unexpected response"
+
+          -- Meanwhile, the server should just continue running; the /second/
+          -- invocation of the handler should succeed normally.
+          mResp2 :: Either GrpcException (Proto PongMessage) <- try $
+            Client.nonStreaming conn (Client.rpc @Ping) (defMessage & #id .~ 2)
+          case mResp2 of
+            Right resp ->
+              assertEqual "" 2 $ resp ^. #id
+            _otherwise ->
+              assertFailure "Unexpected response"
+      }
+  where
+    -- Server handler attempts to enqueue an undefined message
+    handler :: IORef Int -> Proto PingMessage -> IO (Proto PongMessage)
+    handler st req = do
+        isFirst <- atomicModifyIORef st $ \i -> (succ i, i == 0)
+        if isFirst
+          then return $ throw $ DeliberateException (userError "uhoh")
+          else return $ defMessage & #id .~ req ^. #id

grapesy/test-grapesy/Test/Sanity/StreamingType/CustomFormat.hs

@@ -4,6 +4,7 @@ module Test.Sanity.StreamingType.CustomFormat (tests) where
 
 import Codec.Serialise qualified as Cbor
 import Control.Concurrent.Async (concurrently)
+import Control.DeepSeq (NFData)
 import Data.Bifunctor
 import Data.ByteString qualified as Strict (ByteString)
 import Data.Kind
@@ -59,6 +60,8 @@ data Function =
 class ( Typeable fun
       , Show (CalcInput  fun)
       , Show (CalcOutput fun)
+      , NFData (CalcInput  fun)
+      , NFData (CalcOutput fun)
       , Cbor.Serialise (CalcInput  fun)
       , Cbor.Serialise (CalcOutput fun)
       ) => CalculatorFunction (fun :: Function) where

grapesy/test-stress/Test/Stress/Driver.hs

@@ -236,31 +236,31 @@ servers = [
         , componentPort   = 50000
         , componentSecure = False
         , componentStable = False
-        , componentLimit  = Just 60
+        , componentLimit  = Just 400
         , componentName   = "server-unstable-insecure"
         }
     , Component {
           componentType   = Server
         , componentPort   = 50001
         , componentSecure = True
         , componentStable = False
-        , componentLimit  = Just 100
+        , componentLimit  = Just 400
         , componentName   = "server-unstable-secure"
         }
     , Component {
           componentType   = Server
         , componentPort   = 50002
         , componentSecure = False
         , componentStable = True
-        , componentLimit  = Just 60
+        , componentLimit  = Just 400
         , componentName   = "server-stable-insecure"
         }
     , Component {
           componentType   = Server
         , componentPort   = 50003
         , componentSecure = True
         , componentStable = True
-        , componentLimit  = Just 100
+        , componentLimit  = Just 400
         , componentName   = "server-stable-secure"
         }
     ]