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:
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.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:
|
||||||
|
|
|
@ -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(..))
|
||||||
|
|
|
@ -1,6 +1,9 @@
|
||||||
{-# 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
|
||||||
|
@ -11,11 +14,11 @@ 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
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
|
|
@ -7,13 +7,13 @@ 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.
|
||||||
|
@ -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
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
|
|
@ -26,11 +26,14 @@ 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',
|
||||||
|
newTVarIO, readTVar,
|
||||||
|
writeTVar)
|
||||||
import Control.Exception (bracket)
|
import Control.Exception (bracket)
|
||||||
import Data.IORef (IORef, atomicModifyIORef',
|
import Data.IORef (IORef,
|
||||||
|
atomicModifyIORef',
|
||||||
newIORef)
|
newIORef)
|
||||||
import Data.List (intersperse)
|
import Data.List (intersperse)
|
||||||
import Foreign.Marshal.Alloc (free, malloc)
|
import Foreign.Marshal.Alloc (free, malloc)
|
||||||
|
@ -44,6 +47,7 @@ import qualified Network.GRPC.Unsafe.Time as C
|
||||||
import System.Timeout (timeout)
|
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
|
||||||
|
|
|
@ -20,6 +20,7 @@ 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
|
||||||
|
|
||||||
|
|
|
@ -2,7 +2,6 @@
|
||||||
|
|
||||||
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)
|
||||||
|
@ -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
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