eeva/gRPC-haskell
1
0
Fork 0
mirror of https://github.com/unclechu/gRPC-haskell.git synced 2024-11-26 21:19:43 +01:00
Code Issues Projects Releases Wiki Activity

Split off support for unregistered calls to an *.Unregistered module namespace

Browse source
This commit is contained in:
Joel Stanley 2016-06-08 11:18:43 -05:00
parent 2119ef4b16
commit 386568463a
10 changed files with 305 additions and 236 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
grpc-haskell.cabal
View file

@ -47,8 +47,11 @@ library
Network.GRPC.LowLevel.GRPC Network.GRPC.LowLevel.GRPC
Network.GRPC.LowLevel.Op Network.GRPC.LowLevel.Op
Network.GRPC.LowLevel.Server Network.GRPC.LowLevel.Server
Network.GRPC.LowLevel.Server.Unregistered
Network.GRPC.LowLevel.Call Network.GRPC.LowLevel.Call
Network.GRPC.LowLevel.Call.Unregistered
Network.GRPC.LowLevel.Client Network.GRPC.LowLevel.Client
Network.GRPC.LowLevel.Client.Unregistered
extra-libraries: extra-libraries:
grpc grpc
includes: includes:

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

@ -61,10 +61,13 @@ GRPC
import Network.GRPC.LowLevel.GRPC import Network.GRPC.LowLevel.GRPC
import Network.GRPC.LowLevel.Server import Network.GRPC.LowLevel.Server
import Network.GRPC.LowLevel.Server.Unregistered
import Network.GRPC.LowLevel.CompletionQueue import Network.GRPC.LowLevel.CompletionQueue
import Network.GRPC.LowLevel.Op import Network.GRPC.LowLevel.Op
import Network.GRPC.LowLevel.Client import Network.GRPC.LowLevel.Client
import Network.GRPC.LowLevel.Client.Unregistered
import Network.GRPC.LowLevel.Call import Network.GRPC.LowLevel.Call
import Network.GRPC.LowLevel.Call.Unregistered
import Network.GRPC.Unsafe (ConnectivityState(..)) import Network.GRPC.Unsafe (ConnectivityState(..))
import Network.GRPC.Unsafe.Op (StatusCode(..)) import Network.GRPC.Unsafe.Op (StatusCode(..))

81
src/Network/GRPC/LowLevel/Call.hs
View file

