Update echo client/server to use CG and high-level interfaces (#88)

* echo client/server example: dead code removal, add command line params, improve output messages

* Add nix-build result to .gitignore

* Merge echo-client and echo-server directories to echo-hs/ directory; rename main modules accordingly

* Use our protobuf compiler to generate bindings for the Echo service

* Simplify echo.proto to just one endpoint; use highlevel client/server interfaces and codegen for echo example

* Remove repetition counts and thread spawns from echo client, parameterize payload

* Update default.nix

.gitignore

@@ -6,3 +6,5 @@ dist
 examples/echo/echo-cpp/echo-client
 examples/echo/echo-cpp/echo-server
 benchmarks.html
+result
+

default.nix

@@ -20,6 +20,7 @@ mkDerivation {
   executableHaskellDepends = [
     async base bytestring containers optparse-generic proto3-wire
     protobuf-wire random system-filepath text transformers turtle
+    vector
   ];
   testHaskellDepends = [
     async base bytestring clock containers managed pipes protobuf-wire

examples/echo/echo-client/Main.hs

@@ -1,76 +0,0 @@
-{-# LANGUAGE DeriveGeneric     #-}
-{-# LANGUAGE LambdaCase        #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE OverloadedLists   #-}
-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
-{-# OPTIONS_GHC -fno-warn-unused-binds       #-}
-
-import           Control.Concurrent.Async
-import           Control.Monad
-import qualified Data.ByteString.Lazy                      as BL
-import           Data.Protobuf.Wire.Class
-import           Data.Protobuf.Wire.Types
-import qualified Data.Text                                 as T
-import           Data.Word
-import           GHC.Generics                              (Generic)
-import           Network.GRPC.LowLevel
-import qualified Network.GRPC.LowLevel.Client.Unregistered as U
-import           System.Random                             (randomRIO)
-
-echoMethod = MethodName "/echo.Echo/DoEcho"
-addMethod = MethodName "/echo.Add/DoAdd"
-
-_unregistered c = U.clientRequest c echoMethod 1 "hi" mempty
-
-regMain = withGRPC $ \g ->
-  withClient g (ClientConfig "localhost" 50051 [] Nothing) $ \c -> do
-  rm <- clientRegisterMethodNormal c echoMethod
-  replicateM_ 100000 $ clientRequest c rm 5 "hi" mempty >>= \case
-    Left e -> fail $ "Got client error: " ++ show e
-    Right r
-      | rspBody r == "hi" -> return ()
-      | otherwise -> fail $ "Got unexpected payload: " ++ show r
-
--- NB: If you change these, make sure to change them in the server as well.
--- TODO: Put these in a common location (or just hack around it until CG is working)
-data EchoRequest = EchoRequest {message :: T.Text} deriving (Show, Eq, Ord, Generic)
-instance Message EchoRequest
-data AddRequest = AddRequest {addX :: Fixed Word32, addY :: Fixed Word32} deriving (Show, Eq, Ord, Generic)
-instance Message AddRequest
-data AddResponse = AddResponse {answer :: Fixed Word32} deriving (Show, Eq, Ord, Generic)
-instance Message AddResponse
-
--- TODO: Create Network.GRPC.HighLevel.Client w/ request variants
-
-highlevelMain = withGRPC $ \g ->
-    withClient g (ClientConfig "localhost" 50051 [] Nothing) $ \c -> do
-    rm <- clientRegisterMethodNormal c echoMethod
-    rmAdd <- clientRegisterMethodNormal c addMethod
-    let oneThread = replicateM_ 10000 $ body c rm rmAdd
-    tids <- replicateM 4 (async oneThread)
-    results <- mapM waitCatch tids
-    print $ "waitCatch results: " ++ show (sequence results)
-      where body c rm rmAdd = do
-              let pay = EchoRequest "hi"
-                  enc = BL.toStrict . toLazyByteString $ pay
-              clientRequest c rm 5 enc mempty >>= \case
-                Left e  -> fail $ "Got client error: " ++ show e
-                Right r -> case fromByteString (rspBody r) of
-                  Left e -> fail $ "Got decoding error: " ++ show e
-                  Right dec
-                    | dec == pay -> return ()
-                    | otherwise -> fail $ "Got unexpected payload: " ++ show dec
-              x <- liftM Fixed $ randomRIO (0,1000)
-              y <- liftM Fixed $ randomRIO (0,1000)
-              let addPay = AddRequest x y
-                  addEnc = BL.toStrict . toLazyByteString $ addPay
-              clientRequest c rmAdd 5 addEnc mempty >>= \case
-                Left e -> fail $ "Got client error on add request: " ++ show e
-                Right r -> case fromByteString (rspBody r) of
-                  Left e -> fail $ "failed to decode add response: " ++ show e
-                  Right dec
-                    | dec == AddResponse (x + y) -> return ()
-                    | otherwise -> fail $ "Got wrong add answer: " ++ show dec ++ "expected: " ++ show x ++ " + " ++ show y ++ " = " ++ show (x+y)
-
-main :: IO ()
-main = highlevelMain

examples/echo/echo-cpp/Makefile

@@ -3,8 +3,14 @@ CXXFLAGS += -std=c++11
 CPPFLAGS += -I/usr/local/include -pthread
 LDFLAGS += -L/usr/local/lib -lgrpc++_unsecure -lgrpc -lprotobuf -lpthread -ldl
 
+.phony: all
+all:
+	@echo "TODO: Update this code to use the new echo.proto"
+	@exit 1
+
 echo-server: echo.pb.o echo.grpc.pb.o echo-server.o
 	clang++ $^ $(LDFLAGS) -o $@
 
 echo-client: echo.pb.o echo.grpc.pb.o echo-client.o
 	clang++ $^ $(LDFLAGS) -o $@
+

examples/echo/echo-hs/Echo.hs

@@ -0,0 +1,105 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedStrings #-}
+-- | Generated by Haskell protocol buffer compiler. DO NOT EDIT!
+module Echo where
+import qualified Prelude as Hs
+import qualified Data.Protobuf.Wire.DotProto as HsProtobuf
+import qualified Data.Protobuf.Wire.Types as HsProtobuf
+import qualified Data.Protobuf.Wire.Class as HsProtobuf
+import qualified Proto3.Wire as HsProtobuf
+import Control.Applicative ((<*>), (<|>))
+import qualified Data.Text as Hs (Text)
+import qualified Data.ByteString as Hs
+import qualified Data.String as Hs (fromString)
+import qualified Data.Vector as Hs (Vector)
+import qualified Data.Int as Hs (Int16, Int32, Int64)
+import qualified Data.Word as Hs (Word16, Word32, Word64)
+import GHC.Generics as Hs
+import GHC.Enum as Hs
+import Network.GRPC.HighLevel.Generated as HsGRPC
+import Network.GRPC.HighLevel.Client as HsGRPC
+import Network.GRPC.HighLevel.Server as HsGRPC hiding (serverLoop)
+import Network.GRPC.HighLevel.Server.Unregistered as HsGRPC
+       (serverLoop)
+import Network.GRPC.LowLevel.Call as HsGRPC
+ 
+data Echo request response = Echo{echoDoEcho ::
+                                  request 'HsGRPC.Normal EchoRequest EchoResponse ->
+                                    Hs.IO (response 'HsGRPC.Normal EchoResponse)}
+                           deriving Hs.Generic
+ 
+echoServer ::
+             Echo HsGRPC.ServerRequest HsGRPC.ServerResponse ->
+               HsGRPC.ServiceOptions -> Hs.IO ()
+echoServer Echo{echoDoEcho = echoDoEcho}
+  (ServiceOptions serverHost serverPort useCompression
+     userAgentPrefix userAgentSuffix initialMetadata sslConfig logger)
+  = (HsGRPC.serverLoop
+       HsGRPC.defaultOptions{HsGRPC.optNormalHandlers =
+                               [(HsGRPC.UnaryHandler (HsGRPC.MethodName "/echo.Echo/DoEcho")
+                                   (HsGRPC.convertGeneratedServerHandler echoDoEcho))],
+                             HsGRPC.optClientStreamHandlers = [],
+                             HsGRPC.optServerStreamHandlers = [],
+                             HsGRPC.optBiDiStreamHandlers = [], optServerHost = serverHost,
+                             optServerPort = serverPort, optUseCompression = useCompression,
+                             optUserAgentPrefix = userAgentPrefix,
+                             optUserAgentSuffix = userAgentSuffix,
+                             optInitialMetadata = initialMetadata, optSSLConfig = sslConfig,
+                             optLogger = logger})
+ 
+echoClient ::
+             HsGRPC.Client ->
+               Hs.IO (Echo HsGRPC.ClientRequest HsGRPC.ClientResult)
+echoClient client
+  = (Hs.pure Echo) <*>
+      ((Hs.pure (HsGRPC.clientRequest client)) <*>
+         (HsGRPC.clientRegisterMethod client
+            (HsGRPC.MethodName "/echo.Echo/DoEcho")))
+ 
+data EchoRequest = EchoRequest{echoRequestMessage :: Hs.Text}
+                 deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)
+ 
+instance HsProtobuf.Named EchoRequest where
+        nameOf _ = (Hs.fromString "EchoRequest")
+ 
+instance HsProtobuf.Message EchoRequest where
+        encodeMessage _
+          EchoRequest{echoRequestMessage = echoRequestMessage}
+          = (Hs.mconcat
+               [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)
+                   echoRequestMessage)])
+        decodeMessage _
+          = (Hs.pure EchoRequest) <*>
+              (HsProtobuf.at HsProtobuf.decodeMessageField
+                 (HsProtobuf.FieldNumber 1))
+        dotProto _
+          = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)
+                (HsProtobuf.Prim HsProtobuf.String)
+                (HsProtobuf.Single "message")
+                []
+                Hs.Nothing)]
+ 
+data EchoResponse = EchoResponse{echoResponseMessage :: Hs.Text}
+                  deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)
+ 
+instance HsProtobuf.Named EchoResponse where
+        nameOf _ = (Hs.fromString "EchoResponse")
+ 
+instance HsProtobuf.Message EchoResponse where
+        encodeMessage _
+          EchoResponse{echoResponseMessage = echoResponseMessage}
+          = (Hs.mconcat
+               [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)
+                   echoResponseMessage)])
+        decodeMessage _
+          = (Hs.pure EchoResponse) <*>
+              (HsProtobuf.at HsProtobuf.decodeMessageField
+                 (HsProtobuf.FieldNumber 1))
+        dotProto _
+          = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)
+                (HsProtobuf.Prim HsProtobuf.String)
+                (HsProtobuf.Single "message")
+                []
+                Hs.Nothing)]

