From d46c0c1c945270ea4d1fdf2ef2c59d6fd7d7e129 Mon Sep 17 00:00:00 2001 From: Joel Stanley Date: Mon, 6 Jun 2016 12:54:43 -0500 Subject: [PATCH] Distinguish hostnames vs "host:port" strings; minor echo client cleanup (#20) * Remove explicit host:port parameter from clientRequest * Save ClientConfig in Client ADT; derive host:port string as needed * Add Port newtype and endpoint string constructor fn * Introduce Endpoint newtype for host:port strings; derive them as needed; misc cleanup * Clean up echo client --- examples/echo/echo-client/Main.hs | 47 ++++------- grpc-haskell.cabal | 2 +- src/Network/GRPC/LowLevel/Call.hs | 12 ++- src/Network/GRPC/LowLevel/Client.hs | 64 +++++++------- src/Network/GRPC/LowLevel/CompletionQueue.hs | 19 +++-- src/Network/GRPC/LowLevel/Server.hs | 87 +++++++++++--------- tests/LowLevelTests.hs | 4 +- 7 files changed, 119 insertions(+), 116 deletions(-) diff --git a/examples/echo/echo-client/Main.hs b/examples/echo/echo-client/Main.hs index 62eb1c0..a430f1f 100644 --- a/examples/echo/echo-client/Main.hs +++ b/examples/echo/echo-client/Main.hs @@ -1,37 +1,24 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} -import Control.Concurrent (threadDelay) -import Control.Monad (forever) -import Data.ByteString () -import qualified Data.Map as M -import Network.GRPC.LowLevel +import Control.Monad +import Network.GRPC.LowLevel -echoMethod :: MethodName echoMethod = MethodName "/echo.Echo/DoEcho" -ntimes :: Int -> IO () -> IO () -ntimes 1 f = f -ntimes n f = f >> (ntimes (n-1) f) +unregistered c = do + clientRequest c echoMethod 1 "hi" mempty -unregClient :: IO () -unregClient = do - withGRPC $ \grpc -> - withClient grpc (ClientConfig "localhost" 50051) $ \client -> - ntimes 100000 $ do - reqResult <- clientRequest client echoMethod "localhost:50051" 1 "hi" M.empty - case reqResult of - Left x -> error $ "Got client error: " ++ show x - Right resp -> return () +registered c = do + meth <- clientRegisterMethod c echoMethod Normal + clientRegisteredRequest c meth 1 "hi" mempty -regClient :: IO () -regClient = do - withGRPC $ \grpc -> - withClient grpc (ClientConfig "localhost" 50051) $ \client -> ntimes 100000 $ do - regMethod <- clientRegisterMethod client echoMethod Normal - reqResult <- clientRegisteredRequest client regMethod 1 "hi" M.empty - case reqResult of - Left x -> error $ "Got client error: " ++ show x - Right resp -> return () +run f = withGRPC $ \g -> withClient g (ClientConfig "localhost" 50051) $ \c -> + f c >>= \case + Left e -> error $ "Got client error: " ++ show e + _ -> return () -main :: IO () -main = regClient +main = replicateM_ 100 $ run $ + registered diff --git a/grpc-haskell.cabal b/grpc-haskell.cabal index 51f2d9b..72373f8 100644 --- a/grpc-haskell.cabal +++ b/grpc-haskell.cabal @@ -21,7 +21,7 @@ Flag Debug flag with-examples description: Also build example executables. manual: True - default: False + default: True library build-depends: diff --git a/src/Network/GRPC/LowLevel/Call.hs b/src/Network/GRPC/LowLevel/Call.hs index 5190e83..d8349ca 100644 --- a/src/Network/GRPC/LowLevel/Call.hs +++ b/src/Network/GRPC/LowLevel/Call.hs @@ -28,6 +28,16 @@ newtype MethodName = MethodName {unMethodName :: String} newtype Host = Host {unHost :: String} deriving (Show, Eq, IsString) +newtype Port = Port {unPort :: Int} + deriving (Eq, Num, Show) + +newtype Endpoint = Endpoint {unEndpoint :: String} + deriving (Show, Eq, IsString) + +-- | Given a hostname and port, produces a "host:port" string +endpoint :: Host -> Port -> Endpoint +endpoint (Host h) (Port p) = Endpoint (h ++ ":" ++ show p) + -- | Represents a registered method. Methods can optionally be registered in -- order to make the C-level request/response code simpler. -- Before making or awaiting a registered call, the @@ -36,7 +46,7 @@ newtype Host = Host {unHost :: String} -- Contains state for identifying that method in the underlying gRPC library. data RegisteredMethod = RegisteredMethod {methodType :: GRPCMethodType, methodName :: MethodName, - methodHost :: Host, + methodEndpoint :: Endpoint, methodHandle :: C.CallHandle} -- | Represents one GRPC call (i.e. request) on the client. diff --git a/src/Network/GRPC/LowLevel/Client.hs b/src/Network/GRPC/LowLevel/Client.hs index a29ee53..48ce4d9 100644 --- a/src/Network/GRPC/LowLevel/Client.hs +++ b/src/Network/GRPC/LowLevel/Client.hs @@ -19,20 +19,22 @@ import Network.GRPC.LowLevel.Op -- | Represents the context needed to perform client-side gRPC operations. data Client = Client {clientChannel :: C.Channel, clientCQ :: CompletionQueue, - clientHostPort :: String} + clientConfig :: ClientConfig + } -- | Configuration necessary to set up a client. -data ClientConfig = ClientConfig {clientServerHost :: Host, - clientServerPort :: Int} +data ClientConfig = ClientConfig {serverHost :: Host, + serverPort :: Port} + +clientEndpoint :: ClientConfig -> Endpoint +clientEndpoint ClientConfig{..} = endpoint serverHost serverPort createClient :: GRPC -> ClientConfig -> IO Client -createClient grpc conf@ClientConfig{..} = do - let clientHostPort = (unHost clientServerHost) - ++ ":" - ++ (show clientServerPort) - clientChannel <- C.grpcInsecureChannelCreate clientHostPort nullPtr C.reserved +createClient grpc clientConfig = do + let Endpoint e = clientEndpoint clientConfig + clientChannel <- C.grpcInsecureChannelCreate e nullPtr C.reserved clientCQ <- createCompletionQueue grpc - return $ Client{..} + return Client{..} destroyClient :: Client -> IO () destroyClient Client{..} = do @@ -59,12 +61,11 @@ clientRegisterMethod :: Client -- ^ method name, e.g. "/foo" -> GRPCMethodType -> IO RegisteredMethod -clientRegisterMethod Client{..} name Normal = do +clientRegisterMethod Client{..} meth Normal = do + let e = clientEndpoint clientConfig handle <- C.grpcChannelRegisterCall clientChannel - (unMethodName name) - clientHostPort - C.reserved - return $ RegisteredMethod Normal name (Host clientHostPort) handle + (unMethodName meth) (unEndpoint e) C.reserved + return $ RegisteredMethod Normal meth e handle clientRegisterMethod _ _ _ = error "Streaming methods not yet implemented." -- | Create a new call on the client for a registered method. @@ -97,23 +98,22 @@ withClientRegisteredCall client regmethod timeout f = do -- method registration machinery. In practice, we'll probably only use the -- registered method version, but we include this for completeness and testing. clientCreateCall :: Client - -> MethodName - -- ^ The method name - -> Host - -- ^ The host. - -> TimeoutSeconds - -> IO (Either GRPCIOError ClientCall) -clientCreateCall Client{..} method host timeout = do + -> MethodName + -> TimeoutSeconds + -> IO (Either GRPCIOError ClientCall) +clientCreateCall Client{..} meth timeout = do let parentCall = C.Call nullPtr C.withDeadlineSeconds timeout $ \deadline -> do channelCreateCall clientChannel parentCall C.propagateDefaults - clientCQ method host deadline + clientCQ meth (clientEndpoint clientConfig) deadline -withClientCall :: Client -> MethodName -> Host -> TimeoutSeconds - -> (ClientCall -> IO (Either GRPCIOError a)) - -> IO (Either GRPCIOError a) -withClientCall client method host timeout f = do - createResult <- clientCreateCall client method host timeout +withClientCall :: Client + -> MethodName + -> TimeoutSeconds + -> (ClientCall -> IO (Either GRPCIOError a)) + -> IO (Either GRPCIOError a) +withClientCall client method timeout f = do + createResult <- clientCreateCall client method timeout case createResult of Left x -> return $ Left x Right call -> f call `finally` logDestroy call @@ -201,18 +201,16 @@ clientRegisteredRequest client@(Client{..}) rm@(RegisteredMethod{..}) clientRequest :: Client -> MethodName -- ^ Method name, e.g. "/foo" - -> Host - -- ^ Host. Not sure if used. -> TimeoutSeconds + -- ^ "Number of seconds until request times out" -> ByteString -- ^ Request body. -> MetadataMap -- ^ Request metadata. -> IO (Either GRPCIOError NormalRequestResult) -clientRequest client@(Client{..}) (MethodName method) (Host host) - timeLimit body meta = - fmap join $ - withClientCall client (MethodName method) (Host host) timeLimit $ \call -> do +clientRequest client@Client{..} meth timeLimit body meta = + fmap join $ do + withClientCall client meth timeLimit $ \call -> do let ops = clientNormalRequestOps body meta results <- runClientOps call clientCQ ops timeLimit grpcDebug "clientRequest: ops ran." diff --git a/src/Network/GRPC/LowLevel/CompletionQueue.hs b/src/Network/GRPC/LowLevel/CompletionQueue.hs index ae7005d..dd14388 100644 --- a/src/Network/GRPC/LowLevel/CompletionQueue.hs +++ b/src/Network/GRPC/LowLevel/CompletionQueue.hs @@ -237,15 +237,18 @@ channelCreateRegisteredCall handle deadline C.reserved return $ Right $ ClientCall call -channelCreateCall :: C.Channel -> C.Call -> C.PropagationMask -> CompletionQueue - -> MethodName -> Host -> C.CTimeSpecPtr - -> IO (Either GRPCIOError ClientCall) -channelCreateCall - chan parent mask cq@CompletionQueue{..} (MethodName methodName) (Host host) - deadline = +channelCreateCall :: C.Channel + -> C.Call + -> C.PropagationMask + -> CompletionQueue + -> MethodName + -> Endpoint + -> C.CTimeSpecPtr + -> IO (Either GRPCIOError ClientCall) +channelCreateCall chan parent mask cq@CompletionQueue{..} meth endpt deadline = withPermission Push cq $ do - call <- C.grpcChannelCreateCall chan parent mask unsafeCQ methodName host - deadline C.reserved + call <- C.grpcChannelCreateCall chan parent mask unsafeCQ + (unMethodName meth) (unEndpoint endpt) deadline C.reserved return $ Right $ ClientCall call -- | Create the call object to handle a registered call. diff --git a/src/Network/GRPC/LowLevel/Server.hs b/src/Network/GRPC/LowLevel/Server.hs index 60a3ea0..4c3bc74 100644 --- a/src/Network/GRPC/LowLevel/Server.hs +++ b/src/Network/GRPC/LowLevel/Server.hs @@ -24,41 +24,47 @@ import Network.GRPC.LowLevel.GRPC import Network.GRPC.LowLevel.Op -- | Wraps various gRPC state needed to run a server. -data Server = Server {internalServer :: C.Server, serverCQ :: CompletionQueue, - registeredMethods :: [RegisteredMethod]} +data Server = Server + { internalServer :: C.Server + , serverCQ :: CompletionQueue + , registeredMethods :: [RegisteredMethod] + , serverConfig :: ServerConfig + } --- | Configuration needed to start a server. There might be more fields that --- need to be added to this in the future. -data ServerConfig = - ServerConfig {hostName :: Host, - -- ^ Name of the host the server is running on. Not sure - -- how this is used. Setting to "localhost" works fine in tests. - port :: Int, - -- ^ Port to listen for requests on. - methodsToRegister :: [(MethodName, GRPCMethodType)] - -- ^ List of (method name, method host, method type) tuples - -- specifying all methods to register. You can also handle - -- other unregistered methods with `serverHandleNormalCall`. - } +-- | Configuration needed to start a server. +data ServerConfig = ServerConfig + { host :: Host + -- ^ Name of the host the server is running on. Not sure how this is + -- used. Setting to "localhost" works fine in tests. + , port :: Port + -- ^ Port on which to listen for requests. + , methodsToRegister :: [(MethodName, GRPCMethodType)] + -- ^ List of (method name, method type) tuples specifying all methods to + -- register. You can also handle other unregistered methods with + -- `serverHandleNormalCall`. + } deriving (Show, Eq) +serverEndpoint :: ServerConfig -> Endpoint +serverEndpoint ServerConfig{..} = endpoint host port + startServer :: GRPC -> ServerConfig -> IO Server -startServer grpc ServerConfig{..} = do +startServer grpc conf@ServerConfig{..} = do + let e = serverEndpoint conf server <- C.grpcServerCreate nullPtr C.reserved - let hostPort = (unHost hostName) ++ ":" ++ (show port) - actualPort <- C.grpcServerAddInsecureHttp2Port server hostPort - when (actualPort /= port) (error $ "Unable to bind port: " ++ (show port)) + actualPort <- C.grpcServerAddInsecureHttp2Port server (unEndpoint e) + when (actualPort /= unPort port) $ + error $ "Unable to bind port: " ++ show port cq <- createCompletionQueue grpc serverRegisterCompletionQueue server cq - methods <- forM methodsToRegister $ - \(name, mtype) -> - serverRegisterMethod server name (Host hostPort) mtype + methods <- forM methodsToRegister $ \(name, mtype) -> + serverRegisterMethod server name e mtype C.grpcServerStart server - return $ Server server cq methods + return $ Server server cq methods conf stopServer :: Server -> IO () -- TODO: Do method handles need to be freed? -stopServer (Server server cq _) = do +stopServer (Server server cq _ _) = do grpcDebug "stopServer: calling shutdownNotify." shutdownNotify grpcDebug "stopServer: cancelling all calls." @@ -94,25 +100,24 @@ withServer grpc cfg f = bracket (startServer grpc cfg) stopServer f -- the server is started, so we do it during startup according to the -- 'ServerConfig'. serverRegisterMethod :: C.Server - -> MethodName - -- ^ method name, e.g. "/foo" - -> Host - -- ^ host name, e.g. "localhost". I have no idea - -- why this is needed since we have to supply a host - -- name to start a server in the first place. It doesn't - -- seem to have any effect, even if it's filled with - -- nonsense. - -> GRPCMethodType - -- ^ Type of method this will be. In the future, this - -- will be used to switch to the correct handling logic. - -- Currently, the only valid choice is 'Normal'. - -> IO RegisteredMethod -serverRegisterMethod internalServer name host Normal = do + -> MethodName + -- ^ method name, e.g. "/foo" + -> Endpoint + -- ^ Endpoint name name, e.g. "localhost:9999". I have no + -- idea why this is needed since we have to provide these + -- parameters to start a server in the first place. It + -- doesn't seem to have any effect, even if it's filled + -- with nonsense. + -> GRPCMethodType + -- ^ Type of method this will be. In the future, this will + -- be used to switch to the correct handling logic. + -- Currently, the only valid choice is 'Normal'. + -> IO RegisteredMethod +serverRegisterMethod internalServer meth e Normal = do handle <- C.grpcServerRegisterMethod internalServer - (unMethodName name) - (unHost host) + (unMethodName meth) (unEndpoint e) grpcDebug $ "registered method to handle " ++ show handle - return $ RegisteredMethod Normal name host handle + return $ RegisteredMethod Normal meth e handle serverRegisterMethod _ _ _ _ = error "Streaming methods not implemented yet." -- | Create a 'Call' with which to wait for the invocation of a registered diff --git a/tests/LowLevelTests.hs b/tests/LowLevelTests.hs index fda28fb..631260f 100644 --- a/tests/LowLevelTests.hs +++ b/tests/LowLevelTests.hs @@ -78,7 +78,7 @@ payloadLowLevelClient = TestClient $ \grpc -> payloadLowLevelClientUnregistered :: TestClient payloadLowLevelClientUnregistered = TestClient $ \grpc -> do withClient grpc (ClientConfig "localhost" 50051) $ \client -> do - reqResult <- clientRequest client "/foo" "localhost" 10 "Hello!" M.empty + reqResult <- clientRequest client "/foo" 10 "Hello!" M.empty case reqResult of Left x -> error $ "Client got error: " ++ show x Right (NormalRequestResult @@ -166,7 +166,7 @@ testWithClientCall = grpcTest "Client - Create/destroy call" $ \grpc -> do let conf = ClientConfig "localhost" 50051 withClient grpc conf $ \client -> do - result <- withClientCall client "foo" "localhost" 10 $ + result <- withClientCall client "foo" 10 $ const $ return $ Right () case result of Left err -> error $ show err