eeva/gRPC-haskell
1
0
Fork 0
mirror of https://github.com/unclechu/gRPC-haskell.git synced 2024-12-24 02:39:45 +01:00
Code Issues Projects Releases Wiki Activity

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

Browse source 
* 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
This commit is contained in:
Joel Stanley 2016-12-22 14:33:44 -06:00 committed by GitHub Enterprise
parent db3d66c4eb
commit 9a3be32ed7
12 changed files with 225 additions and 230 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
.gitignore vendored
View file

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

1
default.nix
View file

@ -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

76
examples/echo/echo-client/Main.hs
View file

@ -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

6
examples/echo/echo-cpp/Makefile
View file

@ -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 $@

105
examples/echo/echo-hs/Echo.hs Normal file
View file

@ -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)]

48
examples/echo/echo-hs/EchoClient.hs Normal file
View file

@ -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

42
examples/echo/echo-hs/EchoServer.hs Normal file
View file

@ -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

4
examples/echo/echo-hs/Makefile Normal file
View file

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

127
examples/echo/echo-server/Main.hs
View file

@ -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

23
examples/echo/echo.proto
View file

@ -1,24 +1,7 @@
syntax = "proto3";
package echo;
service Echo {
rpc DoEcho (EchoRequest) returns (EchoRequest) {}
}
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) {}
rpc DoEcho (EchoRequest) returns (EchoResponse) {}
}
message EchoRequest { string message = 1; }
message EchoResponse { string message = 1; }

17
grpc-haskell.cabal
View file

@ -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
main-is: Main.hs
hs-source-dirs: examples/echo/echo-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
main-is: Main.hs
hs-source-dirs: examples/echo/echo-hs
main-is: EchoClient.hs
test-suite test
build-depends:

4
src/Network/GRPC/LowLevel.hs
View file

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