examples/echo/echo-hs/EchoClient.hs

@@ -0,0 +1,48 @@
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE GADTs             #-}
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedLists   #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE TypeOperators     #-}
+
+import           Control.Monad
+import           Data.ByteString                  (ByteString)
+import           Data.Maybe                       (fromMaybe)
+import           GHC.Generics                     (Generic)
+import           Network.GRPC.HighLevel.Client
+import           Network.GRPC.HighLevel.Generated
+import           Network.GRPC.LowLevel
+import           Options.Generic
+import           Prelude                          hiding (FilePath)
+
+import           Echo
+
+data Args = Args
+  { bind       :: Maybe ByteString <?> "grpc endpoint hostname (default \"localhost\")"
+  , port       :: Maybe Int        <?> "grpc endpoint port (default 50051)"
+  , payload    :: Maybe Text       <?> "string to echo (default \"hullo!\")"
+  } deriving (Generic, Show)
+instance ParseRecord Args
+
+main :: IO ()
+main = do
+  Args{..} <- getRecord "Runs the echo client"
+  let
+    pay      = fromMaybe "hullo!" . unHelpful $ payload
+    rqt      = EchoRequest pay
+    expected = EchoResponse pay
+    cfg      = ClientConfig
+                 (Host . fromMaybe "localhost" . unHelpful $ bind)
+                 (Port . fromMaybe 50051       . unHelpful $ port)
+                 [] Nothing
+  withGRPC $ \g -> withClient g cfg $ \c -> do
+    Echo{..} <- echoClient c
+    echoDoEcho (ClientNormalRequest rqt 5 mempty) >>= \case
+      ClientNormalResponse rsp _ _ StatusOk _
+        | rsp == expected             -> return ()
+        | otherwise                   -> fail $ "Got unexpected response: '" ++ show rsp ++ "', expected: '" ++ show expected ++ "'"
+      ClientNormalResponse _ _ _ st _ -> fail $ "Got unexpected status " ++ show st ++ " from call, expecting StatusOk"
+      ClientError e                   -> fail $ "Got client error: " ++ show e
+  putStrLn $ "echo-client success: sent " ++ show pay ++ ", got " ++ show pay

