WIP: Infrastructure for gRPC interop test

cabal.project

@@ -2,4 +2,4 @@ packages: .
 
 package grapesy
   tests: True
-  flags: +build-demo +build-stress-test
+  flags: +build-demo +build-stress-test +build-interop

cabal.project.ci

@@ -2,5 +2,5 @@ packages: .
 
 package grapesy
   tests: True
-  flags: +build-demo +build-stress-test
+  flags: +build-demo +build-stress-test +build-interop
   ghc-options: -Werror

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

@@ -28,6 +28,7 @@ handlers :: Methods IO (ProtobufMethodsOf Greeter)
 handlers =
       Method (mkNonStreaming sayHello)
     $ RawMethod sayHelloStreamReply
+    $ UnsupportedMethod -- TODO: sayHelloBidiStream
     $ NoMoreMethods
 
 {-------------------------------------------------------------------------------

dev/disable-ipv6.sh

@@ -0,0 +1,19 @@
+#!/bin/bash
+
+##
+## Disable IPv6 for Docker
+##
+## The gRPC interop tests get confused if IPv6 is enabled: they only expect an
+## IPv4 port to be listed by `docker port`, and throw a parse error when there
+## is also an IPv6 port. Disabling IPv6 in `/etc/docker/daemon.json` instead
+## would be cleaner but does not seem to have the desired effect.
+##
+
+# Disable IPv6 on the host
+sysctl -w net.ipv6.conf.all.disable_ipv6=1
+sysctl -w net.ipv6.conf.default.disable_ipv6=1
+
+# Restart docker
+systemctl restart docker
+
+

genproto.sh → dev/genproto.sh

@@ -14,3 +14,13 @@ do
     --proto_path=${GRPC_REPO}/examples/protos \
     $i.proto
 done
+
+for i in test empty messages
+do
+  protoc \
+    --plugin=protoc-gen-haskell=`which proto-lens-protoc` \
+    --haskell_out=proto \
+    --proto_path=${GRPC_REPO} \
+    src/proto/grpc/testing/$i.proto
+done
+

dev/grapesy-deps-docker/Dockerfile

@@ -0,0 +1,8 @@
+FROM haskell:9.2.8
+RUN mkdir /var/local/git
+RUN git clone https://github.com/well-typed/grapesy.git /var/local/git/grapesy
+WORKDIR /var/local/git/grapesy
+RUN cabal update -w /opt/ghc/9.2.8/bin/ghc
+RUN cabal build -w /opt/ghc/9.2.8/bin/ghc all --only-dependencies
+WORKDIR /
+RUN rm -rf /var/local/git/grapesy

dev/reset-docker.sh

@@ -0,0 +1,15 @@
+#!/bin/bash
+
+##
+## Reset the entire Docker state
+##
+## Don't use this is you are not sure if you might still need any docker
+## images, containers, volumes or networks!
+## 
+
+if [ "$(docker ps -q)" ] 
+then 
+  docker kill $(docker ps -q)
+fi
+
+docker system prune -f --volumes

grapesy.cabal

@@ -386,6 +386,40 @@ executable test-stress
     buildable:
       False
 
+executable grapesy-interop
+  import:
+      lang
+  hs-source-dirs:
+      interop
+      proto
+  main-is:
+      Main.hs
+  other-modules:
+      Interop.Cmdline
+      Interop.Server
+      Interop.TestCase.CacheableUnary
+      Interop.TestCases
+
+      Proto.Src.Proto.Grpc.Testing.Empty
+      Proto.Src.Proto.Grpc.Testing.Messages
+      Proto.Src.Proto.Grpc.Testing.Test
+
+      Paths_grapesy
+  build-depends:
+    , grapesy
+  build-depends:
+    , base
+    , data-default
+    , exceptions
+    , network
+    , optparse-applicative
+    , proto-lens
+    , proto-lens-runtime
+
+  if !flag(build-interop)
+    buildable:
+      False
+
 Flag build-demo
   description: Build the demo
   default: False
@@ -396,7 +430,13 @@ Flag build-stress-test
   default: False
   manual: True
 
+Flag build-interop
+  description: Build the gRPC interop test executable
+  default: False
+  manual: True
+
 Flag crypton
   description: Use the crypton-x509-* package family instead of x509-*
   default: True
   manual: False
+

interop/Interop/Cmdline.hs

@@ -0,0 +1,75 @@
+module Interop.Cmdline (
+    getCmdline
+    -- * Definition
+  , Cmdline(..)
+  , Mode(..)
+  ) where
+
+import Options.Applicative
+import Network.Socket (PortNumber)
+
+{-------------------------------------------------------------------------------
+  Definition
+-------------------------------------------------------------------------------}
+
+data Cmdline = Cmdline {
+      cmdMode   :: Mode
+    , cmdPort   :: PortNumber
+    , cmdUseTLS :: Bool
+    }
+  deriving (Show)
+
+data Mode = Server | Client
+  deriving (Show)
+
+{-------------------------------------------------------------------------------
+  Get command line args
+-------------------------------------------------------------------------------}
+
+getCmdline :: IO Cmdline
+getCmdline = execParser opts
+  where
+    opts :: ParserInfo Cmdline
+    opts =
+        info (parseCmdline <**> helper) $ mconcat [
+            fullDesc
+          , progDesc "Server and client for official gRPC interop tests"
+          ]
+
+{-------------------------------------------------------------------------------
+  Parsers
+-------------------------------------------------------------------------------}
+
+parseCmdline :: Parser Cmdline
+parseCmdline =
+    Cmdline
+      <$> parseMode
+      <*> (option auto $ mconcat [
+              long "port"
+            , help "Port number"
+            ])
+      <*> (option readBool $ mconcat [
+              long "use_tls"
+            , help "Enable TLS"
+            ])
+
+parseMode :: Parser Mode
+parseMode = asum [
+      flag' Server $ mconcat [
+          long "server"
+        , help "Run in server mode"
+        ]
+    , flag' Client $ mconcat [
+          long "client"
+        , help "Run in client mode"
+        ]
+    ]
+
+readBool :: ReadM Bool
+readBool = str >>= aux
+  where
+    aux :: String -> ReadM Bool
+    aux "true"  = return True
+    aux "false" = return False
+    aux x       = fail $ "Could not parse bool " ++ show x
+

