mirror of
https://github.com/unclechu/gRPC-haskell.git
synced 2024-11-26 21:19:43 +01:00
Split off support for unregistered calls to an *.Unregistered module namespace
This commit is contained in:
Joel Stanley
parent
2119ef4b16
commit
386568463a
10 changed files with 305 additions and 236 deletions
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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(..))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
75
src/Network/GRPC/LowLevel/Call/Unregistered.hs
Normal file
75
src/Network/GRPC/LowLevel/Call/Unregistered.hs
Normal 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
|
||||
|
|
@ -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,
|
||||
|
|
|
|||
66
src/Network/GRPC/LowLevel/Client/Unregistered.hs
Normal file
66
src/Network/GRPC/LowLevel/Client/Unregistered.hs
Normal 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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
78
src/Network/GRPC/LowLevel/Server/Unregistered.hs
Normal file
78
src/Network/GRPC/LowLevel/Server/Unregistered.hs
Normal 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
|
||||
Loading…
Reference in a new issue