examples/echo/echo-hs/EchoServer.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE GADTs             #-}
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedLists   #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE TypeOperators     #-}
+
+import           Data.ByteString                  (ByteString)
+import           Data.Maybe                       (fromMaybe)
+import           GHC.Generics                     (Generic)
+import           Network.GRPC.HighLevel.Generated (GRPCMethodType (..),
+                                                   Host (..), Port (..),
+                                                   ServerRequest (..),
+                                                   ServerResponse (..),
+                                                   StatusCode (..),
+                                                   defaultServiceOptions,
+                                                   serverHost, serverPort)
+import           Options.Generic
+
+import           Echo
+
+data Args = Args
+  { bind :: Maybe ByteString <?> "grpc endpoint hostname (default \"localhost\")"
+  , port :: Maybe Int        <?> "grpc endpoint port (default 50051)"
+  } deriving (Generic, Show)
+instance ParseRecord Args
+
+doEcho :: ServerRequest 'Normal EchoRequest EchoResponse
+       -> IO (ServerResponse 'Normal EchoResponse)
+doEcho (ServerNormalRequest _meta (EchoRequest pay)) = do
+  return (ServerNormalResponse (EchoResponse pay) mempty StatusOk "")
+
+main :: IO ()
+main = do
+  Args{..} <- getRecord "Runs the echo service"
+  let opts = defaultServiceOptions
+             { serverHost = Host . fromMaybe "localhost" . unHelpful $ bind
+             , serverPort = Port . fromMaybe 50051       . unHelpful $ port
+             }
+  echoServer Echo{ echoDoEcho = doEcho } opts

examples/echo/echo-hs/Makefile

@@ -0,0 +1,4 @@
+
+Echo.hs: ../echo.proto
+	stack exec -- compile-proto-file --proto ../echo.proto > Echo.hs
+

examples/echo/echo-server/Main.hs

@@ -1,127 +0,0 @@
-{-# LANGUAGE DataKinds         #-}
-{-# LANGUAGE DeriveGeneric     #-}
-{-# LANGUAGE OverloadedLists   #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards   #-}
-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
-{-# OPTIONS_GHC -fno-warn-unused-binds       #-}
-
-import           Control.Concurrent
-import           Control.Concurrent.Async
-import           Control.Monad
-import           Data.ByteString                           (ByteString)
-import           Data.Protobuf.Wire.Class
-import           Data.Protobuf.Wire.Types
-import qualified Data.Text                                 as T
-import           Data.Word
-import           GHC.Generics                              (Generic)
-import           Network.GRPC.HighLevel.Server
-import qualified Network.GRPC.HighLevel.Server.Unregistered as U
-import           Network.GRPC.LowLevel
-import qualified Network.GRPC.LowLevel.Call.Unregistered   as U
-import qualified Network.GRPC.LowLevel.Server.Unregistered as U
-import           Network.GRPC.Unsafe.Security as U
-
-serverMeta :: MetadataMap
-serverMeta = [("test_meta", "test_meta_value")]
-
-handler :: U.ServerCall
-           -> ByteString
-           -> IO (ByteString, MetadataMap, StatusCode, StatusDetails)
-handler U.ServerCall{..} reqBody = do
-  --putStrLn $ "Got request for method: " ++ show method
-  --putStrLn $ "Got metadata: " ++ show reqMeta
-  return (reqBody, serverMeta, StatusOk, StatusDetails "")
-
-unregMain :: IO ()
-unregMain = withGRPC $ \grpc -> do
-  withServer grpc defConfig $ \server -> forever $ do
-    result <- U.serverHandleNormalCall server serverMeta handler
-    case result of
-      Left x -> putStrLn $ "handle call result error: " ++ show x
-      Right _ -> return ()
-
-regMain :: IO ()
-regMain = withGRPC $ \grpc -> do
-  let ms = [(MethodName "/echo.Echo/DoEcho")]
-  withServer grpc (defConfig {methodsToRegisterNormal = ms}) $ \server ->
-    forever $ do
-      let method = head (normalMethods server)
-      result <- serverHandleNormalCall server method serverMeta $
-        \call -> return (payload call, serverMeta, StatusOk, StatusDetails "")
-      case result of
-        Left x -> putStrLn $ "registered call result error: " ++ show x
-        Right _ -> return ()
-
-tputStrLn x = do
-  tid <- myThreadId
-  putStrLn $ "[" ++ show tid ++ "]: " ++ x
-
-regLoop :: Server -> RegisteredMethod 'Normal -> IO ()
-regLoop server method = forever $ do
---  tputStrLn "about to block on call handler"
-  result <- serverHandleNormalCall server method serverMeta $
-    \call ->
-      return (payload call, serverMeta, StatusOk, StatusDetails "")
-  case result of
-    Left x -> error $! "registered call result error: " ++ show x
-    Right _ -> return ()
-
-regMainThreaded :: IO ()
-regMainThreaded = do
-  withGRPC $ \grpc -> do
-    let ms = [(MethodName "/echo.Echo/DoEcho")]
-    withServer grpc (defConfig {methodsToRegisterNormal = ms}) $ \server -> do
-      let method = head (normalMethods server)
-      tids <- replicateM 7 $ async $ do tputStrLn "starting handler"
-                                        regLoop server method
-      _ <- waitAnyCancel tids
-      tputStrLn "finishing"
-
--- NB: If you change these, make sure to change them in the client as well.
--- TODO: Put these in a common location (or just hack around it until CG is working)
-data EchoRequest = EchoRequest {message :: T.Text} deriving (Show, Eq, Ord, Generic)
-instance Message EchoRequest
-
-echoHandler :: Handler 'Normal
-echoHandler =
-        UnaryHandler "/echo.Echo/DoEcho" $
-          \call -> do
-            return ( payload call :: EchoRequest
-                   , metadata call
-                   , StatusOk
-                   , StatusDetails ""
-                   )
-
-data AddRequest = AddRequest {addX :: Fixed Word32
-                              , addY :: Fixed Word32}
-  deriving (Show, Eq, Ord, Generic)
-instance Message AddRequest
-data AddResponse = AddResponse {answer :: Fixed Word32}
-  deriving (Show, Eq, Ord, Generic)
-instance Message AddResponse
-
-addHandler :: Handler 'Normal
-addHandler =
-  UnaryHandler "/echo.Add/DoAdd" $
-    \c -> do
-      let b = payload c
-      return ( AddResponse $ addX b + addY b
-             , metadata c
-             , StatusOk
-             , StatusDetails ""
-             )
-
-highlevelMain :: IO ()
-highlevelMain =
-  serverLoop defaultOptions{optNormalHandlers = [echoHandler, addHandler]}
-
-highlevelMainUnregistered :: IO ()
-highlevelMainUnregistered =
-  U.serverLoop defaultOptions{optNormalHandlers = [echoHandler, addHandler]}
-
-main :: IO ()
-main = highlevelMainUnregistered
-
-defConfig :: ServerConfig
-defConfig = ServerConfig "localhost" 50051 [] [] [] [] [] Nothing

examples/echo/echo.proto

@@ -1,24 +1,7 @@
 syntax = "proto3";
-
 package echo;
-
 service Echo {
-  rpc DoEcho (EchoRequest) returns (EchoRequest) {}
+  rpc DoEcho (EchoRequest) returns (EchoResponse) {}
-}
-
-message EchoRequest {
-  string message = 1;
-}
-
-message AddRequest {
-  fixed32 addX = 1;
-  fixed32 addY = 2;
-}
-
-message AddResponse {
-  fixed32 answer = 1;
-}
-
-service Add {
-  rpc DoAdd (AddRequest) returns (AddResponse) {}
 }
+message EchoRequest  { string message = 1; }
+message EchoResponse { string message = 1; }

grpc-haskell.cabal

@@ -10,7 +10,6 @@ copyright:           Copyright 2016 Awake Networks
 category:            Network
 build-type:          Simple
 cabal-version:       >=1.10
-extra-source-files:   cbits, include
 
 Flag Debug
   Description: Adds debug logging.
@@ -157,15 +156,19 @@ executable echo-server
       , bytestring == 0.10.*
       , containers ==0.5.*
       , grpc-haskell
+      , optparse-generic
       , proto3-wire
       , protobuf-wire
       , text
+      , vector
+    other-modules:
+      Echo
   else
     buildable: False
   default-language: Haskell2010
   ghc-options:      -Wall -g -threaded -rtsopts -with-rtsopts=-N -O2
-  hs-source-dirs:   examples/echo/echo-server
+  hs-source-dirs:   examples/echo/echo-hs
-  main-is:          Main.hs
+  main-is:          EchoServer.hs
 
 executable echo-client
   if flag(with-examples)
@@ -175,16 +178,20 @@ executable echo-client
       , bytestring == 0.10.*
       , containers ==0.5.*
       , grpc-haskell
+      , optparse-generic
       , proto3-wire
       , protobuf-wire
       , text
       , random
+      , vector
+    other-modules:
+      Echo
   else
     buildable: False
   default-language: Haskell2010
   ghc-options:      -Wall -g -threaded -rtsopts -with-rtsopts=-N -O2
-  hs-source-dirs:   examples/echo/echo-client
+  hs-source-dirs:   examples/echo/echo-hs
-  main-is:          Main.hs
+  main-is:          EchoClient.hs
 
 test-suite test
   build-depends:

src/Network/GRPC/LowLevel.hs

@@ -31,8 +31,8 @@ GRPC
 , Arg(..)
 , CompressionAlgorithm(..)
 , CompressionLevel(..)
-, Host
+, Host(..)
-, Port
+, Port(..)
 
 -- * Server
 , ServerConfig(..)