diff --git a/.gitignore b/.gitignore index 3e4307f..ad33332 100644 --- a/.gitignore +++ b/.gitignore @@ -6,3 +6,5 @@ dist examples/echo/echo-cpp/echo-client examples/echo/echo-cpp/echo-server benchmarks.html +result + diff --git a/default.nix b/default.nix index 2685f99..0878bbe 100644 --- a/default.nix +++ b/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 diff --git a/examples/echo/echo-client/Main.hs b/examples/echo/echo-client/Main.hs deleted file mode 100644 index 31c0b60..0000000 --- a/examples/echo/echo-client/Main.hs +++ /dev/null @@ -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 diff --git a/examples/echo/echo-cpp/Makefile b/examples/echo/echo-cpp/Makefile index 63df926..b7e0c99 100644 --- a/examples/echo/echo-cpp/Makefile +++ b/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 $@ + diff --git a/examples/echo/echo-hs/Echo.hs b/examples/echo/echo-hs/Echo.hs new file mode 100644 index 0000000..486f201 --- /dev/null +++ b/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)] diff --git a/examples/echo/echo-hs/EchoClient.hs b/examples/echo/echo-hs/EchoClient.hs new file mode 100644 index 0000000..4757758 --- /dev/null +++ b/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 diff --git a/examples/echo/echo-hs/EchoServer.hs b/examples/echo/echo-hs/EchoServer.hs new file mode 100644 index 0000000..b147117 --- /dev/null +++ b/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 diff --git a/examples/echo/echo-hs/Makefile b/examples/echo/echo-hs/Makefile new file mode 100644 index 0000000..81f15b7 --- /dev/null +++ b/examples/echo/echo-hs/Makefile @@ -0,0 +1,4 @@ + +Echo.hs: ../echo.proto + stack exec -- compile-proto-file --proto ../echo.proto > Echo.hs + diff --git a/examples/echo/echo-server/Main.hs b/examples/echo/echo-server/Main.hs deleted file mode 100644 index a9c6fa9..0000000 --- a/examples/echo/echo-server/Main.hs +++ /dev/null @@ -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 diff --git a/examples/echo/echo.proto b/examples/echo/echo.proto index 5ac72fe..37335d0 100644 --- a/examples/echo/echo.proto +++ b/examples/echo/echo.proto @@ -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; } diff --git a/grpc-haskell.cabal b/grpc-haskell.cabal index 92e34f5..5dc8485 100644 --- a/grpc-haskell.cabal +++ b/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 - 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: diff --git a/src/Network/GRPC/LowLevel.hs b/src/Network/GRPC/LowLevel.hs index 69f371f..e305139 100644 --- a/src/Network/GRPC/LowLevel.hs +++ b/src/Network/GRPC/LowLevel.hs @@ -31,8 +31,8 @@ GRPC , Arg(..) , CompressionAlgorithm(..) , CompressionLevel(..) -, Host -, Port +, Host(..) +, Port(..) -- * Server , ServerConfig(..)