@ -1,21 +1,24 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# 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 module Network.GRPC.LowLevel.Call where
import Control.Monad import Control.Monad
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.String (IsString) import Data.String (IsString)
import Foreign.Marshal.Alloc (free) import Foreign.Marshal.Alloc (free)
import Foreign.Ptr (Ptr, nullPtr) import Foreign.Ptr (Ptr, nullPtr)
import Foreign.Storable (peek) import Foreign.Storable (peek)
import qualified Network.GRPC.Unsafe as C 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.ByteBuffer 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 -- | Models the four types of RPC call supported by gRPC. We currently only
-- support the first alternative, and only in a preliminary fashion. -- support the first alternative, and only in a preliminary fashion.
@ -82,28 +85,6 @@ serverRegCallGetPayload ServerRegCall{..} = do
then return Nothing then return Nothing
else Just <$> C.copyByteBufferToByteString bb 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 () debugClientCall :: ClientCall -> IO ()
{-# INLINE debugClientCall #-} {-# INLINE debugClientCall #-}
#ifdef DEBUG #ifdef DEBUG
@ -138,28 +119,6 @@ debugServerRegCall call@(ServerRegCall (C.Call ptr) _ _ _ _) = do
debugServerRegCall = const $ return () debugServerRegCall = const $ return ()
#endif #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 -> IO ()
destroyClientCall ClientCall{..} = do destroyClientCall ClientCall{..} = do
grpcDebug "Destroying client-side call object." grpcDebug "Destroying client-side call object."
@ -180,17 +139,3 @@ destroyServerRegCall call@ServerRegCall{..} = do
forM_ parentPtrReg free forM_ parentPtrReg free
grpcDebug $ "destroying deadline." ++ show callDeadline grpcDebug $ "destroying deadline." ++ show callDeadline
C.timespecDestroy 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

75
src/Network/GRPC/LowLevel/Call/Unregistered.hs Normal file
View file

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

73
src/Network/GRPC/LowLevel/Client.hs
View file

@ -2,24 +2,24 @@
module Network.GRPC.LowLevel.Client where module Network.GRPC.LowLevel.Client where
import Control.Exception (bracket, finally) import Control.Exception (bracket, finally)
import Control.Monad (join) import Control.Monad (join)
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Foreign.Ptr (nullPtr) import Foreign.Ptr (nullPtr)
import qualified Network.GRPC.Unsafe as C 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.Constants as C import qualified Network.GRPC.Unsafe.Op 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.Call
import Network.GRPC.LowLevel.CompletionQueue
import Network.GRPC.LowLevel.GRPC
import Network.GRPC.LowLevel.Op import Network.GRPC.LowLevel.Op
-- | Represents the context needed to perform client-side gRPC operations. -- | Represents the context needed to perform client-side gRPC operations.
data Client = Client {clientChannel :: C.Channel, data Client = Client {clientChannel :: C.Channel,
clientCQ :: CompletionQueue, clientCQ :: CompletionQueue,
clientConfig :: ClientConfig clientConfig :: ClientConfig
} }
-- | Configuration necessary to set up a client. -- | Configuration necessary to set up a client.
@ -94,32 +94,6 @@ withClientRegisteredCall client regmethod timeout f = do
where logDestroy c = grpcDebug "withClientRegisteredCall: destroying." where logDestroy c = grpcDebug "withClientRegisteredCall: destroying."
>> destroyClientCall c >> 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 data NormalRequestResult = NormalRequestResult
{ rspBody :: ByteString { rspBody :: ByteString
, initMD :: Maybe MetadataMap -- initial metadata , initMD :: Maybe MetadataMap -- initial metadata
@ -196,29 +170,6 @@ clientRegisteredRequest client@(Client{..}) rm@(RegisteredMethod{..})
return $ Right $ compileNormalRequestResults (rs ++ rs') return $ Right $ compileNormalRequestResults (rs ++ rs')
_ -> error "Streaming methods not yet implemented." _ -> 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 :: ByteString -> MetadataMap -> [Op]
clientNormalRequestOps body metadata = clientNormalRequestOps body metadata =
[OpSendInitialMetadata metadata, [OpSendInitialMetadata metadata,

66
src/Network/GRPC/LowLevel/Client/Unregistered.hs Normal file
View file

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

38
src/Network/GRPC/LowLevel/CompletionQueue.hs
View file

@ -25,25 +25,29 @@ module Network.GRPC.LowLevel.CompletionQueue
) )
where where
import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.STM (atomically, check, retry) import Control.Concurrent.STM (atomically, check,
import Control.Concurrent.STM.TVar (TVar, modifyTVar', newTVarIO, retry)
readTVar, writeTVar) import Control.Concurrent.STM.TVar (TVar, modifyTVar',
import Control.Exception (bracket) newTVarIO, readTVar,
import Data.IORef (IORef, atomicModifyIORef', writeTVar)
newIORef) import Control.Exception (bracket)
import Data.List (intersperse) import Data.IORef (IORef,
import Foreign.Marshal.Alloc (free, malloc) atomicModifyIORef',
import Foreign.Ptr (nullPtr, plusPtr) newIORef)
import Foreign.Storable (peek) import Data.List (intersperse)
import qualified Network.GRPC.Unsafe as C import Foreign.Marshal.Alloc (free, malloc)
import qualified Network.GRPC.Unsafe.Constants as C import Foreign.Ptr (nullPtr, plusPtr)
import qualified Network.GRPC.Unsafe.Metadata as C import Foreign.Storable (peek)
import qualified Network.GRPC.Unsafe.Op as C import qualified Network.GRPC.Unsafe as C
import qualified Network.GRPC.Unsafe.Time as C import qualified Network.GRPC.Unsafe.Constants as C
import System.Timeout (timeout) 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
import Network.GRPC.LowLevel.Call.Unregistered
import Network.GRPC.LowLevel.GRPC import Network.GRPC.LowLevel.GRPC
-- NOTE: the concurrency requirements for a CompletionQueue are a little -- NOTE: the concurrency requirements for a CompletionQueue are a little

29
src/Network/GRPC/LowLevel/Op.hs
View file

@ -4,22 +4,23 @@
module Network.GRPC.LowLevel.Op where module Network.GRPC.LowLevel.Op where
import Control.Exception import Control.Exception
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Data.Maybe (catMaybes) import Data.Maybe (catMaybes)
import Data.String (IsString) import Data.String (IsString)
import Foreign.C.String (CString) import Foreign.C.String (CString)
import Foreign.C.Types (CInt) import Foreign.C.Types (CInt)
import Foreign.Marshal.Alloc (free, malloc, import Foreign.Marshal.Alloc (free, malloc,
mallocBytes) mallocBytes)
import Foreign.Ptr (Ptr, nullPtr) import Foreign.Ptr (Ptr, nullPtr)
import Foreign.Storable (peek, poke) import Foreign.Storable (peek, poke)
import qualified Network.GRPC.Unsafe as C (Call) import qualified Network.GRPC.Unsafe as C (Call)
import qualified Network.GRPC.Unsafe.ByteBuffer as C import qualified Network.GRPC.Unsafe.ByteBuffer as C
import qualified Network.GRPC.Unsafe.Metadata as C import qualified Network.GRPC.Unsafe.Metadata as C
import qualified Network.GRPC.Unsafe.Op as C import qualified Network.GRPC.Unsafe.Op as C
import Network.GRPC.LowLevel.Call import Network.GRPC.LowLevel.Call
import Network.GRPC.LowLevel.Call.Unregistered
import Network.GRPC.LowLevel.CompletionQueue import Network.GRPC.LowLevel.CompletionQueue
import Network.GRPC.LowLevel.GRPC import Network.GRPC.LowLevel.GRPC

95
src/Network/GRPC/LowLevel/Server.hs
View file

@ -2,41 +2,40 @@
module Network.GRPC.LowLevel.Server where module Network.GRPC.LowLevel.Server where
import Control.Concurrent (threadDelay) import Control.Exception (bracket, finally)
import Control.Exception (bracket, finally)
import Control.Monad import Control.Monad
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Foreign.Ptr (nullPtr) import Foreign.Ptr (nullPtr)
import qualified Network.GRPC.Unsafe as C import qualified Network.GRPC.Unsafe as C
import qualified Network.GRPC.Unsafe.Op as C import qualified Network.GRPC.Unsafe.Op as C
import Network.GRPC.LowLevel.Call import Network.GRPC.LowLevel.Call
import Network.GRPC.LowLevel.CompletionQueue (CompletionQueue, import Network.GRPC.LowLevel.CompletionQueue (CompletionQueue,
TimeoutSeconds, TimeoutSeconds,
createCompletionQueue, createCompletionQueue,
pluck, pluck,
serverRegisterCompletionQueue, serverRegisterCompletionQueue,
serverRequestCall, serverRequestCall,
serverRequestRegisteredCall, serverRequestRegisteredCall,
serverShutdownAndNotify, serverShutdownAndNotify,
shutdownCompletionQueue) shutdownCompletionQueue)
import Network.GRPC.LowLevel.GRPC import Network.GRPC.LowLevel.GRPC
import Network.GRPC.LowLevel.Op import Network.GRPC.LowLevel.Op
-- | Wraps various gRPC state needed to run a server. -- | Wraps various gRPC state needed to run a server.
data Server = Server data Server = Server
{ internalServer :: C.Server { internalServer :: C.Server
, serverCQ :: CompletionQueue , serverCQ :: CompletionQueue
, registeredMethods :: [RegisteredMethod] , registeredMethods :: [RegisteredMethod]
, serverConfig :: ServerConfig , serverConfig :: ServerConfig
} }
-- | Configuration needed to start a server. -- | Configuration needed to start a server.
data ServerConfig = ServerConfig data ServerConfig = ServerConfig
{ host :: Host { host :: Host
-- ^ Name of the host the server is running on. Not sure how this is -- ^ Name of the host the server is running on. Not sure how this is
-- used. Setting to "localhost" works fine in tests. -- used. Setting to "localhost" works fine in tests.
, port :: Port , port :: Port
-- ^ Port on which to listen for requests. -- ^ Port on which to listen for requests.
, methodsToRegister :: [(MethodName, GRPCMethodType)] , methodsToRegister :: [(MethodName, GRPCMethodType)]
-- ^ List of (method name, method type) tuples specifying all methods to -- ^ 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." where logDestroy c = grpcDebug "withServerRegisteredCall: destroying."
>> destroyServerRegCall c >> 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. -- | Sequence of 'Op's needed to receive a normal (non-streaming) call.
serverOpsGetNormalCall :: MetadataMap -> [Op] serverOpsGetNormalCall :: MetadataMap -> [Op]
serverOpsGetNormalCall initMetadata = serverOpsGetNormalCall initMetadata =
@ -230,43 +213,3 @@ serverHandleNormalRegisteredCall s@Server{..} rm timeLimit srvMetadata f = do
case respOpsResults of case respOpsResults of
Left x -> return $ Left x Left x -> return $ Left x
Right _ -> return $ Right () 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

78
src/Network/GRPC/LowLevel/Server/Unregistered.hs Normal file
View file

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