interop/Interop/Server.hs

@@ -0,0 +1,78 @@
+module Interop.Server (server) where
+
+import Control.Monad.Catch (generalBracket, ExitCase(..))
+import Data.Default
+
+import Network.GRPC.Common
+import Network.GRPC.Server.Protobuf
+import Network.GRPC.Server.Run
+import Network.GRPC.Server.StreamType
+import Paths_grapesy
+
+import Proto.Src.Proto.Grpc.Testing.Test
+
+import Interop.Cmdline
+import Interop.TestCases
+
+handlers :: Methods IO (ProtobufMethodsOf TestService)
+handlers =
+      Method handleCacheableUnaryCall
+    $ UnsupportedMethod -- emptyCall
+    $ UnsupportedMethod -- fullDuplexCall
+    $ UnsupportedMethod -- halfDuplexCall
+    $ UnsupportedMethod -- streamingInputCall
+    $ UnsupportedMethod -- streamingOutputCall
+    $ UnsupportedMethod -- unaryCall
+    $ UnsupportedMethod -- unimplementedCall
+    $ NoMoreMethods
+
+services :: Services IO (ProtobufServices '[TestService])
+services = Service handlers NoMoreServices
+
+server :: Cmdline -> IO ()
+server cmdline = showStartStop $ do
+    serverConfig <-
+      if cmdUseTLS cmdline then do
+        pubCert <- getDataFileName "grpc-demo.cert"
+        privKey <- getDataFileName "grpc-demo.priv"
+
+        return ServerConfig {
+            serverInsecure = Nothing
+          , serverSecure   = Just SecureConfig {
+                secureHost       = "localhost"
+              , securePort       = cmdPort cmdline
+              , securePubCert    = pubCert
+              , secureChainCerts = []
+              , securePrivKey    = privKey
+              , secureSslKeyLog  = SslKeyLogNone -- TODO: We might want this
+              }
+          }
+      else
+        return ServerConfig {
+            serverSecure   = Nothing
+          , serverInsecure = Just InsecureConfig {
+                insecureHost = Nothing
+              , insecurePort = show $ cmdPort cmdline
+              }
+          }
+
+    runServerWithHandlers
+      serverConfig
+      def
+      (fromServices services)
+
+showStartStop :: forall a. IO a -> IO a
+showStartStop act = fst <$>
+    generalBracket
+      start
+      (\() -> stop)
+      (\() -> act)
+  where
+    start :: IO ()
+    start = putStrLn "grapesy interop server started"
+
+    stop :: ExitCase a -> IO ()
+    stop (ExitCaseSuccess _)   = putStrLn $ "server terminated normally"
+    stop (ExitCaseException e) = putStrLn $ "server exception: " ++ show e
+    stop  ExitCaseAbort        = error "impossible in IO"
+

interop/Interop/TestCase/CacheableUnary.hs

@@ -0,0 +1,20 @@
+module Interop.TestCase.CacheableUnary (
+    handleCacheableUnaryCall
+  ) where
+
+import Data.ProtoLens
+
+import Network.GRPC.Common.StreamType
+import Network.GRPC.Server
+
+import Proto.Src.Proto.Grpc.Testing.Test
+import Proto.Src.Proto.Grpc.Testing.Messages
+
+handleCacheableUnaryCall ::
+     NonStreamingHandler IO (Protobuf TestService "cacheableUnaryCall")
+handleCacheableUnaryCall =
+    mkNonStreaming go
+  where
+    go :: SimpleRequest -> IO SimpleResponse
+    go _ = return defMessage
+

interop/Interop/TestCases.hs

@@ -0,0 +1,12 @@
+-- | Re-export all testcases
+--
+-- The test cases are described in the gRPC documentation at
+-- <https://github.com/grpc/grpc/blob/master/doc/interop-test-descriptions.md>;
+-- the relevant @.proto@ definitions are
+--
+-- * @grpc-repo/src/proto/grpc/testing/test.proto@ (main service definition)
+-- * @grpc-repo/src/proto/grpc/testing/messages.proto@ (most message types)
+-- * @grpc-repo/src/proto/grpc/testing/empty.proto@
+module Interop.TestCases (module X) where
+
+import Interop.TestCase.CacheableUnary as X

interop/Main.hs

@@ -0,0 +1,15 @@
+module Main where
+
+import Interop.Cmdline
+import Interop.Server (server)
+
+{-------------------------------------------------------------------------------
+  Top-level application driver
+-------------------------------------------------------------------------------}
+
+main :: IO ()
+main = do
+    cmdline <- getCmdline
+    case cmdMode cmdline of
+      Server -> server cmdline
+      Client -> fail "client not yet implemented"