eeva/gRPC-haskell
1
0
Fork 0
mirror of https://github.com/unclechu/gRPC-haskell.git synced 2024-11-23 03:29:42 +01:00
Code Issues Projects Releases Wiki Activity

Streaming interface tweaks (i.e., StreamSend/Recv ops in IO) (#58)

Browse source 
* Add clientRW', StreamRecv', StreamSend' placeholders for IO-based stream ops (instead of Streaming); concurrent hellos Haskell client; hellos client cleanup

* Fix typo

* Rename clientRW' => clientRW; fix unreg bidi testcase

* Replace serverRW operation with one that uses the IO-based stream ops instead of the Pipes.Proxy.Client ops; modify examples accordingly

* Misc formatting, minor restructuring wibbles

* Replace remaining stream send/recv operations with IO-based ops instead of
Pipes.Proxy.Client; DCR; minor style consistency tweaks.
This commit is contained in:
Joel Stanley 2016-08-09 11:30:47 -05:00
parent d66a4f98b3
commit 9408745254
11 changed files with 290 additions and 340 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
README.md
View file

@ -7,7 +7,7 @@ In order to run the tests, you will need to have the `grpcio`, `gevent`, and
``` ```
$ virtualenv path/to/virtualenv # to create a virtualenv $ virtualenv path/to/virtualenv # to create a virtualenv
$ . path/to/virtual/env/bin/activate # to use an existing virtualenv $ . path/to/virtualenv/bin/activate # to use an existing virtualenv
$ pip install grpcio-tools gevent $ pip install grpcio-tools gevent
$ pip install grpcio # Need to install grpcio-tools first to avoid a versioning problem $ pip install grpcio # Need to install grpcio-tools first to avoid a versioning problem
``` ```

93
examples/hellos/hellos-client/Main.hs
View file

@ -3,19 +3,22 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
{-# OPTIONS_GHC -fno-warn-unused-binds #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-}
import Control.Concurrent.Async
import Control.Monad import Control.Monad
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import Data.Function
import Data.Protobuf.Wire.Class import Data.Protobuf.Wire.Class
import qualified Data.Text as T import qualified Data.Text as T
import Data.Word import Data.Word
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Network.GRPC.LowLevel import Network.GRPC.LowLevel
helloSS, helloCS, helloBi :: MethodName
helloSS = MethodName "/hellos.Hellos/HelloSS" helloSS = MethodName "/hellos.Hellos/HelloSS"
helloCS = MethodName "/hellos.Hellos/HelloCS" helloCS = MethodName "/hellos.Hellos/HelloCS"
helloBi = MethodName "/hellos.Hellos/HelloBi"
data SSRqt = SSRqt { ssName :: T.Text, ssNumReplies :: Word32 } deriving (Show, Eq, Ord, Generic) data SSRqt = SSRqt { ssName :: T.Text, ssNumReplies :: Word32 } deriving (Show, Eq, Ord, Generic)
instance Message SSRqt instance Message SSRqt
@ -25,43 +28,43 @@ data CSRqt = CSRqt { csMessage :: T.Text } deriving (Show, Eq, Ord, Generic)
instance Message CSRqt instance Message CSRqt
data CSRpy = CSRpy { csNumRequests :: Word32 } deriving (Show, Eq, Ord, Generic) data CSRpy = CSRpy { csNumRequests :: Word32 } deriving (Show, Eq, Ord, Generic)
instance Message CSRpy instance Message CSRpy
data BiRqtRpy = BiRqtRpy { biMessage :: T.Text } deriving (Show, Eq, Ord, Generic)
instance Message BiRqtRpy
expect :: (Eq a, Monad m, Show a) => String -> a -> a -> m () expect :: (Eq a, Monad m, Show a) => String -> a -> a -> m ()
expect ctx ex got expect ctx ex got
| ex /= got = fail $ ctx ++ " error: expected " ++ show ex ++ ", got " ++ show got | ex /= got = fail $ ctx ++ " error: expected " ++ show ex ++ ", got " ++ show got
| otherwise = return () | otherwise = return ()
doHelloSS c = do doHelloSS :: Client -> Int -> IO ()
doHelloSS c n = do
rm <- clientRegisterMethodServerStreaming c helloSS rm <- clientRegisterMethodServerStreaming c helloSS
let nr = 10 let pay = SSRqt "server streaming mode" (fromIntegral n)
pay = SSRqt "server streaming mode" nr enc = BL.toStrict . toLazyByteString $ pay
enc = BL.toStrict . toLazyByteString $ pay err desc e = fail $ "doHelloSS: " ++ desc ++ " error: " ++ show e
eea <- clientReader c rm 5 enc mempty $ \_md recv -> do eea <- clientReader c rm n enc mempty $ \_md recv -> do
n :: Int <- go recv 0 n' <- flip fix (0::Int) $ \go i -> recv >>= \case
expect "doHelloSS/cnt" (fromIntegral nr) n Left e -> err "recv" e
Right Nothing -> return i
Right (Just bs) -> case fromByteString bs of
Left e -> err "decoding" e
Right r -> expect "doHelloSS/rpy" expay (ssGreeting r) >> go (i+1)
expect "doHelloSS/cnt" n n'
case eea of case eea of
Left e -> fail $ "clientReader error: " ++ show e Left e -> err "clientReader" e
Right (_, st, _) Right (_, st, _)
| st /= StatusOk -> fail "clientReader: non-OK status" | st /= StatusOk -> fail "clientReader: non-OK status"
| otherwise -> return () | otherwise -> putStrLn "doHelloSS: RPC successful"
where where
expay = "Hello there, server streaming mode!" expay = "Hello there, server streaming mode!"
go recv n = recv >>= \case
Left e -> fail $ "doHelloSS error: " ++ show e
Right Nothing -> return n
Right (Just r) -> case fromByteString r of
Left e -> fail $ "Decoding error: " ++ show e
Right r' -> do
expect "doHelloSS/rpy" expay (ssGreeting r')
go recv (n+1)
doHelloCS c = do doHelloCS :: Client -> Int -> IO ()
doHelloCS c n = do
rm <- clientRegisterMethodClientStreaming c helloCS rm <- clientRegisterMethodClientStreaming c helloCS
let nr = 10 let pay = CSRqt "client streaming payload"
pay = CSRqt "client streaming payload"
enc = BL.toStrict . toLazyByteString $ pay enc = BL.toStrict . toLazyByteString $ pay
eea <- clientWriter c rm 10 mempty $ \send -> eea <- clientWriter c rm n mempty $ \send ->
replicateM_ (fromIntegral nr) $ send enc >>= \case replicateM_ n $ send enc >>= \case
Left e -> fail $ "doHelloCS: send error: " ++ show e Left e -> fail $ "doHelloCS: send error: " ++ show e
Right{} -> return () Right{} -> return ()
case eea of case eea of
@ -71,11 +74,49 @@ doHelloCS c = do
| st /= StatusOk -> fail "clientWriter: non-OK status" | st /= StatusOk -> fail "clientWriter: non-OK status"
| otherwise -> case fromByteString bs of | otherwise -> case fromByteString bs of
Left e -> fail $ "Decoding error: " ++ show e Left e -> fail $ "Decoding error: " ++ show e
Right dec -> expect "doHelloCS/cnt" nr (csNumRequests dec) Right dec -> do
expect "doHelloCS/cnt" (fromIntegral n) (csNumRequests dec)
putStrLn "doHelloCS: RPC successful"
doHelloBi :: Client -> Int -> IO ()
doHelloBi c n = do
rm <- clientRegisterMethodBiDiStreaming c helloBi
let pay = BiRqtRpy "bidi payload"
enc = BL.toStrict . toLazyByteString $ pay
err desc e = fail $ "doHelloBi: " ++ desc ++ " error: " ++ show e
eea <- clientRW c rm n mempty $ \_ recv send writesDone -> do
-- perform n writes on a worker thread
thd <- async $ do
replicateM_ n $ send enc >>= \case
Left e -> err "send" e
_ -> return ()
writesDone >>= \case
Left e -> err "writesDone" e
_ -> return ()
-- perform reads on this thread until the stream is terminated
fix $ \go -> recv >>= \case
Left e -> err "recv" e
Right Nothing -> return ()
Right (Just bs) -> case fromByteString bs of
Left e -> err "decoding" e
Right r -> when (r /= pay) (fail "Reply payload mismatch") >> go
wait thd
case eea of
Left e -> err "clientRW'" e
Right (_, st, _) -> do
when (st /= StatusOk) $ fail $ "clientRW: non-OK status: " ++ show st
putStrLn "doHelloBi: RPC successful"
highlevelMain :: IO ()
highlevelMain = withGRPC $ \g -> highlevelMain = withGRPC $ \g ->
withClient g (ClientConfig "localhost" 50051 []) $ \c -> do withClient g (ClientConfig "localhost" 50051 []) $ \c -> do
doHelloSS c let n = 100000
doHelloCS c putStrLn "-------------- HelloSS --------------"
doHelloSS c n
putStrLn "-------------- HelloCS --------------"
doHelloCS c n
putStrLn "-------------- HelloBi --------------"
doHelloBi c n
main :: IO ()
main = highlevelMain main = highlevelMain

127
src/Network/GRPC/HighLevel/Server.hs
View file

@ -8,19 +8,16 @@
module Network.GRPC.HighLevel.Server where module Network.GRPC.HighLevel.Server where
import Control.Concurrent.Async
import qualified Control.Exception as CE import qualified Control.Exception as CE
import Control.Monad import Control.Monad
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import Data.Protobuf.Wire.Class import Data.Protobuf.Wire.Class
import Network.GRPC.LowLevel import Network.GRPC.LowLevel
import qualified Network.GRPC.LowLevel.Call.Unregistered as U
import qualified Network.GRPC.LowLevel.Server.Unregistered as U
import System.IO import System.IO
type ServerHandler a b = type ServerHandler a b
ServerCall a = ServerCall a
-> IO (b, MetadataMap, StatusCode, StatusDetails) -> IO (b, MetadataMap, StatusCode, StatusDetails)
convertServerHandler :: (Message a, Message b) convertServerHandler :: (Message a, Message b)
@ -28,48 +25,45 @@ convertServerHandler :: (Message a, Message b)
-> ServerHandlerLL -> ServerHandlerLL
convertServerHandler f c = case fromByteString (payload c) of convertServerHandler f c = case fromByteString (payload c) of
Left x -> CE.throw (GRPCIODecodeError x) Left x -> CE.throw (GRPCIODecodeError x)
Right x -> do (y, tm, sc, sd) <- f (fmap (const x) c) Right x -> do (y, tm, sc, sd) <- f (const x <$> c)
return (toBS y, tm, sc, sd) return (toBS y, tm, sc, sd)
type ServerReaderHandler a b = type ServerReaderHandler a b
ServerCall () = ServerCall (MethodPayload 'ClientStreaming)
-> StreamRecv a -> StreamRecv a
-> Streaming (Maybe b, MetadataMap, StatusCode, StatusDetails) -> IO (Maybe b, MetadataMap, StatusCode, StatusDetails)
convertServerReaderHandler :: (Message a, Message b) convertServerReaderHandler :: (Message a, Message b)
=> ServerReaderHandler a b => ServerReaderHandler a b
-> ServerReaderHandlerLL -> ServerReaderHandlerLL
convertServerReaderHandler f c recv = convertServerReaderHandler f c recv = serialize <$> f c (convertRecv recv)
serialize <$> f c (convertRecv recv)
where where
serialize (mmsg, m, sc, sd) = (toBS <$> mmsg, m, sc, sd) serialize (mmsg, m, sc, sd) = (toBS <$> mmsg, m, sc, sd)
type ServerWriterHandler a b = type ServerWriterHandler a b =
ServerCall a ServerCall a
-> StreamSend b -> StreamSend b
-> Streaming (MetadataMap, StatusCode, StatusDetails) -> IO (MetadataMap, StatusCode, StatusDetails)
convertServerWriterHandler :: (Message a, Message b) => convertServerWriterHandler :: (Message a, Message b)
ServerWriterHandler a b => ServerWriterHandler a b
-> ServerWriterHandlerLL -> ServerWriterHandlerLL
convertServerWriterHandler f c send = convertServerWriterHandler f c send = f (convert <$> c) (convertSend send)
f (convert <$> c) (convertSend send)
where where
convert bs = case fromByteString bs of convert bs = case fromByteString bs of
Left x -> CE.throw (GRPCIODecodeError x) Left x -> CE.throw (GRPCIODecodeError x)
Right x -> x Right x -> x
type ServerRWHandler a b = type ServerRWHandler a b
ServerCall () = ServerCall (MethodPayload 'BiDiStreaming)
-> StreamRecv a -> StreamRecv a
-> StreamSend b -> StreamSend b
-> Streaming (MetadataMap, StatusCode, StatusDetails) -> IO (MetadataMap, StatusCode, StatusDetails)
convertServerRWHandler :: (Message a, Message b) convertServerRWHandler :: (Message a, Message b)
=> ServerRWHandler a b => ServerRWHandler a b
-> ServerRWHandlerLL -> ServerRWHandlerLL
convertServerRWHandler f c recv send = convertServerRWHandler f c r s = f c (convertRecv r) (convertSend s)
f c (convertRecv recv) (convertSend send)
convertRecv :: Message a => StreamRecv ByteString -> StreamRecv a convertRecv :: Message a => StreamRecv ByteString -> StreamRecv a
convertRecv = convertRecv =
@ -88,40 +82,21 @@ toBS :: Message a => a -> ByteString
toBS = BL.toStrict . toLazyByteString toBS = BL.toStrict . toLazyByteString
data Handler (a :: GRPCMethodType) where data Handler (a :: GRPCMethodType) where
UnaryHandler UnaryHandler :: (Message c, Message d) => MethodName -> ServerHandler c d -> Handler 'Normal
:: (Message c, Message d) ClientStreamHandler :: (Message c, Message d) => MethodName -> ServerReaderHandler c d -> Handler 'ClientStreaming
=> MethodName ServerStreamHandler :: (Message c, Message d) => MethodName -> ServerWriterHandler c d -> Handler 'ServerStreaming
-> ServerHandler c d BiDiStreamHandler :: (Message c, Message d) => MethodName -> ServerRWHandler c d -> Handler 'BiDiStreaming
-> Handler 'Normal
ClientStreamHandler data AnyHandler = forall (a :: GRPCMethodType). AnyHandler (Handler a)
:: (Message c, Message d)
=> MethodName
-> ServerReaderHandler c d
-> Handler 'ClientStreaming
ServerStreamHandler
:: (Message c, Message d)
=> MethodName
-> ServerWriterHandler c d
-> Handler 'ServerStreaming
BiDiStreamHandler
:: (Message c, Message d)
=> MethodName
-> ServerRWHandler c d
-> Handler 'BiDiStreaming
data AnyHandler = forall (a :: GRPCMethodType) . AnyHandler (Handler a)
anyHandlerMethodName :: AnyHandler -> MethodName anyHandlerMethodName :: AnyHandler -> MethodName
anyHandlerMethodName (AnyHandler m) = handlerMethodName m anyHandlerMethodName (AnyHandler m) = handlerMethodName m
handlerMethodName :: Handler a -> MethodName handlerMethodName :: Handler a -> MethodName
handlerMethodName (UnaryHandler m _) = m handlerMethodName (UnaryHandler m _) = m
handlerMethodName (ClientStreamHandler m _) = m handlerMethodName (ClientStreamHandler m _) = m
handlerMethodName (ServerStreamHandler m _) = m handlerMethodName (ServerStreamHandler m _) = m
handlerMethodName (BiDiStreamHandler m _) = m handlerMethodName (BiDiStreamHandler m _) = m
logMsg :: String -> IO () logMsg :: String -> IO ()
logMsg = hPutStrLn stderr logMsg = hPutStrLn stderr
@ -146,17 +121,17 @@ handleCallError (Left x) =
logMsg $ show x ++ ": This probably indicates a bug in gRPC-haskell. Please report this error." logMsg $ show x ++ ": This probably indicates a bug in gRPC-haskell. Please report this error."
loopWError :: Int loopWError :: Int
-> IO (Either GRPCIOError a) -> IO (Either GRPCIOError a)
-> IO () -> IO ()
loopWError i f = do loopWError i f = do
when (i `mod` 100 == 0) $ putStrLn $ "i = " ++ show i when (i `mod` 100 == 0) $ putStrLn $ "i = " ++ show i
f >>= handleCallError f >>= handleCallError
loopWError (i + 1) f loopWError (i + 1) f
--TODO: options for setting initial/trailing metadata -- TODO: options for setting initial/trailing metadata
handleLoop :: Server handleLoop :: Server
-> (Handler a, RegisteredMethod a) -> (Handler a, RegisteredMethod a)
-> IO () -> IO ()
handleLoop s (UnaryHandler _ f, rm) = handleLoop s (UnaryHandler _ f, rm) =
loopWError 0 $ serverHandleNormalCall s rm mempty $ convertServerHandler f loopWError 0 $ serverHandleNormalCall s rm mempty $ convertServerHandler f
handleLoop s (ClientStreamHandler _ f, rm) = handleLoop s (ClientStreamHandler _ f, rm) =
@ -167,30 +142,33 @@ handleLoop s (BiDiStreamHandler _ f, rm) =
loopWError 0 $ serverRW s rm mempty $ convertServerRWHandler f loopWError 0 $ serverRW s rm mempty $ convertServerRWHandler f
data ServerOptions = ServerOptions data ServerOptions = ServerOptions
{optNormalHandlers :: [Handler 'Normal], { optNormalHandlers :: [Handler 'Normal]
optClientStreamHandlers :: [Handler 'ClientStreaming], , optClientStreamHandlers :: [Handler 'ClientStreaming]
optServerStreamHandlers :: [Handler 'ServerStreaming], , optServerStreamHandlers :: [Handler 'ServerStreaming]
optBiDiStreamHandlers :: [Handler 'BiDiStreaming], , optBiDiStreamHandlers :: [Handler 'BiDiStreaming]
optServerPort :: Port, , optServerPort :: Port
optUseCompression :: Bool, , optUseCompression :: Bool
optUserAgentPrefix :: String, , optUserAgentPrefix :: String
optUserAgentSuffix :: String, , optUserAgentSuffix :: String
optInitialMetadata :: MetadataMap} , optInitialMetadata :: MetadataMap
}
defaultOptions :: ServerOptions defaultOptions :: ServerOptions
defaultOptions = defaultOptions = ServerOptions
ServerOptions {optNormalHandlers = [], { optNormalHandlers = []
optClientStreamHandlers = [], , optClientStreamHandlers = []
optServerStreamHandlers = [], , optServerStreamHandlers = []
optBiDiStreamHandlers = [], , optBiDiStreamHandlers = []
optServerPort = 50051, , optServerPort = 50051
optUseCompression = False, , optUseCompression = False
optUserAgentPrefix = "grpc-haskell/0.0.0", , optUserAgentPrefix = "grpc-haskell/0.0.0"
optUserAgentSuffix = "", , optUserAgentSuffix = ""
optInitialMetadata = mempty} , optInitialMetadata = mempty
}
serverLoop :: ServerOptions -> IO () serverLoop :: ServerOptions -> IO ()
serverLoop opts = serverLoop _opts = fail "Registered method-based serverLoop NYI"
{-
withGRPC $ \grpc -> withGRPC $ \grpc ->
withServer grpc (mkConfig opts) $ \server -> do withServer grpc (mkConfig opts) $ \server -> do
let rmsN = zip (optNormalHandlers opts) $ normalMethods server let rmsN = zip (optNormalHandlers opts) $ normalMethods server
@ -231,3 +209,4 @@ serverLoop opts =
logMsg $ "Requested unknown endpoint: " ++ show (U.callMethod call) logMsg $ "Requested unknown endpoint: " ++ show (U.callMethod call)
return ("", mempty, StatusNotFound, return ("", mempty, StatusNotFound,
StatusDetails "Unknown method") StatusDetails "Unknown method")
-}

126
src/Network/GRPC/HighLevel/Server/Unregistered.hs
View file

@ -21,65 +21,49 @@ import qualified Network.GRPC.LowLevel.Call.Unregistered as U
import qualified Network.GRPC.LowLevel.Server.Unregistered as U import qualified Network.GRPC.LowLevel.Server.Unregistered as U
dispatchLoop :: Server dispatchLoop :: Server
-> MetadataMap -> MetadataMap
-> [Handler 'Normal] -> [Handler 'Normal]
-> [Handler 'ClientStreaming] -> [Handler 'ClientStreaming]
-> [Handler 'ServerStreaming] -> [Handler 'ServerStreaming]
-> [Handler 'BiDiStreaming] -> [Handler 'BiDiStreaming]
-> IO () -> IO ()
dispatchLoop server meta hN hC hS hB = dispatchLoop s md hN hC hS hB =
forever $ U.withServerCallAsync server $ \call -> do forever $ U.withServerCallAsync s $ \sc ->
case findHandler call allHandlers of case findHandler sc allHandlers of
Just (AnyHandler (UnaryHandler _ h)) -> unaryHandler call h Just (AnyHandler ah) -> case ah of
Just (AnyHandler (ClientStreamHandler _ h)) -> csHandler call h UnaryHandler _ h -> unaryHandler sc h
Just (AnyHandler (ServerStreamHandler _ h)) -> ssHandler call h ClientStreamHandler _ h -> csHandler sc h
Just (AnyHandler (BiDiStreamHandler _ h)) -> bdHandler call h ServerStreamHandler _ h -> ssHandler sc h
Nothing -> unknownHandler call BiDiStreamHandler _ h -> bdHandler sc h
where allHandlers = map AnyHandler hN Nothing -> unknownHandler sc
++ map AnyHandler hC where
++ map AnyHandler hS allHandlers = map AnyHandler hN ++ map AnyHandler hC
++ map AnyHandler hB ++ map AnyHandler hS ++ map AnyHandler hB
findHandler call = find ((== (U.callMethod call))
. anyHandlerMethodName)
unknownHandler call =
void $ U.serverHandleNormalCall' server call meta $ \_ _ ->
return (mempty
, mempty
, StatusNotFound
, StatusDetails "unknown method")
handleError = (handleCallError . left herr =<<) . CE.try findHandler sc = find ((== U.callMethod sc) . anyHandlerMethodName)
where herr (e :: CE.SomeException) = GRPCIOHandlerException (show e)
unaryHandler :: (Message a, Message b) => unaryHandler :: (Message a, Message b) => U.ServerCall -> ServerHandler a b -> IO ()
U.ServerCall unaryHandler sc h =
-> ServerHandler a b handleError $
-> IO () U.serverHandleNormalCall' s sc md $ \_sc' bs ->
unaryHandler call h = convertServerHandler h (const bs <$> U.convertCall sc)
handleError $
U.serverHandleNormalCall' server call meta $ \_call' bs -> csHandler :: (Message a, Message b) => U.ServerCall -> ServerReaderHandler a b -> IO ()
convertServerHandler h (fmap (const bs) $ U.convertCall call) csHandler sc = handleError . U.serverReader s sc md . convertServerReaderHandler
csHandler :: (Message a, Message b) =>
U.ServerCall ssHandler :: (Message a, Message b) => U.ServerCall -> ServerWriterHandler a b -> IO ()
-> ServerReaderHandler a b ssHandler sc = handleError . U.serverWriter s sc md . convertServerWriterHandler
-> IO ()
csHandler call h = bdHandler :: (Message a, Message b) => U.ServerCall -> ServerRWHandler a b -> IO ()
handleError $ bdHandler sc = handleError . U.serverRW s sc md . convertServerRWHandler
U.serverReader server call meta (convertServerReaderHandler h)
ssHandler :: (Message a, Message b) => unknownHandler :: U.ServerCall -> IO ()
U.ServerCall unknownHandler sc = void $ U.serverHandleNormalCall' s sc md $ \_ _ ->
-> ServerWriterHandler a b return (mempty, mempty, StatusNotFound, StatusDetails "unknown method")
-> IO ()
ssHandler call h = handleError :: IO a -> IO ()
handleError $ handleError = (handleCallError . left herr =<<) . CE.try
U.serverWriter server call meta (convertServerWriterHandler h) where herr (e :: CE.SomeException) = GRPCIOHandlerException (show e)
bdHandler :: (Message a, Message b) =>
U.ServerCall
-> ServerRWHandler a b
-> IO ()
bdHandler call h =
handleError $
U.serverRW server call meta (convertServerRWHandler h)
serverLoop :: ServerOptions -> IO () serverLoop :: ServerOptions -> IO ()
serverLoop ServerOptions{..} = do serverLoop ServerOptions{..} = do
@ -95,17 +79,17 @@ serverLoop ServerOptions{..} = do
optBiDiStreamHandlers optBiDiStreamHandlers
wait tid wait tid
where where
config = config = ServerConfig
ServerConfig { host = "localhost"
{ host = "localhost" , port = optServerPort
, port = optServerPort , methodsToRegisterNormal = []
, methodsToRegisterNormal = [] , methodsToRegisterClientStreaming = []
, methodsToRegisterClientStreaming = [] , methodsToRegisterServerStreaming = []
, methodsToRegisterServerStreaming = [] , methodsToRegisterBiDiStreaming = []
, methodsToRegisterBiDiStreaming = [] , serverArgs =
, serverArgs = [CompressionAlgArg GrpcCompressDeflate | optUseCompression]
([CompressionAlgArg GrpcCompressDeflate | optUseCompression] ++
++ [ UserAgentPrefix optUserAgentPrefix
[UserAgentPrefix optUserAgentPrefix , UserAgentSuffix optUserAgentSuffix
, UserAgentSuffix optUserAgentSuffix]) ]
} }

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

@ -21,6 +21,7 @@ GRPC
-- * Calls -- * Calls
, GRPCMethodType(..) , GRPCMethodType(..)
, RegisteredMethod , RegisteredMethod
, MethodPayload
, NormalRequestResult(..) , NormalRequestResult(..)
, MetadataMap(..) , MetadataMap(..)
, MethodName(..) , MethodName(..)
@ -74,7 +75,6 @@ GRPC
, OpRecvResult(..) , OpRecvResult(..)
-- * Streaming utilities -- * Streaming utilities
, Streaming
, StreamSend , StreamSend
, StreamRecv , StreamRecv

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

@ -12,6 +12,7 @@ module Network.GRPC.LowLevel.Client where
import Control.Exception (bracket, finally) import Control.Exception (bracket, finally)
import Control.Monad import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Network.GRPC.LowLevel.Call import Network.GRPC.LowLevel.Call
@ -198,7 +199,8 @@ compileNormalRequestResults x =
-- clientReader (client side of server streaming mode) -- clientReader (client side of server streaming mode)
-- | First parameter is initial server metadata. -- | First parameter is initial server metadata.
type ClientReaderHandler = MetadataMap -> StreamRecv ByteString -> Streaming () type ClientReaderHandler = MetadataMap -> StreamRecv ByteString -> IO ()
type ClientReaderResult = (MetadataMap, C.StatusCode, StatusDetails)
clientReader :: Client clientReader :: Client
-> RegisteredMethod 'ServerStreaming -> RegisteredMethod 'ServerStreaming
@ -206,7 +208,7 @@ clientReader :: Client
-> ByteString -- ^ The body of the request -> ByteString -- ^ The body of the request
-> MetadataMap -- ^ Metadata to send with the request -> MetadataMap -- ^ Metadata to send with the request
-> ClientReaderHandler -> ClientReaderHandler
-> IO (Either GRPCIOError (MetadataMap, C.StatusCode, StatusDetails)) -> IO (Either GRPCIOError ClientReaderResult)
clientReader cl@Client{ clientCQ = cq } rm tm body initMeta f = clientReader cl@Client{ clientCQ = cq } rm tm body initMeta f =
withClientCall cl rm tm go withClientCall cl rm tm go
where where
@ -216,13 +218,13 @@ clientReader cl@Client{ clientCQ = cq } rm tm body initMeta f =
, OpSendCloseFromClient , OpSendCloseFromClient
] ]
srvMD <- recvInitialMetadata c cq srvMD <- recvInitialMetadata c cq
runStreamingProxy "clientReader'" c cq (f srvMD streamRecv) liftIO $ f srvMD (streamRecvPrim c cq)
recvStatusOnClient c cq recvStatusOnClient c cq
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- clientWriter (client side of client streaming mode) -- clientWriter (client side of client streaming mode)
type ClientWriterHandler = StreamSend ByteString -> Streaming () type ClientWriterHandler = StreamSend ByteString -> IO ()
type ClientWriterResult = (Maybe ByteString, MetadataMap, MetadataMap, type ClientWriterResult = (Maybe ByteString, MetadataMap, MetadataMap,
C.StatusCode, StatusDetails) C.StatusCode, StatusDetails)
@ -243,7 +245,7 @@ clientWriterCmn :: Client -- ^ The active client
clientWriterCmn (clientCQ -> cq) initMeta f (unsafeCC -> c) = clientWriterCmn (clientCQ -> cq) initMeta f (unsafeCC -> c) =
runExceptT $ do runExceptT $ do
sendInitialMetadata c cq initMeta sendInitialMetadata c cq initMeta
runStreamingProxy "clientWriterCmn" c cq (f streamSend) liftIO $ f (streamSendPrim c cq)
sendSingle c cq OpSendCloseFromClient sendSingle c cq OpSendCloseFromClient
let ops = [OpRecvInitialMetadata, OpRecvMessage, OpRecvStatusOnClient] let ops = [OpRecvInitialMetadata, OpRecvMessage, OpRecvStatusOnClient]
runOps' c cq ops >>= \case runOps' c cq ops >>= \case
@ -260,28 +262,41 @@ pattern CWRFinal mmsg initMD trailMD st ds
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- clientRW (client side of bidirectional streaming mode) -- clientRW (client side of bidirectional streaming mode)
-- | First parameter is initial server metadata. type ClientRWHandler
type ClientRWHandler = MetadataMap = MetadataMap
-> StreamRecv ByteString -> StreamRecv ByteString
-> StreamSend ByteString -> StreamSend ByteString
-> Streaming () -> WritesDone
-> IO ()
type ClientRWResult = (MetadataMap, C.StatusCode, StatusDetails)
-- | For bidirectional-streaming registered requests -- | The most generic version of clientRW. It does not assume anything about
-- threading model; caller must invoke the WritesDone operation, exactly once,
-- for the half-close, after all threads have completed writing. TODO: It'd be
-- nice to find a way to type-enforce this usage pattern rather than accomplish
-- it via usage convention and documentation.
clientRW :: Client clientRW :: Client
-> RegisteredMethod 'BiDiStreaming -> RegisteredMethod 'BiDiStreaming
-> TimeoutSeconds -> TimeoutSeconds
-> MetadataMap -> MetadataMap
-- ^ request metadata
-> ClientRWHandler -> ClientRWHandler
-> IO (Either GRPCIOError (MetadataMap, C.StatusCode, StatusDetails)) -> IO (Either GRPCIOError ClientRWResult)
clientRW cl@(clientCQ -> cq) rm tm initMeta f = clientRW cl@(clientCQ -> cq) rm tm initMeta f = withClientCall cl rm tm go
withClientCall cl rm tm go
where where
go (unsafeCC -> c) = runExceptT $ do go (unsafeCC -> c) = runExceptT $ do
sendInitialMetadata c cq initMeta sendInitialMetadata c cq initMeta
srvMeta <- recvInitialMetadata c cq srvMeta <- recvInitialMetadata c cq
runStreamingProxy "clientRW" c cq (f srvMeta streamRecv streamSend) liftIO $ f srvMeta (streamRecvPrim c cq) (streamSendPrim c cq) (writesDonePrim c cq)
runOps' c cq [OpSendCloseFromClient] -- WritesDone() -- NB: We could consider having the passed writesDone action safely set a
-- flag once it had been called, and invoke it ourselves if not set after
-- returning from the handler (although this is actually borked in the
-- concurrent case, because a reader may remain blocked without the
-- half-close and thus not return control to us -- doh). Alternately, we
-- can document just this general-purpose function well, and then create
-- slightly simpler versions of the bidi interface which support (a)
-- monothreaded send/recv interleaving with implicit half-close and (b)
-- send/recv threads with implicit half-close after writer thread
-- termination.
recvStatusOnClient c cq -- Finish() recvStatusOnClient c cq -- Finish()
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

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

@ -8,7 +8,6 @@ module Network.GRPC.LowLevel.Op where
import Control.Exception import Control.Exception
import Control.Monad import Control.Monad
import Control.Monad.Trans.Class (MonadTrans(lift))
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import qualified Data.ByteString as B import qualified Data.ByteString as B
@ -27,8 +26,6 @@ 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 qualified Network.GRPC.Unsafe.Slice as C (Slice, freeSlice) import qualified Network.GRPC.Unsafe.Slice as C (Slice, freeSlice)
import qualified Pipes as P
import qualified Pipes.Core as P
-- | Sum describing all possible send and receive operations that can be batched -- | Sum describing all possible send and receive operations that can be batched
-- and executed by gRPC. Usually these are processed in a handful of -- and executed by gRPC. Usually these are processed in a handful of
@ -304,60 +301,28 @@ recvInitialMessage c cq = runOps' c cq [OpRecvMessage] >>= \case
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Streaming types and helpers -- Streaming types and helpers
-- | Requests use Nothing to denote read, Just to denote type StreamRecv a = IO (Either GRPCIOError (Maybe a))
-- write. Right-constructed responses use Just to indicate a successful read, streamRecvPrim :: C.Call -> CompletionQueue -> StreamRecv ByteString
-- and Nothing to denote end of stream when reading or a successful write. streamRecvPrim c cq = f <$> runOps c cq [OpRecvMessage]
type Streaming a =
P.Client (Maybe ByteString) (Either GRPCIOError (Maybe ByteString)) IO a
-- | Run the given 'Streaming' operation via an appropriate upstream
-- proxy. I.e., if called on the client side, the given 'Streaming' operation
-- talks to a server proxy, and vice versa.
runStreamingProxy :: String
-- ^ context string for including in errors
-> C.Call
-- ^ the call associated with this streaming operation
-> CompletionQueue
-- ^ the completion queue for ops batches
-> Streaming a
-- ^ the requesting side of the streaming operation
-> ExceptT GRPCIOError IO a
runStreamingProxy nm c cq
= ExceptT . P.runEffect . (streamingProxy nm c cq P.+>>) . fmap Right
streamingProxy :: String
-- ^ context string for including in errors
-> C.Call
-- ^ the call associated with this streaming operation
-> CompletionQueue
-- ^ the completion queue for ops batches
-> Maybe ByteString
-- ^ the request to the proxy
-> P.Server
(Maybe ByteString)
(Either GRPCIOError (Maybe ByteString))
IO (Either GRPCIOError a)
streamingProxy nm c cq = maybe recv send
where where
recv = run [OpRecvMessage] >>= \case f (RecvMsgRslt mmsg) = Right mmsg
RecvMsgRslt mr -> rsp mr >>= streamingProxy nm c cq f Right{} = Left (GRPCIOInternalUnexpectedRecv "streamRecvPrim")
Right{} -> err (urecv "recv") f (Left e) = Left e
Left e -> err e
send msg = run [OpSendMessage msg] >>= \case
Right [] -> rsp Nothing >>= streamingProxy nm c cq
Right _ -> err (urecv "send")
Left e -> err e
err e = P.respond (Left e) >> return (Left e)
rsp = P.respond . Right
run = lift . runOps c cq
urecv = GRPCIOInternalUnexpectedRecv . (nm ++)
type StreamRecv a = Streaming (Either GRPCIOError (Maybe a))
streamRecv :: StreamRecv ByteString
streamRecv = P.request Nothing
type StreamSend a = a -> Streaming (Either GRPCIOError ())
streamSend :: StreamSend ByteString
streamSend = fmap void . P.request . Just
pattern RecvMsgRslt mmsg <- Right [OpRecvMessageResult mmsg] pattern RecvMsgRslt mmsg <- Right [OpRecvMessageResult mmsg]
type StreamSend a = a -> IO (Either GRPCIOError ())
streamSendPrim :: C.Call -> CompletionQueue -> StreamSend ByteString
streamSendPrim c cq bs = f <$> runOps c cq [OpSendMessage bs]
where
f (Right []) = Right ()
f Right{} = Left (GRPCIOInternalUnexpectedRecv "streamSendPrim")
f (Left e) = Left e
type WritesDone = IO (Either GRPCIOError ())
writesDonePrim :: C.Call -> CompletionQueue -> WritesDone
writesDonePrim c cq = f <$> runOps c cq [OpSendCloseFromClient]
where
f (Right []) = Right ()
f Right{} = Left (GRPCIOInternalUnexpectedRecv "writesDonePrim")
f (Left e) = Left e

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

@ -28,6 +28,7 @@ import Control.Concurrent.STM.TVar (TVar
, newTVarIO) , newTVarIO)
import Control.Exception (bracket, finally) import Control.Exception (bracket, finally)
import Control.Monad import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import qualified Data.Set as S import qualified Data.Set as S
@ -199,7 +200,7 @@ serverRegisterMethod :: C.Server
-> MethodName -> MethodName
-> Endpoint -> Endpoint
-> GRPCMethodType -> GRPCMethodType
-> IO (C.CallHandle) -> IO C.CallHandle
serverRegisterMethod s nm e mty = serverRegisterMethod s nm e mty =
C.grpcServerRegisterMethod s C.grpcServerRegisterMethod s
(unMethodName nm) (unMethodName nm)
@ -312,20 +313,19 @@ withServerCall s rm f =
-- serverReader (server side of client streaming mode) -- serverReader (server side of client streaming mode)
type ServerReaderHandlerLL type ServerReaderHandlerLL
= ServerCall () = ServerCall (MethodPayload 'ClientStreaming)
-> StreamRecv ByteString -> StreamRecv ByteString
-> Streaming (Maybe ByteString, MetadataMap, C.StatusCode, StatusDetails) -> IO (Maybe ByteString, MetadataMap, C.StatusCode, StatusDetails)
serverReader :: Server serverReader :: Server
-> RegisteredMethod 'ClientStreaming -> RegisteredMethod 'ClientStreaming
-> MetadataMap -- ^ initial server metadata -> MetadataMap -- ^ Initial server metadata
-> ServerReaderHandlerLL -> ServerReaderHandlerLL
-> IO (Either GRPCIOError ()) -> IO (Either GRPCIOError ())
serverReader s rm initMeta f = withServerCall s rm go serverReader s rm initMeta f = withServerCall s rm go
where where
go sc@ServerCall{ unsafeSC = c, callCQ = ccq } = runExceptT $ do go sc@ServerCall{ unsafeSC = c, callCQ = ccq } = runExceptT $ do
(mmsg, trailMeta, st, ds) <- (mmsg, trailMeta, st, ds) <- liftIO $ f sc (streamRecvPrim c ccq)
runStreamingProxy "serverReader" c ccq (f sc streamRecv)
runOps' c ccq ( OpSendInitialMetadata initMeta runOps' c ccq ( OpSendInitialMetadata initMeta
: OpSendStatusFromServer trailMeta st ds : OpSendStatusFromServer trailMeta st ds
: maybe [] ((:[]) . OpSendMessage) mmsg : maybe [] ((:[]) . OpSendMessage) mmsg
@ -336,44 +336,42 @@ serverReader s rm initMeta f = withServerCall s rm go
-- serverWriter (server side of server streaming mode) -- serverWriter (server side of server streaming mode)
type ServerWriterHandlerLL type ServerWriterHandlerLL
= ServerCall ByteString = ServerCall (MethodPayload 'ServerStreaming)
-> StreamSend ByteString -> StreamSend ByteString
-> Streaming (MetadataMap, C.StatusCode, StatusDetails) -> IO (MetadataMap, C.StatusCode, StatusDetails)
-- | Wait for and then handle a registered, server-streaming call. -- | Wait for and then handle a registered, server-streaming call.
serverWriter :: Server serverWriter :: Server
-> RegisteredMethod 'ServerStreaming -> RegisteredMethod 'ServerStreaming
-> MetadataMap -> MetadataMap -- ^ Initial server metadata
-- ^ Initial server metadata
-> ServerWriterHandlerLL -> ServerWriterHandlerLL
-> IO (Either GRPCIOError ()) -> IO (Either GRPCIOError ())
serverWriter s rm initMeta f = withServerCall s rm go serverWriter s rm initMeta f = withServerCall s rm go
where where
go sc@ServerCall{ unsafeSC = c, callCQ = ccq } = runExceptT $ do go sc@ServerCall{ unsafeSC = c, callCQ = ccq } = runExceptT $ do
sendInitialMetadata c ccq initMeta sendInitialMetadata c ccq initMeta
st <- runStreamingProxy "serverWriter" c ccq (f sc streamSend) st <- liftIO $ f sc (streamSendPrim c ccq)
sendStatusFromServer c ccq st sendStatusFromServer c ccq st
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- serverRW (server side of bidirectional streaming mode) -- serverRW (bidirectional streaming mode)
type ServerRWHandlerLL type ServerRWHandlerLL
= ServerCall () = ServerCall (MethodPayload 'BiDiStreaming)
-> StreamRecv ByteString -> StreamRecv ByteString
-> StreamSend ByteString -> StreamSend ByteString
-> Streaming (MetadataMap, C.StatusCode, StatusDetails) -> IO (MetadataMap, C.StatusCode, StatusDetails)
serverRW :: Server serverRW :: Server
-> RegisteredMethod 'BiDiStreaming -> RegisteredMethod 'BiDiStreaming
-> MetadataMap -> MetadataMap -- ^ initial server metadata
-- ^ initial server metadata
-> ServerRWHandlerLL -> ServerRWHandlerLL
-> IO (Either GRPCIOError ()) -> IO (Either GRPCIOError ())
serverRW s rm initMeta f = withServerCall s rm go serverRW s rm initMeta f = withServerCall s rm go
where where
go sc@ServerCall{ unsafeSC = c, callCQ = ccq } = runExceptT $ do go sc@ServerCall{ unsafeSC = c, callCQ = ccq } = runExceptT $ do
sendInitialMetadata c ccq initMeta sendInitialMetadata c ccq initMeta
st <- runStreamingProxy "serverRW" c ccq (f sc streamRecv streamSend) st <- liftIO $ f sc (streamRecvPrim c ccq) (streamSendPrim c ccq)
sendStatusFromServer c ccq st sendStatusFromServer c ccq st
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -386,7 +384,7 @@ serverRW s rm initMeta f = withServerCall s rm go
-- respectively. We pass in the 'ServerCall' so that the server can call -- respectively. We pass in the 'ServerCall' so that the server can call
-- 'serverCallCancel' on it if needed. -- 'serverCallCancel' on it if needed.
type ServerHandlerLL type ServerHandlerLL
= ServerCall ByteString = ServerCall (MethodPayload 'Normal)
-> IO (ByteString, MetadataMap, C.StatusCode, StatusDetails) -> IO (ByteString, MetadataMap, C.StatusCode, StatusDetails)
-- | Wait for and then handle a normal (non-streaming) call. -- | Wait for and then handle a normal (non-streaming) call.
@ -399,12 +397,10 @@ serverHandleNormalCall :: Server
serverHandleNormalCall s rm initMeta f = serverHandleNormalCall s rm initMeta f =
withServerCall s rm go withServerCall s rm go
where where
go sc@ServerCall{..} = do go sc@ServerCall{ unsafeSC = c, callCQ = ccq } = do
(rsp, trailMeta, st, ds) <- f sc (rsp, trailMeta, st, ds) <- f sc
void <$> runOps unsafeSC callCQ void <$> runOps c ccq [ OpSendInitialMetadata initMeta
[ OpSendInitialMetadata initMeta , OpRecvCloseOnServer
, OpRecvCloseOnServer , OpSendMessage rsp
, OpSendMessage rsp , OpSendStatusFromServer trailMeta st ds
, OpSendStatusFromServer trailMeta st ds ]
]
<* grpcDebug "serverHandleNormalCall(R): finished response ops."

85
src/Network/GRPC/LowLevel/Server/Unregistered.hs
View file

@ -4,26 +4,19 @@
module Network.GRPC.LowLevel.Server.Unregistered where module Network.GRPC.LowLevel.Server.Unregistered where
import Control.Exception (finally) import Control.Exception (finally)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Network.GRPC.LowLevel.Call.Unregistered import Network.GRPC.LowLevel.Call.Unregistered
import Network.GRPC.LowLevel.CompletionQueue.Unregistered (serverRequestCall) import Network.GRPC.LowLevel.CompletionQueue.Unregistered (serverRequestCall)
import Network.GRPC.LowLevel.GRPC import Network.GRPC.LowLevel.GRPC
import Network.GRPC.LowLevel.Op (Op (..) import Network.GRPC.LowLevel.Op
, OpRecvResult (..) import Network.GRPC.LowLevel.Server (Server (..),
, runOps ServerRWHandlerLL,
, runStreamingProxy ServerReaderHandlerLL,
, streamRecv ServerWriterHandlerLL,
, streamSend forkServer)
, runOps'
, sendInitialMetadata
, sendStatusFromServer
, recvInitialMessage)
import Network.GRPC.LowLevel.Server (Server (..)
, ServerReaderHandlerLL
, ServerWriterHandlerLL
, ServerRWHandlerLL
, forkServer)
import qualified Network.GRPC.Unsafe.Op as C import qualified Network.GRPC.Unsafe.Op as C
serverCreateCall :: Server serverCreateCall :: Server
@ -47,49 +40,27 @@ withServerCall s f =
-- Because this function doesn't wait for the handler to return, it cannot -- Because this function doesn't wait for the handler to return, it cannot
-- return errors. -- return errors.
withServerCallAsync :: Server withServerCallAsync :: Server
-> (ServerCall -> IO ()) -> (ServerCall -> IO ())
-> IO () -> IO ()
withServerCallAsync s f = withServerCallAsync s f =
serverCreateCall s >>= \case serverCreateCall s >>= \case
Left e -> do grpcDebug $ "withServerCallAsync: call error: " ++ show e Left e -> do grpcDebug $ "withServerCallAsync: call error: " ++ show e
return () return ()
Right c -> do wasForkSuccess <- forkServer s handler Right c -> do wasForkSuccess <- forkServer s handler
if wasForkSuccess unless wasForkSuccess destroy
then return ()
else destroy
where handler = f c `finally` destroy where handler = f c `finally` destroy
--TODO: We sometimes never finish cleanup if the server -- TODO: We sometimes never finish cleanup if the server
-- is shutting down and calls killThread. This causes -- is shutting down and calls killThread. This causes gRPC
-- gRPC core to complain about leaks. -- core to complain about leaks. I think the cause of
-- I think the cause of this is that killThread gets -- this is that killThread gets called after we are
-- called after we are already in destroyServerCall, -- already in destroyServerCall, and wrapping
-- and wrapping uninterruptibleMask doesn't seem to help. -- uninterruptibleMask doesn't seem to help. Doesn't
-- Doesn't crash, but does emit annoying log messages. -- crash, but does emit annoying log messages.
destroy = do destroy = do
grpcDebug "withServerCallAsync: destroying." grpcDebug "withServerCallAsync: destroying."
destroyServerCall c destroyServerCall c
grpcDebug "withServerCallAsync: cleanup finished." grpcDebug "withServerCallAsync: cleanup finished."
-- | Sequence of 'Op's needed to receive a normal (non-streaming) call.
-- TODO: We have to put 'OpRecvCloseOnServer' in the response ops, or else the
-- client times out. Given this, I have no idea how to check for cancellation on
-- the server.
serverOpsGetNormalCall :: MetadataMap -> [Op]
serverOpsGetNormalCall initMetadata =
[OpSendInitialMetadata initMetadata,
OpRecvMessage]
-- | Sequence of 'Op's needed to respond to a normal (non-streaming) call.
serverOpsSendNormalResponse :: ByteString
-> MetadataMap
-> C.StatusCode
-> StatusDetails
-> [Op]
serverOpsSendNormalResponse body metadata code details =
[OpRecvCloseOnServer,
OpSendMessage body,
OpSendStatusFromServer metadata code details]
-- | A handler for an unregistered server call; bytestring arguments are the -- | A handler for an unregistered server call; bytestring arguments are the
-- request body and response body respectively. -- request body and response body respectively.
type ServerHandler type ServerHandler
@ -125,6 +96,9 @@ serverHandleNormalCall'
grpcDebug $ "got client metadata: " ++ show metadata grpcDebug $ "got client metadata: " ++ show metadata
grpcDebug $ "call_details host is: " ++ show callHost grpcDebug $ "call_details host is: " ++ show callHost
(rsp, trailMeta, st, ds) <- f sc body (rsp, trailMeta, st, ds) <- f sc body
-- TODO: We have to put 'OpRecvCloseOnServer' in the response ops,
-- or else the client times out. Given this, I have no idea how to
-- check for cancellation on the server.
runOps c cq runOps c cq
[ OpRecvCloseOnServer [ OpRecvCloseOnServer
, OpSendMessage rsp, , OpSendMessage rsp,
@ -141,13 +115,12 @@ serverHandleNormalCall'
serverReader :: Server serverReader :: Server
-> ServerCall -> ServerCall
-> MetadataMap -- ^ initial server metadata -> MetadataMap -- ^ Initial server metadata
-> ServerReaderHandlerLL -> ServerReaderHandlerLL
-> IO (Either GRPCIOError ()) -> IO (Either GRPCIOError ())
serverReader _ sc@ServerCall{ unsafeSC = c, callCQ = ccq } initMeta f = serverReader _ sc@ServerCall{ unsafeSC = c, callCQ = ccq } initMeta f =
runExceptT $ do runExceptT $ do
(mmsg, trailMeta, st, ds) <- (mmsg, trailMeta, st, ds) <- liftIO $ f (convertCall sc) (streamRecvPrim c ccq)
runStreamingProxy "serverReader" c ccq (f (convertCall sc) streamRecv)
runOps' c ccq ( OpSendInitialMetadata initMeta runOps' c ccq ( OpSendInitialMetadata initMeta
: OpSendStatusFromServer trailMeta st ds : OpSendStatusFromServer trailMeta st ds
: maybe [] ((:[]) . OpSendMessage) mmsg : maybe [] ((:[]) . OpSendMessage) mmsg
@ -156,27 +129,23 @@ serverReader _ sc@ServerCall{ unsafeSC = c, callCQ = ccq } initMeta f =
serverWriter :: Server serverWriter :: Server
-> ServerCall -> ServerCall
-> MetadataMap -> MetadataMap -- ^ Initial server metadata
-- ^ Initial server metadata
-> ServerWriterHandlerLL -> ServerWriterHandlerLL
-> IO (Either GRPCIOError ()) -> IO (Either GRPCIOError ())
serverWriter _ sc@ServerCall{ unsafeSC = c, callCQ = ccq } initMeta f = serverWriter _ sc@ServerCall{ unsafeSC = c, callCQ = ccq } initMeta f =
runExceptT $ do runExceptT $ do
bs <- recvInitialMessage c ccq bs <- recvInitialMessage c ccq
sendInitialMetadata c ccq initMeta sendInitialMetadata c ccq initMeta
let regCall = fmap (const bs) (convertCall sc) st <- liftIO $ f (const bs <$> convertCall sc) (streamSendPrim c ccq)
st <- runStreamingProxy "serverWriter" c ccq (f regCall streamSend)
sendStatusFromServer c ccq st sendStatusFromServer c ccq st
serverRW :: Server serverRW :: Server
-> ServerCall -> ServerCall
-> MetadataMap -> MetadataMap -- ^ Initial server metadata
-- ^ initial server metadata
-> ServerRWHandlerLL -> ServerRWHandlerLL
-> IO (Either GRPCIOError ()) -> IO (Either GRPCIOError ())
serverRW _ sc@ServerCall{ unsafeSC = c, callCQ = ccq } initMeta f = serverRW _ sc@ServerCall{ unsafeSC = c, callCQ = ccq } initMeta f =
runExceptT $ do runExceptT $ do
sendInitialMetadata c ccq initMeta sendInitialMetadata c ccq initMeta
let regCall = convertCall sc st <- liftIO $ f (convertCall sc) (streamRecvPrim c ccq) (streamSendPrim c ccq)
st <- runStreamingProxy "serverRW" c ccq (f regCall streamRecv streamSend)
sendStatusFromServer c ccq st sendStatusFromServer c ccq st

13
tests/LowLevelTests.hs
View file

@ -295,13 +295,14 @@ testBiDiStreaming =
client c = do client c = do
rm <- clientRegisterMethodBiDiStreaming c "/bidi" rm <- clientRegisterMethodBiDiStreaming c "/bidi"
eea <- clientRW c rm 10 clientInitMD $ \_initMD recv send -> do eea <- clientRW c rm 10 clientInitMD $ \_srvInitMD recv send writesDone -> do
send "cw0" `is` Right () send "cw0" `is` Right ()
recv `is` Right (Just "sw0") recv `is` Right (Just "sw0")
send "cw1" `is` Right () send "cw1" `is` Right ()
recv `is` Right (Just "sw1") recv `is` Right (Just "sw1")
recv `is` Right (Just "sw2") recv `is` Right (Just "sw2")
return () writesDone `is` Right ()
recv `is` Right Nothing
eea @?= Right (trailMD, serverStatus, serverDtls) eea @?= Right (trailMD, serverStatus, serverDtls)
server s = do server s = do
@ -330,19 +331,19 @@ testBiDiStreamingUnregistered =
client c = do client c = do
rm <- clientRegisterMethodBiDiStreaming c "/bidi" rm <- clientRegisterMethodBiDiStreaming c "/bidi"
eea <- clientRW c rm 10 clientInitMD $ \_initMD recv send -> do eea <- clientRW c rm 10 clientInitMD $ \_srvInitMD recv send writesDone -> do
send "cw0" `is` Right () send "cw0" `is` Right ()
recv `is` Right (Just "sw0") recv `is` Right (Just "sw0")
send "cw1" `is` Right () send "cw1" `is` Right ()
recv `is` Right (Just "sw1") recv `is` Right (Just "sw1")
recv `is` Right (Just "sw2") recv `is` Right (Just "sw2")
return () writesDone `is` Right ()
recv `is` Right Nothing
eea @?= Right (trailMD, serverStatus, serverDtls) eea @?= Right (trailMD, serverStatus, serverDtls)
server s = U.withServerCallAsync s $ \call -> do server s = U.withServerCallAsync s $ \call -> do
eea <- U.serverRW s call serverInitMD $ \sc recv send -> do eea <- U.serverRW s call serverInitMD $ \sc recv send -> do
liftIO $ checkMD "Client request metadata mismatch" checkMD "Client request metadata mismatch" clientInitMD (metadata sc)
clientInitMD (metadata sc)
recv `is` Right (Just "cw0") recv `is` Right (Just "cw0")
send "sw0" `is` Right () send "sw0" `is` Right ()
recv `is` Right (Just "cw1") recv `is` Right (Just "cw1")

6
tests/TestServer.hs
View file

@ -23,7 +23,7 @@ handleNormalCall call =
result = sum nums result = sum nums
handleClientStreamingCall :: ServerCall () -> StreamRecv SimpleServiceRequest -> Streaming (Maybe SimpleServiceResponse, MetadataMap, StatusCode, StatusDetails) handleClientStreamingCall :: ServerCall () -> StreamRecv SimpleServiceRequest -> IO (Maybe SimpleServiceResponse, MetadataMap, StatusCode, StatusDetails)
handleClientStreamingCall call recvRequest = go 0 "" handleClientStreamingCall call recvRequest = go 0 ""
where go sumAccum nameAccum = where go sumAccum nameAccum =
recvRequest >>= \req -> recvRequest >>= \req ->
@ -34,7 +34,7 @@ handleClientStreamingCall call recvRequest = go 0 ""
Right (Just (SimpleServiceRequest name nums)) -> Right (Just (SimpleServiceRequest name nums)) ->
go (sumAccum + sum nums) (nameAccum <> name) go (sumAccum + sum nums) (nameAccum <> name)
handleServerStreamingCall :: ServerCall SimpleServiceRequest -> StreamSend SimpleServiceResponse -> Streaming (MetadataMap, StatusCode, StatusDetails) handleServerStreamingCall :: ServerCall SimpleServiceRequest -> StreamSend SimpleServiceResponse -> IO (MetadataMap, StatusCode, StatusDetails)
handleServerStreamingCall call sendResponse = go handleServerStreamingCall call sendResponse = go
where go = do forM_ nums $ \num -> where go = do forM_ nums $ \num ->
sendResponse (SimpleServiceResponse requestName num) sendResponse (SimpleServiceResponse requestName num)
@ -42,7 +42,7 @@ handleServerStreamingCall call sendResponse = go
SimpleServiceRequest requestName nums = payload call SimpleServiceRequest requestName nums = payload call
handleBiDiStreamingCall :: ServerCall () -> StreamRecv SimpleServiceRequest -> StreamSend SimpleServiceResponse -> Streaming (MetadataMap, StatusCode, StatusDetails) handleBiDiStreamingCall :: ServerCall () -> StreamRecv SimpleServiceRequest -> StreamSend SimpleServiceResponse -> IO (MetadataMap, StatusCode, StatusDetails)
handleBiDiStreamingCall call recvRequest sendResponse = go handleBiDiStreamingCall call recvRequest sendResponse = go
where go = recvRequest >>= \req -> where go = recvRequest >>= \req ->
case req of case req of