Merge pull request #215 from well-typed/edsko/issue-203

Test that compression negotation works

.github/workflows/haskell-ci.yml

@@ -14,8 +14,12 @@
 #
 name: Haskell-CI
 on:
-  - push
-  - pull_request
+  push:
+    branches:
+      - main
+  pull_request:
+    branches:
+      - main
 jobs:
   linux:
     name: Haskell-CI - Linux - ${{ matrix.compiler }}

cabal.haskell-ci

@@ -1,2 +1,3 @@
+branches: main
 copy-fields: all
 apt: libsnappy-dev

grapesy.cabal

@@ -310,6 +310,7 @@ test-suite test-grapesy
       Test.Prop.IncrementalParsing
       Test.Prop.Serialization
       Test.Sanity.BrokenDeployments
+      Test.Sanity.Compression
       Test.Sanity.Disconnect
       Test.Sanity.EndOfStream
       Test.Sanity.Exception
@@ -328,10 +329,12 @@ test-suite test-grapesy
 
       Paths_grapesy
 
+      Proto.API.Helloworld
       Proto.API.Interop
       Proto.API.Ping
       Proto.API.Trivial
       Proto.Empty
+      Proto.Helloworld
       Proto.Messages
       Proto.Ping
       Proto.Test

test-grapesy/Main.hs

@@ -17,6 +17,7 @@ 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.Compression                qualified as Compression
 import Test.Sanity.Disconnect                 qualified as Disconnect
 import Test.Sanity.EndOfStream                qualified as EndOfStream
 import Test.Sanity.Exception                  qualified as Exception
@@ -36,6 +37,7 @@ main = do
                 StreamingType.NonStreaming.tests
               , StreamingType.CustomFormat.tests
               ]
+          , Compression.tests
           , Exception.tests
           , Interop.tests
           , BrokenDeployments.tests

test-grapesy/Test/Sanity/Compression.hs

