From 386568463a331465e7648817fb98b24acdbf22e1 Mon Sep 17 00:00:00 2001 From: Joel Stanley Date: Wed, 8 Jun 2016 11:18:43 -0500 Subject: [PATCH] Split off support for unregistered calls to an *.Unregistered module namespace --- grpc-haskell.cabal | 3 + src/Network/GRPC/LowLevel.hs | 3 + src/Network/GRPC/LowLevel/Call.hs | 81 +++------------- .../GRPC/LowLevel/Call/Unregistered.hs | 75 +++++++++++++++ src/Network/GRPC/LowLevel/Client.hs | 73 +++----------- .../GRPC/LowLevel/Client/Unregistered.hs | 66 +++++++++++++ src/Network/GRPC/LowLevel/CompletionQueue.hs | 38 ++++---- src/Network/GRPC/LowLevel/Op.hs | 29 +++--- src/Network/GRPC/LowLevel/Server.hs | 95 ++++--------------- .../GRPC/LowLevel/Server/Unregistered.hs | 78 +++++++++++++++ 10 files changed, 305 insertions(+), 236 deletions(-) create mode 100644 src/Network/GRPC/LowLevel/Call/Unregistered.hs create mode 100644 src/Network/GRPC/LowLevel/Client/Unregistered.hs create mode 100644 src/Network/GRPC/LowLevel/Server/Unregistered.hs diff --git a/grpc-haskell.cabal b/grpc-haskell.cabal index 72373f8..0386528 100644 --- a/grpc-haskell.cabal +++ b/grpc-haskell.cabal @@ -47,8 +47,11 @@ library Network.GRPC.LowLevel.GRPC Network.GRPC.LowLevel.Op Network.GRPC.LowLevel.Server + Network.GRPC.LowLevel.Server.Unregistered Network.GRPC.LowLevel.Call + Network.GRPC.LowLevel.Call.Unregistered Network.GRPC.LowLevel.Client + Network.GRPC.LowLevel.Client.Unregistered extra-libraries: grpc includes: diff --git a/src/Network/GRPC/LowLevel.hs b/src/Network/GRPC/LowLevel.hs index aa96213..26b8f52 100644 --- a/src/Network/GRPC/LowLevel.hs +++ b/src/Network/GRPC/LowLevel.hs @@ -61,10 +61,13 @@ GRPC import Network.GRPC.LowLevel.GRPC import Network.GRPC.LowLevel.Server +import Network.GRPC.LowLevel.Server.Unregistered import Network.GRPC.LowLevel.CompletionQueue import Network.GRPC.LowLevel.Op import Network.GRPC.LowLevel.Client +import Network.GRPC.LowLevel.Client.Unregistered import Network.GRPC.LowLevel.Call +import Network.GRPC.LowLevel.Call.Unregistered import Network.GRPC.Unsafe (ConnectivityState(..)) import Network.GRPC.Unsafe.Op (StatusCode(..)) diff --git a/src/Network/GRPC/LowLevel/Call.hs b/src/Network/GRPC/LowLevel/Call.hs index d8349ca..127b4ca 100644 --- a/src/Network/GRPC/LowLevel/Call.hs +++ b/src/Network/GRPC/LowLevel/Call.hs @@ -1,21 +1,24 @@ -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} +-- | This module defines data structures and operations pertaining to registered +-- calls; for unregistered call support, see +-- `Network.GRPC.LowLevel.Call.Unregistered`. module Network.GRPC.LowLevel.Call where import Control.Monad -import Data.ByteString (ByteString) -import Data.String (IsString) -import Foreign.Marshal.Alloc (free) -import Foreign.Ptr (Ptr, nullPtr) -import Foreign.Storable (peek) +import Data.ByteString (ByteString) +import Data.String (IsString) +import Foreign.Marshal.Alloc (free) +import Foreign.Ptr (Ptr, nullPtr) +import Foreign.Storable (peek) -import qualified Network.GRPC.Unsafe as C -import qualified Network.GRPC.Unsafe.Time as C -import qualified Network.GRPC.Unsafe.Metadata as C +import qualified Network.GRPC.Unsafe as C import qualified Network.GRPC.Unsafe.ByteBuffer as C +import qualified Network.GRPC.Unsafe.Metadata as C +import qualified Network.GRPC.Unsafe.Time as C -import Network.GRPC.LowLevel.GRPC (grpcDebug, MetadataMap) +import Network.GRPC.LowLevel.GRPC (MetadataMap, grpcDebug) -- | Models the four types of RPC call supported by gRPC. We currently only -- support the first alternative, and only in a preliminary fashion. @@ -82,28 +85,6 @@ serverRegCallGetPayload ServerRegCall{..} = do then return Nothing else Just <$> C.copyByteBufferToByteString bb --- | Represents one unregistered GRPC call on the server. --- Contains pointers to all the C state needed to respond to an unregistered --- call. -data ServerUnregCall = ServerUnregCall - {internalServerUnregCall :: C.Call, - requestMetadataRecvUnreg :: Ptr C.MetadataArray, - parentPtrUnreg :: Maybe (Ptr C.Call), - callDetails :: C.CallDetails} - -serverUnregCallGetMetadata :: ServerUnregCall -> IO MetadataMap -serverUnregCallGetMetadata ServerUnregCall{..} = do - marray <- peek requestMetadataRecvUnreg - C.getAllMetadataArray marray - -serverUnregCallGetMethodName :: ServerUnregCall -> IO MethodName -serverUnregCallGetMethodName ServerUnregCall{..} = - MethodName <$> C.callDetailsGetMethod callDetails - -serverUnregCallGetHost :: ServerUnregCall -> IO Host -serverUnregCallGetHost ServerUnregCall{..} = - Host <$> C.callDetailsGetHost callDetails - debugClientCall :: ClientCall -> IO () {-# INLINE debugClientCall #-} #ifdef DEBUG @@ -138,28 +119,6 @@ debugServerRegCall call@(ServerRegCall (C.Call ptr) _ _ _ _) = do debugServerRegCall = const $ return () #endif -debugServerUnregCall :: ServerUnregCall -> IO () -#ifdef DEBUG -debugServerUnregCall call@(ServerUnregCall (C.Call ptr) _ _ _) = do - grpcDebug $ "debugServerUnregCall: server call: " ++ (show ptr) - grpcDebug $ "debugServerUnregCall: metadata ptr: " - ++ show (requestMetadataRecvUnreg call) - metadataArr <- peek (requestMetadataRecvUnreg call) - metadata <- C.getAllMetadataArray metadataArr - grpcDebug $ "debugServerUnregCall: metadata received: " ++ (show metadata) - forM_ (parentPtrUnreg call) $ \parentPtr' -> do - grpcDebug $ "debugServerRegCall: parent ptr: " ++ show parentPtr' - (C.Call parent) <- peek parentPtr' - grpcDebug $ "debugServerRegCall: parent: " ++ show parent - grpcDebug $ "debugServerUnregCall: callDetails ptr: " - ++ show (callDetails call) - --TODO: need functions for getting data out of call_details. -#else -{-# INLINE debugServerUnregCall #-} -debugServerUnregCall = const $ return () -#endif - - destroyClientCall :: ClientCall -> IO () destroyClientCall ClientCall{..} = do grpcDebug "Destroying client-side call object." @@ -180,17 +139,3 @@ destroyServerRegCall call@ServerRegCall{..} = do forM_ parentPtrReg free grpcDebug $ "destroying deadline." ++ show callDeadline C.timespecDestroy callDeadline - -destroyServerUnregCall :: ServerUnregCall -> IO () -destroyServerUnregCall call@ServerUnregCall{..} = do - grpcDebug "destroyServerUnregCall: entered." - debugServerUnregCall call - grpcDebug $ "Destroying server-side call object: " - ++ show internalServerUnregCall - C.grpcCallDestroy internalServerUnregCall - grpcDebug $ "destroying metadata array: " ++ show requestMetadataRecvUnreg - C.metadataArrayDestroy requestMetadataRecvUnreg - grpcDebug $ "freeing parentPtrUnreg: " ++ show parentPtrUnreg - forM_ parentPtrUnreg free - grpcDebug $ "destroying call details: " ++ show callDetails - C.destroyCallDetails callDetails diff --git a/src/Network/GRPC/LowLevel/Call/Unregistered.hs b/src/Network/GRPC/LowLevel/Call/Unregistered.hs new file mode 100644 index 0000000..de6fb36 --- /dev/null +++ b/src/Network/GRPC/LowLevel/Call/Unregistered.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE RecordWildCards #-} + +module Network.GRPC.LowLevel.Call.Unregistered where + +import Control.Monad +import Data.ByteString (ByteString) +import Data.String (IsString) +import Foreign.Marshal.Alloc (free) +import Foreign.Ptr (Ptr, nullPtr) +import Foreign.Storable (peek) + +import qualified Network.GRPC.Unsafe as C +import qualified Network.GRPC.Unsafe.ByteBuffer as C +import qualified Network.GRPC.Unsafe.Metadata as C +import qualified Network.GRPC.Unsafe.Time as C + +import Network.GRPC.LowLevel.Call +import Network.GRPC.LowLevel.GRPC (MetadataMap, grpcDebug) + +-- | Represents one unregistered GRPC call on the server. +-- Contains pointers to all the C state needed to respond to an unregistered +-- call. +data ServerUnregCall = ServerUnregCall + {internalServerUnregCall :: C.Call, + requestMetadataRecvUnreg :: Ptr C.MetadataArray, + parentPtrUnreg :: Maybe (Ptr C.Call), + callDetails :: C.CallDetails} + +serverUnregCallGetMetadata :: ServerUnregCall -> IO MetadataMap +serverUnregCallGetMetadata ServerUnregCall{..} = do + marray <- peek requestMetadataRecvUnreg + C.getAllMetadataArray marray + +serverUnregCallGetMethodName :: ServerUnregCall -> IO MethodName +serverUnregCallGetMethodName ServerUnregCall{..} = + MethodName <$> C.callDetailsGetMethod callDetails + +serverUnregCallGetHost :: ServerUnregCall -> IO Host +serverUnregCallGetHost ServerUnregCall{..} = + Host <$> C.callDetailsGetHost callDetails + +debugServerUnregCall :: ServerUnregCall -> IO () +#ifdef DEBUG +debugServerUnregCall call@(ServerUnregCall (C.Call ptr) _ _ _) = do + grpcDebug $ "debugServerUnregCall: server call: " ++ (show ptr) + grpcDebug $ "debugServerUnregCall: metadata ptr: " + ++ show (requestMetadataRecvUnreg call) + metadataArr <- peek (requestMetadataRecvUnreg call) + metadata <- C.getAllMetadataArray metadataArr + grpcDebug $ "debugServerUnregCall: metadata received: " ++ (show metadata) + forM_ (parentPtrUnreg call) $ \parentPtr' -> do + grpcDebug $ "debugServerRegCall: parent ptr: " ++ show parentPtr' + (C.Call parent) <- peek parentPtr' + grpcDebug $ "debugServerRegCall: parent: " ++ show parent + grpcDebug $ "debugServerUnregCall: callDetails ptr: " + ++ show (callDetails call) + --TODO: need functions for getting data out of call_details. +#else +{-# INLINE debugServerUnregCall #-} +debugServerUnregCall = const $ return () +#endif + +destroyServerUnregCall :: ServerUnregCall -> IO () +destroyServerUnregCall call@ServerUnregCall{..} = do + grpcDebug "destroyServerUnregCall: entered." + debugServerUnregCall call + grpcDebug $ "Destroying server-side call object: " + ++ show internalServerUnregCall + C.grpcCallDestroy internalServerUnregCall + grpcDebug $ "destroying metadata array: " ++ show requestMetadataRecvUnreg + C.metadataArrayDestroy requestMetadataRecvUnreg + grpcDebug $ "freeing parentPtrUnreg: " ++ show parentPtrUnreg + forM_ parentPtrUnreg free + grpcDebug $ "destroying call details: " ++ show callDetails + C.destroyCallDetails callDetails diff --git a/src/Network/GRPC/LowLevel/Client.hs b/src/Network/GRPC/LowLevel/Client.hs index 3b57381..ffa4479 100644 --- a/src/Network/GRPC/LowLevel/Client.hs +++ b/src/Network/GRPC/LowLevel/Client.hs @@ -2,24 +2,24 @@ module Network.GRPC.LowLevel.Client where -import Control.Exception (bracket, finally) -import Control.Monad (join) -import Data.ByteString (ByteString) -import Foreign.Ptr (nullPtr) -import qualified Network.GRPC.Unsafe as C -import qualified Network.GRPC.Unsafe.Time as C -import qualified Network.GRPC.Unsafe.Constants as C -import qualified Network.GRPC.Unsafe.Op as C +import Control.Exception (bracket, finally) +import Control.Monad (join) +import Data.ByteString (ByteString) +import Foreign.Ptr (nullPtr) +import qualified Network.GRPC.Unsafe as C +import qualified Network.GRPC.Unsafe.Constants as C +import qualified Network.GRPC.Unsafe.Op as C +import qualified Network.GRPC.Unsafe.Time as C -import Network.GRPC.LowLevel.GRPC -import Network.GRPC.LowLevel.CompletionQueue import Network.GRPC.LowLevel.Call +import Network.GRPC.LowLevel.CompletionQueue +import Network.GRPC.LowLevel.GRPC import Network.GRPC.LowLevel.Op -- | Represents the context needed to perform client-side gRPC operations. data Client = Client {clientChannel :: C.Channel, - clientCQ :: CompletionQueue, - clientConfig :: ClientConfig + clientCQ :: CompletionQueue, + clientConfig :: ClientConfig } -- | Configuration necessary to set up a client. @@ -94,32 +94,6 @@ withClientRegisteredCall client regmethod timeout f = do where logDestroy c = grpcDebug "withClientRegisteredCall: destroying." >> destroyClientCall c --- | Create a call on the client for an endpoint without using the --- 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 - -> 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 meth (clientEndpoint clientConfig) deadline - -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 - where logDestroy c = grpcDebug "withClientCall: destroying." - >> destroyClientCall c - data NormalRequestResult = NormalRequestResult { rspBody :: ByteString , initMD :: Maybe MetadataMap -- initial metadata @@ -196,29 +170,6 @@ clientRegisteredRequest client@(Client{..}) rm@(RegisteredMethod{..}) return $ Right $ compileNormalRequestResults (rs ++ rs') _ -> error "Streaming methods not yet implemented." --- | Makes a normal (non-streaming) request without needing to register a method --- first. Probably only useful for testing. TODO: This is preliminary, like --- 'clientRegisteredRequest'. -clientRequest :: Client - -> MethodName - -- ^ Method name, e.g. "/foo" - -> TimeoutSeconds - -- ^ "Number of seconds until request times out" - -> ByteString - -- ^ Request body. - -> MetadataMap - -- ^ Request metadata. - -> IO (Either GRPCIOError NormalRequestResult) -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." - case results of - Left x -> return $ Left x - Right rs -> return $ Right $ compileNormalRequestResults rs - clientNormalRequestOps :: ByteString -> MetadataMap -> [Op] clientNormalRequestOps body metadata = [OpSendInitialMetadata metadata, diff --git a/src/Network/GRPC/LowLevel/Client/Unregistered.hs b/src/Network/GRPC/LowLevel/Client/Unregistered.hs new file mode 100644 index 0000000..9577da0 --- /dev/null +++ b/src/Network/GRPC/LowLevel/Client/Unregistered.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE RecordWildCards #-} + +module Network.GRPC.LowLevel.Client.Unregistered where + +import Control.Exception (finally) +import Control.Monad (join) +import Data.ByteString (ByteString) +import Foreign.Ptr (nullPtr) +import qualified Network.GRPC.Unsafe as C +import qualified Network.GRPC.Unsafe.Constants as C +import qualified Network.GRPC.Unsafe.Time as C + +import Network.GRPC.LowLevel.Call +import Network.GRPC.LowLevel.Client +import Network.GRPC.LowLevel.CompletionQueue +import Network.GRPC.LowLevel.GRPC +import Network.GRPC.LowLevel.Op + +-- | Create a call on the client for an endpoint without using the +-- 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 + -> 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 meth (clientEndpoint clientConfig) deadline + +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 + where logDestroy c = grpcDebug "withClientCall: destroying." + >> destroyClientCall c + +-- | Makes a normal (non-streaming) request without needing to register a method +-- first. Probably only useful for testing. TODO: This is preliminary, like +-- 'clientRegisteredRequest'. +clientRequest :: Client + -> MethodName + -- ^ Method name, e.g. "/foo" + -> TimeoutSeconds + -- ^ "Number of seconds until request times out" + -> ByteString + -- ^ Request body. + -> MetadataMap + -- ^ Request metadata. + -> IO (Either GRPCIOError NormalRequestResult) +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." + case results of + Left x -> return $ Left x + Right rs -> return $ Right $ compileNormalRequestResults rs diff --git a/src/Network/GRPC/LowLevel/CompletionQueue.hs b/src/Network/GRPC/LowLevel/CompletionQueue.hs index dd14388..2b63978 100644 --- a/src/Network/GRPC/LowLevel/CompletionQueue.hs +++ b/src/Network/GRPC/LowLevel/CompletionQueue.hs @@ -25,25 +25,29 @@ module Network.GRPC.LowLevel.CompletionQueue ) where -import Control.Concurrent (forkIO, threadDelay) -import Control.Concurrent.STM (atomically, check, retry) -import Control.Concurrent.STM.TVar (TVar, modifyTVar', newTVarIO, - readTVar, writeTVar) -import Control.Exception (bracket) -import Data.IORef (IORef, atomicModifyIORef', - newIORef) -import Data.List (intersperse) -import Foreign.Marshal.Alloc (free, malloc) -import Foreign.Ptr (nullPtr, plusPtr) -import Foreign.Storable (peek) -import qualified Network.GRPC.Unsafe as C -import qualified Network.GRPC.Unsafe.Constants as C -import qualified Network.GRPC.Unsafe.Metadata as C -import qualified Network.GRPC.Unsafe.Op as C -import qualified Network.GRPC.Unsafe.Time as C -import System.Timeout (timeout) +import Control.Concurrent (forkIO, threadDelay) +import Control.Concurrent.STM (atomically, check, + retry) +import Control.Concurrent.STM.TVar (TVar, modifyTVar', + newTVarIO, readTVar, + writeTVar) +import Control.Exception (bracket) +import Data.IORef (IORef, + atomicModifyIORef', + newIORef) +import Data.List (intersperse) +import Foreign.Marshal.Alloc (free, malloc) +import Foreign.Ptr (nullPtr, plusPtr) +import Foreign.Storable (peek) +import qualified Network.GRPC.Unsafe as C +import qualified Network.GRPC.Unsafe.Constants as C +import qualified Network.GRPC.Unsafe.Metadata as C +import qualified Network.GRPC.Unsafe.Op as C +import qualified Network.GRPC.Unsafe.Time as C +import System.Timeout (timeout) import Network.GRPC.LowLevel.Call +import Network.GRPC.LowLevel.Call.Unregistered import Network.GRPC.LowLevel.GRPC -- NOTE: the concurrency requirements for a CompletionQueue are a little diff --git a/src/Network/GRPC/LowLevel/Op.hs b/src/Network/GRPC/LowLevel/Op.hs index fc39016..b654605 100644 --- a/src/Network/GRPC/LowLevel/Op.hs +++ b/src/Network/GRPC/LowLevel/Op.hs @@ -4,22 +4,23 @@ module Network.GRPC.LowLevel.Op where import Control.Exception -import qualified Data.ByteString as B -import qualified Data.Map.Strict as M -import Data.Maybe (catMaybes) -import Data.String (IsString) -import Foreign.C.String (CString) -import Foreign.C.Types (CInt) -import Foreign.Marshal.Alloc (free, malloc, - mallocBytes) -import Foreign.Ptr (Ptr, nullPtr) -import Foreign.Storable (peek, poke) -import qualified Network.GRPC.Unsafe as C (Call) -import qualified Network.GRPC.Unsafe.ByteBuffer as C -import qualified Network.GRPC.Unsafe.Metadata as C -import qualified Network.GRPC.Unsafe.Op as C +import qualified Data.ByteString as B +import qualified Data.Map.Strict as M +import Data.Maybe (catMaybes) +import Data.String (IsString) +import Foreign.C.String (CString) +import Foreign.C.Types (CInt) +import Foreign.Marshal.Alloc (free, malloc, + mallocBytes) +import Foreign.Ptr (Ptr, nullPtr) +import Foreign.Storable (peek, poke) +import qualified Network.GRPC.Unsafe as C (Call) +import qualified Network.GRPC.Unsafe.ByteBuffer as C +import qualified Network.GRPC.Unsafe.Metadata as C +import qualified Network.GRPC.Unsafe.Op as C import Network.GRPC.LowLevel.Call +import Network.GRPC.LowLevel.Call.Unregistered import Network.GRPC.LowLevel.CompletionQueue import Network.GRPC.LowLevel.GRPC diff --git a/src/Network/GRPC/LowLevel/Server.hs b/src/Network/GRPC/LowLevel/Server.hs index 4c3bc74..6b269c3 100644 --- a/src/Network/GRPC/LowLevel/Server.hs +++ b/src/Network/GRPC/LowLevel/Server.hs @@ -2,41 +2,40 @@ module Network.GRPC.LowLevel.Server where -import Control.Concurrent (threadDelay) -import Control.Exception (bracket, finally) +import Control.Exception (bracket, finally) import Control.Monad -import Data.ByteString (ByteString) -import Foreign.Ptr (nullPtr) -import qualified Network.GRPC.Unsafe as C -import qualified Network.GRPC.Unsafe.Op as C +import Data.ByteString (ByteString) +import Foreign.Ptr (nullPtr) +import qualified Network.GRPC.Unsafe as C +import qualified Network.GRPC.Unsafe.Op as C import Network.GRPC.LowLevel.Call -import Network.GRPC.LowLevel.CompletionQueue (CompletionQueue, - TimeoutSeconds, - createCompletionQueue, - pluck, - serverRegisterCompletionQueue, - serverRequestCall, - serverRequestRegisteredCall, - serverShutdownAndNotify, - shutdownCompletionQueue) +import Network.GRPC.LowLevel.CompletionQueue (CompletionQueue, + TimeoutSeconds, + createCompletionQueue, + pluck, + serverRegisterCompletionQueue, + serverRequestCall, + serverRequestRegisteredCall, + serverShutdownAndNotify, + shutdownCompletionQueue) 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 + { internalServer :: C.Server + , serverCQ :: CompletionQueue , registeredMethods :: [RegisteredMethod] - , serverConfig :: ServerConfig + , serverConfig :: ServerConfig } -- | Configuration needed to start a server. data ServerConfig = ServerConfig - { host :: Host + { 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 :: Port -- ^ Port on which to listen for requests. , methodsToRegister :: [(MethodName, GRPCMethodType)] -- ^ List of (method name, method type) tuples specifying all methods to @@ -141,22 +140,6 @@ withServerRegisteredCall server regmethod timeout initMeta f = do where logDestroy c = grpcDebug "withServerRegisteredCall: destroying." >> destroyServerRegCall c -serverCreateUnregCall :: Server -> TimeoutSeconds - -> IO (Either GRPCIOError ServerUnregCall) -serverCreateUnregCall Server{..} timeLimit = - serverRequestCall internalServer serverCQ timeLimit - -withServerUnregCall :: Server -> TimeoutSeconds - -> (ServerUnregCall -> IO (Either GRPCIOError a)) - -> IO (Either GRPCIOError a) -withServerUnregCall server timeout f = do - createResult <- serverCreateUnregCall server timeout - case createResult of - Left x -> return $ Left x - Right call -> f call `finally` logDestroy call - where logDestroy c = grpcDebug "withServerCall: destroying." - >> destroyServerUnregCall c - -- | Sequence of 'Op's needed to receive a normal (non-streaming) call. serverOpsGetNormalCall :: MetadataMap -> [Op] serverOpsGetNormalCall initMetadata = @@ -230,43 +213,3 @@ serverHandleNormalRegisteredCall s@Server{..} rm timeLimit srvMetadata f = do case respOpsResults of Left x -> return $ Left x Right _ -> return $ Right () - --- TODO: This is preliminary. --- We still need to provide the method name to the handler. --- | Handle one unregistered call. -serverHandleNormalCall :: Server -> TimeoutSeconds - -> MetadataMap - -- ^ Initial server metadata. - -> (ByteString -> MetadataMap -> MethodName - -> IO (ByteString, MetadataMap, StatusDetails)) - -- ^ Handler function takes a request body and - -- metadata and returns a response body and metadata. - -> IO (Either GRPCIOError ()) -serverHandleNormalCall s@Server{..} timeLimit srvMetadata f = do - withServerUnregCall s timeLimit $ \call -> do - grpcDebug "serverHandleNormalCall: starting batch." - let recvOps = serverOpsGetNormalCall srvMetadata - opResults <- runServerUnregOps call serverCQ recvOps timeLimit - case opResults of - Left x -> do grpcDebug "serverHandleNormalCall: ops failed; aborting" - return $ Left x - Right [OpRecvMessageResult (Just body)] -> do - requestMeta <- serverUnregCallGetMetadata call - grpcDebug $ "got client metadata: " ++ show requestMeta - methodName <- serverUnregCallGetMethodName call - hostName <- serverUnregCallGetHost call - grpcDebug $ "call_details host is: " ++ show hostName - (respBody, respMetadata, details) <- f body requestMeta methodName - let status = C.GrpcStatusOk - let respOps = serverOpsSendNormalResponse - respBody respMetadata status details - respOpsResults <- runServerUnregOps call serverCQ respOps timeLimit - case respOpsResults of - Left x -> do grpcDebug "serverHandleNormalCall: resp failed." - return $ Left x - Right _ -> grpcDebug "serverHandleNormalCall: ops done." - >> return (Right ()) - x -> error $ "impossible pattern match: " ++ show x - -_nowarn_unused :: a -_nowarn_unused = undefined threadDelay diff --git a/src/Network/GRPC/LowLevel/Server/Unregistered.hs b/src/Network/GRPC/LowLevel/Server/Unregistered.hs new file mode 100644 index 0000000..d9bcb0c --- /dev/null +++ b/src/Network/GRPC/LowLevel/Server/Unregistered.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE RecordWildCards #-} + +module Network.GRPC.LowLevel.Server.Unregistered where + +import Control.Exception (bracket, finally) +import Control.Monad +import Data.ByteString (ByteString) +import Foreign.Ptr (nullPtr) +import qualified Network.GRPC.Unsafe as C +import qualified Network.GRPC.Unsafe.Op as C + +import Network.GRPC.LowLevel.Call +import Network.GRPC.LowLevel.Call.Unregistered +import Network.GRPC.LowLevel.CompletionQueue (CompletionQueue, + TimeoutSeconds, + createCompletionQueue, + pluck, + serverRegisterCompletionQueue, + serverRequestCall, + serverRequestRegisteredCall, + serverShutdownAndNotify, + shutdownCompletionQueue) +import Network.GRPC.LowLevel.GRPC +import Network.GRPC.LowLevel.Op +import Network.GRPC.LowLevel.Server + +serverCreateUnregCall :: Server -> TimeoutSeconds + -> IO (Either GRPCIOError ServerUnregCall) +serverCreateUnregCall Server{..} timeLimit = + serverRequestCall internalServer serverCQ timeLimit + +withServerUnregCall :: Server -> TimeoutSeconds + -> (ServerUnregCall -> IO (Either GRPCIOError a)) + -> IO (Either GRPCIOError a) +withServerUnregCall server timeout f = do + createResult <- serverCreateUnregCall server timeout + case createResult of + Left x -> return $ Left x + Right call -> f call `finally` logDestroy call + where logDestroy c = grpcDebug "withServerCall: destroying." + >> destroyServerUnregCall c + +-- TODO: This is preliminary. +-- We still need to provide the method name to the handler. +-- | Handle one unregistered call. +serverHandleNormalCall :: Server -> TimeoutSeconds + -> MetadataMap + -- ^ Initial server metadata. + -> (ByteString -> MetadataMap -> MethodName + -> IO (ByteString, MetadataMap, StatusDetails)) + -- ^ Handler function takes a request body and + -- metadata and returns a response body and metadata. + -> IO (Either GRPCIOError ()) +serverHandleNormalCall s@Server{..} timeLimit srvMetadata f = do + withServerUnregCall s timeLimit $ \call -> do + grpcDebug "serverHandleNormalCall: starting batch." + let recvOps = serverOpsGetNormalCall srvMetadata + opResults <- runServerUnregOps call serverCQ recvOps timeLimit + case opResults of + Left x -> do grpcDebug "serverHandleNormalCall: ops failed; aborting" + return $ Left x + Right [OpRecvMessageResult (Just body)] -> do + requestMeta <- serverUnregCallGetMetadata call + grpcDebug $ "got client metadata: " ++ show requestMeta + methodName <- serverUnregCallGetMethodName call + hostName <- serverUnregCallGetHost call + grpcDebug $ "call_details host is: " ++ show hostName + (respBody, respMetadata, details) <- f body requestMeta methodName + let status = C.GrpcStatusOk + let respOps = serverOpsSendNormalResponse + respBody respMetadata status details + respOpsResults <- runServerUnregOps call serverCQ respOps timeLimit + case respOpsResults of + Left x -> do grpcDebug "serverHandleNormalCall: resp failed." + return $ Left x + Right _ -> grpcDebug "serverHandleNormalCall: ops done." + >> return (Right ()) + x -> error $ "impossible pattern match: " ++ show x