@@ -0,0 +1,148 @@
+{-# LANGUAGE OverloadedLabels  #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Test.Sanity.Compression (tests) where
+
+import Data.IORef
+import Data.Maybe (isJust)
+import Data.Text (Text)
+import Test.Tasty
+import Test.Tasty.HUnit
+
+import Network.GRPC.Client qualified as Client
+import Network.GRPC.Common
+import Network.GRPC.Common.Protobuf
+import Network.GRPC.Common.StreamElem qualified as StreamElem
+import Network.GRPC.Server qualified as Server
+
+import Test.Driver.ClientServer
+
+import Proto.API.Helloworld
+import Control.Monad
+
+{-------------------------------------------------------------------------------
+  Top-level
+-------------------------------------------------------------------------------}
+
+tests :: TestTree
+tests = testGroup "Test.Sanity.Compression" [
+      testCase "multipleRPC"  test_multipleRPC
+    , testCase "multipleMsgs" test_multipleMsgs
+    ]
+
+{-------------------------------------------------------------------------------
+  Individual tests
+-------------------------------------------------------------------------------}
+
+-- | Test that compression is enabled for the /second/ RPC
+test_multipleRPC :: Assertion
+test_multipleRPC = do
+    counter <- newIORef 0
+    testClientServer $ ClientServerTest {
+        config = def
+      , server = [Server.someRpcHandler $ handleNonStreaming counter]
+      , client = simpleTestClient $ \conn ->
+            replicateM_ 2 $ do
+              Client.withRPC conn def (Proxy @SayHello) $ \call -> do
+                Client.sendFinalInput call req
+                mResp <- StreamElem.value <$> Client.recvOutputWithMeta call
+                case mResp of
+                  Nothing -> assertFailure "Expected response"
+                  Just (meta, resp) -> do
+                    -- /All/ responses from the server should be compressed
+                    -- (the request tells the server what the client supports)
+                    assertEqual "" True $
+                      isJust (inboundCompressedSize meta)
+                    assertEqual "" compressibleName $
+                      resp ^. #message
+    }
+  where
+    req :: Proto HelloRequest
+    req = defMessage & #name .~ compressibleName
+
+-- | Test that multiple messages on /one/ RPC will either all be compressed or
+-- all uncompressed.
+test_multipleMsgs :: Assertion
+test_multipleMsgs = do
+    counter <- newIORef 0
+    testClientServer $ ClientServerTest {
+        config = def
+      , server = [Server.someRpcHandler $ handleBidiStreaming counter]
+      , client = simpleTestClient $ \conn ->
+          replicateM_ 2 $
+            Client.withRPC conn def (Proxy @SayHelloBidiStream) $ \call -> do
+              replicateM_ 2 $ do
+                Client.sendNextInput call req
+                mResp <- StreamElem.value <$> Client.recvOutputWithMeta call
+                case mResp of
+                  Nothing -> assertFailure "Expected response"
+                  Just (meta, resp) -> do
+                    -- /All/ responses from the server should be compressed
+                    -- (the request tells the server what the client supports)
+                    assertEqual "" True $
+                      isJust (inboundCompressedSize meta)
+                    assertEqual "" compressibleName $
+                      resp ^. #message
+              Client.sendEndOfInput call
+      }
+  where
+    req :: Proto HelloRequest
+    req = defMessage & #name .~ compressibleName
+
+{-------------------------------------------------------------------------------
+  Server handlers
+-------------------------------------------------------------------------------}
+
+handleNonStreaming :: IORef Int -> Server.RpcHandler IO SayHello
+handleNonStreaming counter = Server.mkRpcHandler $ \call -> do
+    mElem <- Server.recvInputWithMeta call
+    case mElem of
+      FinalElem (meta, req) NoMetadata -> do
+        callNo <- atomicModifyIORef counter $ \i -> (succ i, i)
+
+        -- We expect all messages to be compressed except the first (the client
+        -- does not yet know which compression algorithms the server supports)
+        let expectCompression :: Bool
+            expectCompression = callNo > 0
+        assertEqual "" expectCompression $
+          isJust (inboundCompressedSize meta)
+
+        Server.sendFinalOutput call (
+            defMessage & #message .~ (req ^. #name)
+          , NoMetadata
+          )
+      _otherwise ->
+        assertFailure "expected FinalElem"
+
+handleBidiStreaming :: IORef Int -> Server.RpcHandler IO SayHelloBidiStream
+handleBidiStreaming counter = Server.mkRpcHandler $ \call -> do
+    isFirstCall <- atomicModifyIORef counter $ \i -> (succ i, i == 0)
+
+    let loop :: IO ()
+        loop = do
+          mElem <- Server.recvInputWithMeta call
+          case mElem of
+            NoMoreElems NoMetadata ->
+              Server.sendTrailers call NoMetadata
+            StreamElem (meta, req) -> do
+              -- The compression algorithm is established once at the start of
+              -- the request; we cannot start compression halfway a conversation
+              let expectCompression :: Bool
+                  expectCompression = not isFirstCall
+              assertEqual "" expectCompression $
+                isJust (inboundCompressedSize meta)
+
+              Server.sendNextOutput call $
+                defMessage & #message .~ (req ^. #name)
+              loop
+            FinalElem{} ->
+              assertFailure "Unexpected FinalElem"
+
+    loop
+
+{-------------------------------------------------------------------------------
+  Auxiliary
+-------------------------------------------------------------------------------}
+
+compressibleName :: Text
+compressibleName = mconcat (replicate 100 "John")

test-grapesy/Test/Sanity/EndOfStream.hs

@@ -44,25 +44,25 @@ tests = testGroup "Test.Sanity.EndOfStream" [
 -- | Test that we get SendAfterFinal when we call 'sendInput' after the final
 test_sendAfterFinal :: Assertion
 test_sendAfterFinal = testClientServer $ ClientServerTest {
-        config = def
-      , server = [Server.fromMethod clientStreamingHandler]
-      , client = simpleTestClient $ \conn -> do
-          Client.withRPC conn def (Proxy @Absorb) $ \call -> do
-            replicateM_ 10 $ Client.sendNextInput call BS.Lazy.empty
-            Client.sendEndOfInput call
-
-            -- The purpose of this test:
-            mRes <- try $ Client.sendNextInput call BS.Lazy.empty
-            case mRes of
-              Left SendAfterFinal{} ->
-                return ()
-              _otherwise ->
-                assertFailure "Expected SendAfterFinal"
-
-            -- Communication with the server is unaffected
-            (res, _) <- Client.recvFinalOutput call
-            assertEqual "response" BS.Lazy.empty $ res
-      }
+      config = def
+    , server = [Server.fromMethod clientStreamingHandler]
+    , client = simpleTestClient $ \conn -> do
+        Client.withRPC conn def (Proxy @Absorb) $ \call -> do
+          replicateM_ 10 $ Client.sendNextInput call BS.Lazy.empty
+          Client.sendEndOfInput call
+
+          -- The purpose of this test:
+          mRes <- try $ Client.sendNextInput call BS.Lazy.empty
+          case mRes of
+            Left SendAfterFinal{} ->
+              return ()
+            _otherwise ->
+              assertFailure "Expected SendAfterFinal"
+
+          -- Communication with the server is unaffected
+          (res, _) <- Client.recvFinalOutput call
+          assertEqual "response" BS.Lazy.empty $ res
+    }
 
 -- | Test that we get RecvAfterFinal if we call 'recvOutput' after the final
 test_recvAfterFinal :: Assertion