Joel/highlevelv2 (#40)

* Tweak runOps param order, inline common op sequences, clean up serverHandleNormalCall

* More ops sequence inlining for clarity, experimenting with Managed

* Checkpoint: preliminary support for all streaming modes; much cleanup/refactoring and api design still needed

* Use mempty for default StatusDetails; tweak bad status matching mechanism

* Preliminary user-facing, server-streaming, low-level api and test

* renaming wibbles

* Preliminary user-facing, client-streaming, low-level api and test

* Move sendMsgs comb to Network.GRPC.LowLevel.Op; misc cleanup/DCR

* Modify bidi streaming to omit request payload

* Add transformers dep

* Preliminary user-facing low-level bidirectional streaming api and test

* Fix missing peek import

* Remove TimeoutSeconds params on streaming mode functions

* Fix serverHandleNormalCall rebase wart

* Fix rebase warts; minor hlint fixes and wibbles

* Post-rebase tweaks to optional payload use in serverRequestCall (i.e., now respects payloadHandling again)

* Cleanup/refactor serverRequestCall

* Fix comment

* Change ServerRWHandler type so that handler does not have to invoke a finalizer

* Change ServerReaderHandler type so that handler does not have to invoke a finalizer

* Simplify serverWriter interface and ServerWriterHandler structure

* Simplify serverRW (get rid of exec param), improve bidi streaming tests

* Use ExceptT in serverRW impl

* Change ServerRWHandler type to pass recv/send operations.

* Renaming

* Define ClientRWHandler, pass recv/send ops

* wibbles

* Use ExceptT in clientRW impl

* Add DataKinded phantom typing to RegisteredMethod; misc cleanup

* Simplify sendMsgs interface; add SingleSend type and related helpers

* Rename SingleSend to SendSingle, use ExceptT to clean up {client,server}Writer and sendMsgs

* More ExceptT cleanup in clientWriter

* Factor out reusable bits of clientWriter

* Shrink ServerReaderHandler

* Delete stale comments

* begin high-level server interface

* update to datakind representation

* clean up

* move method type info to type level, parametrize ServerCall by payload

* convert for writer handler

* start switching over to Message-based handlers

* begin work on highlevel example

* comment out old code

* parametrize StreamSend

* parametrize StreamRecv

* conversion for ServerReaderHandler

* finish handler conversions

* Add high level version and payload checking to echo-client

* Decouple server CQs from call-bound CQs (registered methods); use more consistent naming conventions

* Decouple server/call-bound CQs for unregistered methods; refactor U.serverRequestCall; misc cleanup

* Make convertRecv total; formatting wibbles
This commit is contained in:
Connor Clark 2016-07-12 11:28:21 -07:00
parent 2c2c817ad8
commit 9113e416e7
26 changed files with 1922 additions and 443 deletions

View file

@ -1,21 +1,53 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
{-# OPTIONS_GHC -fno-warn-unused-binds #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-}
import Control.Monad import Control.Monad
import qualified Data.ByteString.Lazy as BL
import Data.Protobuf.Wire.Class
import qualified Data.Text as T
import Data.Word
import GHC.Generics (Generic)
import Network.GRPC.LowLevel import Network.GRPC.LowLevel
import Network.GRPC.LowLevel.Call
import qualified Network.GRPC.LowLevel.Client.Unregistered as U import qualified Network.GRPC.LowLevel.Client.Unregistered as U
import System.Environment
echoMethod = MethodName "/echo.Echo/DoEcho" echoMethod = MethodName "/echo.Echo/DoEcho"
_unregistered c = U.clientRequest c echoMethod 1 "hi" mempty _unregistered c = U.clientRequest c echoMethod 1 "hi" mempty
main = withGRPC $ \g -> regMain = withGRPC $ \g ->
withClient g (ClientConfig "localhost" 50051 []) $ \c -> do withClient g (ClientConfig "localhost" 50051 []) $ \c -> do
rm <- clientRegisterMethod c echoMethod Normal rm <- clientRegisterMethodNormal c echoMethod
replicateM_ 100000 $ clientRequest c rm 5 "hi" mempty >>= \case replicateM_ 100000 $ clientRequest c rm 5 "hi" mempty >>= \case
Left e -> error $ "Got client error: " ++ show e Left e -> error $ "Got client error: " ++ show e
_ -> return () Right r
| rspBody r == "hi" -> return ()
| otherwise -> error $ "Got unexpected payload: " ++ show r
-- NB: If you change these, make sure to change them in the server as well.
-- TODO: Put these in a common location (or just hack around it until CG is working)
data EchoRequest = EchoRequest {message :: T.Text} deriving (Show, Eq, Ord, Generic)
instance Message EchoRequest
data AddRequest = AddRequest {addX :: Word32, addY :: Word32} deriving (Show, Eq, Ord, Generic)
instance Message AddRequest
data AddResponse = AddResponse {answer :: Word32} deriving (Show, Eq, Ord, Generic)
instance Message AddResponse
-- TODO: Create Network.GRPC.HighLevel.Client w/ request variants
highlevelMain = withGRPC $ \g ->
withClient g (ClientConfig "localhost" 50051 []) $ \c -> do
rm <- clientRegisterMethodNormal c echoMethod
let pay = EchoRequest "hi"
enc = BL.toStrict . toLazyByteString $ pay
replicateM_ 1 $ clientRequest c rm 5 enc mempty >>= \case
Left e -> error $ "Got client error: " ++ show e
Right r -> case fromByteString (rspBody r) of
Left e -> error $ "Got decoding error: " ++ show e
Right dec
| dec == pay -> return ()
| otherwise -> error $ "Got unexpected payload: " ++ show dec
main = highlevelMain

View file

@ -6,12 +6,10 @@
#include "echo.grpc.pb.h" #include "echo.grpc.pb.h"
using namespace std; using namespace std;
using namespace echo;
using grpc::Channel; using grpc::Channel;
using grpc::ClientContext; using grpc::ClientContext;
using grpc::Status; using grpc::Status;
using echo::EchoRequest;
using echo::Echo;
class EchoClient { class EchoClient {
public: public:
@ -32,7 +30,29 @@ private:
unique_ptr<Echo::Stub> stub_; unique_ptr<Echo::Stub> stub_;
}; };
class AddClient {
public:
AddClient(shared_ptr<Channel> chan) : stub_(Add::NewStub(chan)) {}
AddResponse DoAdd(const uint32_t x, const uint32_t y){
AddRequest msg;
msg.set_addx(x);
msg.set_addy(y);
AddResponse resp;
ClientContext ctx;
stub_->DoAdd(&ctx, msg, &resp);
return resp;
}
private:
unique_ptr<Add::Stub> stub_;
};
int main(){ int main(){
/*
EchoClient client(grpc::CreateChannel("localhost:50051", EchoClient client(grpc::CreateChannel("localhost:50051",
grpc::InsecureChannelCredentials())); grpc::InsecureChannelCredentials()));
string msg("hi"); string msg("hi");
@ -43,6 +63,11 @@ int main(){
return 1; return 1;
} }
} }
*/
AddClient client (grpc::CreateChannel("localhost:50051",
grpc::InsecureChannelCredentials()));
AddResponse answer = client.DoAdd(1,2);
cout<<"Got answer: "<<answer.answer()<<endl;
return 0; return 0;
} }

View file

@ -37,6 +37,7 @@ Echo::Stub::Stub(const std::shared_ptr< ::grpc::ChannelInterface>& channel)
} }
Echo::Service::Service() { Echo::Service::Service() {
(void)Echo_method_names;
AddMethod(new ::grpc::RpcServiceMethod( AddMethod(new ::grpc::RpcServiceMethod(
Echo_method_names[0], Echo_method_names[0],
::grpc::RpcMethod::NORMAL_RPC, ::grpc::RpcMethod::NORMAL_RPC,
@ -55,5 +56,46 @@ Echo::Service::~Service() {
} }
static const char* Add_method_names[] = {
"/echo.Add/DoAdd",
};
std::unique_ptr< Add::Stub> Add::NewStub(const std::shared_ptr< ::grpc::ChannelInterface>& channel, const ::grpc::StubOptions& options) {
std::unique_ptr< Add::Stub> stub(new Add::Stub(channel));
return stub;
}
Add::Stub::Stub(const std::shared_ptr< ::grpc::ChannelInterface>& channel)
: channel_(channel), rpcmethod_DoAdd_(Add_method_names[0], ::grpc::RpcMethod::NORMAL_RPC, channel)
{}
::grpc::Status Add::Stub::DoAdd(::grpc::ClientContext* context, const ::echo::AddRequest& request, ::echo::AddResponse* response) {
return ::grpc::BlockingUnaryCall(channel_.get(), rpcmethod_DoAdd_, context, request, response);
}
::grpc::ClientAsyncResponseReader< ::echo::AddResponse>* Add::Stub::AsyncDoAddRaw(::grpc::ClientContext* context, const ::echo::AddRequest& request, ::grpc::CompletionQueue* cq) {
return new ::grpc::ClientAsyncResponseReader< ::echo::AddResponse>(channel_.get(), cq, rpcmethod_DoAdd_, context, request);
}
Add::Service::Service() {
(void)Add_method_names;
AddMethod(new ::grpc::RpcServiceMethod(
Add_method_names[0],
::grpc::RpcMethod::NORMAL_RPC,
new ::grpc::RpcMethodHandler< Add::Service, ::echo::AddRequest, ::echo::AddResponse>(
std::mem_fn(&Add::Service::DoAdd), this)));
}
Add::Service::~Service() {
}
::grpc::Status Add::Service::DoAdd(::grpc::ServerContext* context, const ::echo::AddRequest* request, ::echo::AddResponse* response) {
(void) context;
(void) request;
(void) response;
return ::grpc::Status(::grpc::StatusCode::UNIMPLEMENTED, "");
}
} // namespace echo } // namespace echo

View file

@ -17,6 +17,7 @@
namespace grpc { namespace grpc {
class CompletionQueue; class CompletionQueue;
class Channel;
class RpcService; class RpcService;
class ServerCompletionQueue; class ServerCompletionQueue;
class ServerContext; class ServerContext;
@ -60,7 +61,7 @@ class Echo GRPC_FINAL {
template <class BaseClass> template <class BaseClass>
class WithAsyncMethod_DoEcho : public BaseClass { class WithAsyncMethod_DoEcho : public BaseClass {
private: private:
void BaseClassMustBeDerivedFromService(Service *service) {} void BaseClassMustBeDerivedFromService(const Service *service) {}
public: public:
WithAsyncMethod_DoEcho() { WithAsyncMethod_DoEcho() {
::grpc::Service::MarkMethodAsync(0); ::grpc::Service::MarkMethodAsync(0);
@ -81,7 +82,7 @@ class Echo GRPC_FINAL {
template <class BaseClass> template <class BaseClass>
class WithGenericMethod_DoEcho : public BaseClass { class WithGenericMethod_DoEcho : public BaseClass {
private: private:
void BaseClassMustBeDerivedFromService(Service *service) {} void BaseClassMustBeDerivedFromService(const Service *service) {}
public: public:
WithGenericMethod_DoEcho() { WithGenericMethod_DoEcho() {
::grpc::Service::MarkMethodGeneric(0); ::grpc::Service::MarkMethodGeneric(0);
@ -97,6 +98,79 @@ class Echo GRPC_FINAL {
}; };
}; };
class Add GRPC_FINAL {
public:
class StubInterface {
public:
virtual ~StubInterface() {}
virtual ::grpc::Status DoAdd(::grpc::ClientContext* context, const ::echo::AddRequest& request, ::echo::AddResponse* response) = 0;
std::unique_ptr< ::grpc::ClientAsyncResponseReaderInterface< ::echo::AddResponse>> AsyncDoAdd(::grpc::ClientContext* context, const ::echo::AddRequest& request, ::grpc::CompletionQueue* cq) {
return std::unique_ptr< ::grpc::ClientAsyncResponseReaderInterface< ::echo::AddResponse>>(AsyncDoAddRaw(context, request, cq));
}
private:
virtual ::grpc::ClientAsyncResponseReaderInterface< ::echo::AddResponse>* AsyncDoAddRaw(::grpc::ClientContext* context, const ::echo::AddRequest& request, ::grpc::CompletionQueue* cq) = 0;
};
class Stub GRPC_FINAL : public StubInterface {
public:
Stub(const std::shared_ptr< ::grpc::ChannelInterface>& channel);
::grpc::Status DoAdd(::grpc::ClientContext* context, const ::echo::AddRequest& request, ::echo::AddResponse* response) GRPC_OVERRIDE;
std::unique_ptr< ::grpc::ClientAsyncResponseReader< ::echo::AddResponse>> AsyncDoAdd(::grpc::ClientContext* context, const ::echo::AddRequest& request, ::grpc::CompletionQueue* cq) {
return std::unique_ptr< ::grpc::ClientAsyncResponseReader< ::echo::AddResponse>>(AsyncDoAddRaw(context, request, cq));
}
private:
std::shared_ptr< ::grpc::ChannelInterface> channel_;
::grpc::ClientAsyncResponseReader< ::echo::AddResponse>* AsyncDoAddRaw(::grpc::ClientContext* context, const ::echo::AddRequest& request, ::grpc::CompletionQueue* cq) GRPC_OVERRIDE;
const ::grpc::RpcMethod rpcmethod_DoAdd_;
};
static std::unique_ptr<Stub> NewStub(const std::shared_ptr< ::grpc::ChannelInterface>& channel, const ::grpc::StubOptions& options = ::grpc::StubOptions());
class Service : public ::grpc::Service {
public:
Service();
virtual ~Service();
virtual ::grpc::Status DoAdd(::grpc::ServerContext* context, const ::echo::AddRequest* request, ::echo::AddResponse* response);
};
template <class BaseClass>
class WithAsyncMethod_DoAdd : public BaseClass {
private:
void BaseClassMustBeDerivedFromService(const Service *service) {}
public:
WithAsyncMethod_DoAdd() {
::grpc::Service::MarkMethodAsync(0);
}
~WithAsyncMethod_DoAdd() GRPC_OVERRIDE {
BaseClassMustBeDerivedFromService(this);
}
// disable synchronous version of this method
::grpc::Status DoAdd(::grpc::ServerContext* context, const ::echo::AddRequest* request, ::echo::AddResponse* response) GRPC_FINAL GRPC_OVERRIDE {
abort();
return ::grpc::Status(::grpc::StatusCode::UNIMPLEMENTED, "");
}
void RequestDoAdd(::grpc::ServerContext* context, ::echo::AddRequest* request, ::grpc::ServerAsyncResponseWriter< ::echo::AddResponse>* response, ::grpc::CompletionQueue* new_call_cq, ::grpc::ServerCompletionQueue* notification_cq, void *tag) {
::grpc::Service::RequestAsyncUnary(0, context, request, response, new_call_cq, notification_cq, tag);
}
};
typedef WithAsyncMethod_DoAdd<Service > AsyncService;
template <class BaseClass>
class WithGenericMethod_DoAdd : public BaseClass {
private:
void BaseClassMustBeDerivedFromService(const Service *service) {}
public:
WithGenericMethod_DoAdd() {
::grpc::Service::MarkMethodGeneric(0);
}
~WithGenericMethod_DoAdd() GRPC_OVERRIDE {
BaseClassMustBeDerivedFromService(this);
}
// disable synchronous version of this method
::grpc::Status DoAdd(::grpc::ServerContext* context, const ::echo::AddRequest* request, ::echo::AddResponse* response) GRPC_FINAL GRPC_OVERRIDE {
abort();
return ::grpc::Status(::grpc::StatusCode::UNIMPLEMENTED, "");
}
};
};
} // namespace echo } // namespace echo

View file

@ -24,6 +24,12 @@ namespace {
const ::google::protobuf::Descriptor* EchoRequest_descriptor_ = NULL; const ::google::protobuf::Descriptor* EchoRequest_descriptor_ = NULL;
const ::google::protobuf::internal::GeneratedMessageReflection* const ::google::protobuf::internal::GeneratedMessageReflection*
EchoRequest_reflection_ = NULL; EchoRequest_reflection_ = NULL;
const ::google::protobuf::Descriptor* AddRequest_descriptor_ = NULL;
const ::google::protobuf::internal::GeneratedMessageReflection*
AddRequest_reflection_ = NULL;
const ::google::protobuf::Descriptor* AddResponse_descriptor_ = NULL;
const ::google::protobuf::internal::GeneratedMessageReflection*
AddResponse_reflection_ = NULL;
} // namespace } // namespace
@ -49,6 +55,37 @@ void protobuf_AssignDesc_echo_2eproto() {
sizeof(EchoRequest), sizeof(EchoRequest),
GOOGLE_PROTOBUF_GENERATED_MESSAGE_FIELD_OFFSET(EchoRequest, _internal_metadata_), GOOGLE_PROTOBUF_GENERATED_MESSAGE_FIELD_OFFSET(EchoRequest, _internal_metadata_),
GOOGLE_PROTOBUF_GENERATED_MESSAGE_FIELD_OFFSET(EchoRequest, _is_default_instance_)); GOOGLE_PROTOBUF_GENERATED_MESSAGE_FIELD_OFFSET(EchoRequest, _is_default_instance_));
AddRequest_descriptor_ = file->message_type(1);
static const int AddRequest_offsets_[2] = {
GOOGLE_PROTOBUF_GENERATED_MESSAGE_FIELD_OFFSET(AddRequest, addx_),
GOOGLE_PROTOBUF_GENERATED_MESSAGE_FIELD_OFFSET(AddRequest, addy_),
};
AddRequest_reflection_ =
::google::protobuf::internal::GeneratedMessageReflection::NewGeneratedMessageReflection(
AddRequest_descriptor_,
AddRequest::default_instance_,
AddRequest_offsets_,
-1,
-1,
-1,
sizeof(AddRequest),
GOOGLE_PROTOBUF_GENERATED_MESSAGE_FIELD_OFFSET(AddRequest, _internal_metadata_),
GOOGLE_PROTOBUF_GENERATED_MESSAGE_FIELD_OFFSET(AddRequest, _is_default_instance_));
AddResponse_descriptor_ = file->message_type(2);
static const int AddResponse_offsets_[1] = {
GOOGLE_PROTOBUF_GENERATED_MESSAGE_FIELD_OFFSET(AddResponse, answer_),
};
AddResponse_reflection_ =
::google::protobuf::internal::GeneratedMessageReflection::NewGeneratedMessageReflection(
AddResponse_descriptor_,
AddResponse::default_instance_,
AddResponse_offsets_,
-1,
-1,
-1,
sizeof(AddResponse),
GOOGLE_PROTOBUF_GENERATED_MESSAGE_FIELD_OFFSET(AddResponse, _internal_metadata_),
GOOGLE_PROTOBUF_GENERATED_MESSAGE_FIELD_OFFSET(AddResponse, _is_default_instance_));
} }
namespace { namespace {
@ -63,6 +100,10 @@ void protobuf_RegisterTypes(const ::std::string&) {
protobuf_AssignDescriptorsOnce(); protobuf_AssignDescriptorsOnce();
::google::protobuf::MessageFactory::InternalRegisterGeneratedMessage( ::google::protobuf::MessageFactory::InternalRegisterGeneratedMessage(
EchoRequest_descriptor_, &EchoRequest::default_instance()); EchoRequest_descriptor_, &EchoRequest::default_instance());
::google::protobuf::MessageFactory::InternalRegisterGeneratedMessage(
AddRequest_descriptor_, &AddRequest::default_instance());
::google::protobuf::MessageFactory::InternalRegisterGeneratedMessage(
AddResponse_descriptor_, &AddResponse::default_instance());
} }
} // namespace } // namespace
@ -70,6 +111,10 @@ void protobuf_RegisterTypes(const ::std::string&) {
void protobuf_ShutdownFile_echo_2eproto() { void protobuf_ShutdownFile_echo_2eproto() {
delete EchoRequest::default_instance_; delete EchoRequest::default_instance_;
delete EchoRequest_reflection_; delete EchoRequest_reflection_;
delete AddRequest::default_instance_;
delete AddRequest_reflection_;
delete AddResponse::default_instance_;
delete AddResponse_reflection_;
} }
void protobuf_AddDesc_echo_2eproto() { void protobuf_AddDesc_echo_2eproto() {
@ -80,12 +125,20 @@ void protobuf_AddDesc_echo_2eproto() {
::google::protobuf::DescriptorPool::InternalAddGeneratedFile( ::google::protobuf::DescriptorPool::InternalAddGeneratedFile(
"\n\necho.proto\022\004echo\"\036\n\013EchoRequest\022\017\n\007mes" "\n\necho.proto\022\004echo\"\036\n\013EchoRequest\022\017\n\007mes"
"sage\030\001 \001(\t28\n\004Echo\0220\n\006DoEcho\022\021.echo.Echo" "sage\030\001 \001(\t\"(\n\nAddRequest\022\014\n\004addX\030\001 \001(\007\022\014"
"Request\032\021.echo.EchoRequest\"\000b\006proto3", 116); "\n\004addY\030\002 \001(\007\"\035\n\013AddResponse\022\016\n\006answer\030\001 "
"\001(\00728\n\004Echo\0220\n\006DoEcho\022\021.echo.EchoRequest"
"\032\021.echo.EchoRequest\"\00025\n\003Add\022.\n\005DoAdd\022\020."
"echo.AddRequest\032\021.echo.AddResponse\"\000b\006pr"
"oto3", 244);
::google::protobuf::MessageFactory::InternalRegisterGeneratedFile( ::google::protobuf::MessageFactory::InternalRegisterGeneratedFile(
"echo.proto", &protobuf_RegisterTypes); "echo.proto", &protobuf_RegisterTypes);
EchoRequest::default_instance_ = new EchoRequest(); EchoRequest::default_instance_ = new EchoRequest();
AddRequest::default_instance_ = new AddRequest();
AddResponse::default_instance_ = new AddResponse();
EchoRequest::default_instance_->InitAsDefaultInstance(); EchoRequest::default_instance_->InitAsDefaultInstance();
AddRequest::default_instance_->InitAsDefaultInstance();
AddResponse::default_instance_->InitAsDefaultInstance();
::google::protobuf::internal::OnShutdown(&protobuf_ShutdownFile_echo_2eproto); ::google::protobuf::internal::OnShutdown(&protobuf_ShutdownFile_echo_2eproto);
} }
@ -377,6 +430,516 @@ void EchoRequest::clear_message() {
#endif // PROTOBUF_INLINE_NOT_IN_HEADERS #endif // PROTOBUF_INLINE_NOT_IN_HEADERS
// ===================================================================
#if !defined(_MSC_VER) || _MSC_VER >= 1900
const int AddRequest::kAddXFieldNumber;
const int AddRequest::kAddYFieldNumber;
#endif // !defined(_MSC_VER) || _MSC_VER >= 1900
AddRequest::AddRequest()
: ::google::protobuf::Message(), _internal_metadata_(NULL) {
SharedCtor();
// @@protoc_insertion_point(constructor:echo.AddRequest)
}
void AddRequest::InitAsDefaultInstance() {
_is_default_instance_ = true;
}
AddRequest::AddRequest(const AddRequest& from)
: ::google::protobuf::Message(),
_internal_metadata_(NULL) {
SharedCtor();
MergeFrom(from);
// @@protoc_insertion_point(copy_constructor:echo.AddRequest)
}
void AddRequest::SharedCtor() {
_is_default_instance_ = false;
_cached_size_ = 0;
addx_ = 0u;
addy_ = 0u;
}
AddRequest::~AddRequest() {
// @@protoc_insertion_point(destructor:echo.AddRequest)
SharedDtor();
}
void AddRequest::SharedDtor() {
if (this != default_instance_) {
}
}
void AddRequest::SetCachedSize(int size) const {
GOOGLE_SAFE_CONCURRENT_WRITES_BEGIN();
_cached_size_ = size;
GOOGLE_SAFE_CONCURRENT_WRITES_END();
}
const ::google::protobuf::Descriptor* AddRequest::descriptor() {
protobuf_AssignDescriptorsOnce();
return AddRequest_descriptor_;
}
const AddRequest& AddRequest::default_instance() {
if (default_instance_ == NULL) protobuf_AddDesc_echo_2eproto();
return *default_instance_;
}
AddRequest* AddRequest::default_instance_ = NULL;
AddRequest* AddRequest::New(::google::protobuf::Arena* arena) const {
AddRequest* n = new AddRequest;
if (arena != NULL) {
arena->Own(n);
}
return n;
}
void AddRequest::Clear() {
#define ZR_HELPER_(f) reinterpret_cast<char*>(\
&reinterpret_cast<AddRequest*>(16)->f)
#define ZR_(first, last) do {\
::memset(&first, 0,\
ZR_HELPER_(last) - ZR_HELPER_(first) + sizeof(last));\
} while (0)
ZR_(addx_, addy_);
#undef ZR_HELPER_
#undef ZR_
}
bool AddRequest::MergePartialFromCodedStream(
::google::protobuf::io::CodedInputStream* input) {
#define DO_(EXPRESSION) if (!(EXPRESSION)) goto failure
::google::protobuf::uint32 tag;
// @@protoc_insertion_point(parse_start:echo.AddRequest)
for (;;) {
::std::pair< ::google::protobuf::uint32, bool> p = input->ReadTagWithCutoff(127);
tag = p.first;
if (!p.second) goto handle_unusual;
switch (::google::protobuf::internal::WireFormatLite::GetTagFieldNumber(tag)) {
// optional fixed32 addX = 1;
case 1: {
if (tag == 13) {
DO_((::google::protobuf::internal::WireFormatLite::ReadPrimitive<
::google::protobuf::uint32, ::google::protobuf::internal::WireFormatLite::TYPE_FIXED32>(
input, &addx_)));
} else {
goto handle_unusual;
}
if (input->ExpectTag(21)) goto parse_addY;
break;
}
// optional fixed32 addY = 2;
case 2: {
if (tag == 21) {
parse_addY:
DO_((::google::protobuf::internal::WireFormatLite::ReadPrimitive<
::google::protobuf::uint32, ::google::protobuf::internal::WireFormatLite::TYPE_FIXED32>(
input, &addy_)));
} else {
goto handle_unusual;
}
if (input->ExpectAtEnd()) goto success;
break;
}
default: {
handle_unusual:
if (tag == 0 ||
::google::protobuf::internal::WireFormatLite::GetTagWireType(tag) ==
::google::protobuf::internal::WireFormatLite::WIRETYPE_END_GROUP) {
goto success;
}
DO_(::google::protobuf::internal::WireFormatLite::SkipField(input, tag));
break;
}
}
}
success:
// @@protoc_insertion_point(parse_success:echo.AddRequest)
return true;
failure:
// @@protoc_insertion_point(parse_failure:echo.AddRequest)
return false;
#undef DO_
}
void AddRequest::SerializeWithCachedSizes(
::google::protobuf::io::CodedOutputStream* output) const {
// @@protoc_insertion_point(serialize_start:echo.AddRequest)
// optional fixed32 addX = 1;
if (this->addx() != 0) {
::google::protobuf::internal::WireFormatLite::WriteFixed32(1, this->addx(), output);
}
// optional fixed32 addY = 2;
if (this->addy() != 0) {
::google::protobuf::internal::WireFormatLite::WriteFixed32(2, this->addy(), output);
}
// @@protoc_insertion_point(serialize_end:echo.AddRequest)
}
::google::protobuf::uint8* AddRequest::SerializeWithCachedSizesToArray(
::google::protobuf::uint8* target) const {
// @@protoc_insertion_point(serialize_to_array_start:echo.AddRequest)
// optional fixed32 addX = 1;
if (this->addx() != 0) {
target = ::google::protobuf::internal::WireFormatLite::WriteFixed32ToArray(1, this->addx(), target);
}
// optional fixed32 addY = 2;
if (this->addy() != 0) {
target = ::google::protobuf::internal::WireFormatLite::WriteFixed32ToArray(2, this->addy(), target);
}
// @@protoc_insertion_point(serialize_to_array_end:echo.AddRequest)
return target;
}
int AddRequest::ByteSize() const {
int total_size = 0;
// optional fixed32 addX = 1;
if (this->addx() != 0) {
total_size += 1 + 4;
}
// optional fixed32 addY = 2;
if (this->addy() != 0) {
total_size += 1 + 4;
}
GOOGLE_SAFE_CONCURRENT_WRITES_BEGIN();
_cached_size_ = total_size;
GOOGLE_SAFE_CONCURRENT_WRITES_END();
return total_size;
}
void AddRequest::MergeFrom(const ::google::protobuf::Message& from) {
if (GOOGLE_PREDICT_FALSE(&from == this)) MergeFromFail(__LINE__);
const AddRequest* source =
::google::protobuf::internal::DynamicCastToGenerated<const AddRequest>(
&from);
if (source == NULL) {
::google::protobuf::internal::ReflectionOps::Merge(from, this);
} else {
MergeFrom(*source);
}
}
void AddRequest::MergeFrom(const AddRequest& from) {
if (GOOGLE_PREDICT_FALSE(&from == this)) MergeFromFail(__LINE__);
if (from.addx() != 0) {
set_addx(from.addx());
}
if (from.addy() != 0) {
set_addy(from.addy());
}
}
void AddRequest::CopyFrom(const ::google::protobuf::Message& from) {
if (&from == this) return;
Clear();
MergeFrom(from);
}
void AddRequest::CopyFrom(const AddRequest& from) {
if (&from == this) return;
Clear();
MergeFrom(from);
}
bool AddRequest::IsInitialized() const {
return true;
}
void AddRequest::Swap(AddRequest* other) {
if (other == this) return;
InternalSwap(other);
}
void AddRequest::InternalSwap(AddRequest* other) {
std::swap(addx_, other->addx_);
std::swap(addy_, other->addy_);
_internal_metadata_.Swap(&other->_internal_metadata_);
std::swap(_cached_size_, other->_cached_size_);
}
::google::protobuf::Metadata AddRequest::GetMetadata() const {
protobuf_AssignDescriptorsOnce();
::google::protobuf::Metadata metadata;
metadata.descriptor = AddRequest_descriptor_;
metadata.reflection = AddRequest_reflection_;
return metadata;
}
#if PROTOBUF_INLINE_NOT_IN_HEADERS
// AddRequest
// optional fixed32 addX = 1;
void AddRequest::clear_addx() {
addx_ = 0u;
}
::google::protobuf::uint32 AddRequest::addx() const {
// @@protoc_insertion_point(field_get:echo.AddRequest.addX)
return addx_;
}
void AddRequest::set_addx(::google::protobuf::uint32 value) {
addx_ = value;
// @@protoc_insertion_point(field_set:echo.AddRequest.addX)
}
// optional fixed32 addY = 2;
void AddRequest::clear_addy() {
addy_ = 0u;
}
::google::protobuf::uint32 AddRequest::addy() const {
// @@protoc_insertion_point(field_get:echo.AddRequest.addY)
return addy_;
}
void AddRequest::set_addy(::google::protobuf::uint32 value) {
addy_ = value;
// @@protoc_insertion_point(field_set:echo.AddRequest.addY)
}
#endif // PROTOBUF_INLINE_NOT_IN_HEADERS
// ===================================================================
#if !defined(_MSC_VER) || _MSC_VER >= 1900
const int AddResponse::kAnswerFieldNumber;
#endif // !defined(_MSC_VER) || _MSC_VER >= 1900
AddResponse::AddResponse()
: ::google::protobuf::Message(), _internal_metadata_(NULL) {
SharedCtor();
// @@protoc_insertion_point(constructor:echo.AddResponse)
}
void AddResponse::InitAsDefaultInstance() {
_is_default_instance_ = true;
}
AddResponse::AddResponse(const AddResponse& from)
: ::google::protobuf::Message(),
_internal_metadata_(NULL) {
SharedCtor();
MergeFrom(from);
// @@protoc_insertion_point(copy_constructor:echo.AddResponse)
}
void AddResponse::SharedCtor() {
_is_default_instance_ = false;
_cached_size_ = 0;
answer_ = 0u;
}
AddResponse::~AddResponse() {
// @@protoc_insertion_point(destructor:echo.AddResponse)
SharedDtor();
}
void AddResponse::SharedDtor() {
if (this != default_instance_) {
}
}
void AddResponse::SetCachedSize(int size) const {
GOOGLE_SAFE_CONCURRENT_WRITES_BEGIN();
_cached_size_ = size;
GOOGLE_SAFE_CONCURRENT_WRITES_END();
}
const ::google::protobuf::Descriptor* AddResponse::descriptor() {
protobuf_AssignDescriptorsOnce();
return AddResponse_descriptor_;
}
const AddResponse& AddResponse::default_instance() {
if (default_instance_ == NULL) protobuf_AddDesc_echo_2eproto();
return *default_instance_;
}
AddResponse* AddResponse::default_instance_ = NULL;
AddResponse* AddResponse::New(::google::protobuf::Arena* arena) const {
AddResponse* n = new AddResponse;
if (arena != NULL) {
arena->Own(n);
}
return n;
}
void AddResponse::Clear() {
answer_ = 0u;
}
bool AddResponse::MergePartialFromCodedStream(
::google::protobuf::io::CodedInputStream* input) {
#define DO_(EXPRESSION) if (!(EXPRESSION)) goto failure
::google::protobuf::uint32 tag;
// @@protoc_insertion_point(parse_start:echo.AddResponse)
for (;;) {
::std::pair< ::google::protobuf::uint32, bool> p = input->ReadTagWithCutoff(127);
tag = p.first;
if (!p.second) goto handle_unusual;
switch (::google::protobuf::internal::WireFormatLite::GetTagFieldNumber(tag)) {
// optional fixed32 answer = 1;
case 1: {
if (tag == 13) {
DO_((::google::protobuf::internal::WireFormatLite::ReadPrimitive<
::google::protobuf::uint32, ::google::protobuf::internal::WireFormatLite::TYPE_FIXED32>(
input, &answer_)));
} else {
goto handle_unusual;
}
if (input->ExpectAtEnd()) goto success;
break;
}
default: {
handle_unusual:
if (tag == 0 ||
::google::protobuf::internal::WireFormatLite::GetTagWireType(tag) ==
::google::protobuf::internal::WireFormatLite::WIRETYPE_END_GROUP) {
goto success;
}
DO_(::google::protobuf::internal::WireFormatLite::SkipField(input, tag));
break;
}
}
}
success:
// @@protoc_insertion_point(parse_success:echo.AddResponse)
return true;
failure:
// @@protoc_insertion_point(parse_failure:echo.AddResponse)
return false;
#undef DO_
}
void AddResponse::SerializeWithCachedSizes(
::google::protobuf::io::CodedOutputStream* output) const {
// @@protoc_insertion_point(serialize_start:echo.AddResponse)
// optional fixed32 answer = 1;
if (this->answer() != 0) {
::google::protobuf::internal::WireFormatLite::WriteFixed32(1, this->answer(), output);
}
// @@protoc_insertion_point(serialize_end:echo.AddResponse)
}
::google::protobuf::uint8* AddResponse::SerializeWithCachedSizesToArray(
::google::protobuf::uint8* target) const {
// @@protoc_insertion_point(serialize_to_array_start:echo.AddResponse)
// optional fixed32 answer = 1;
if (this->answer() != 0) {
target = ::google::protobuf::internal::WireFormatLite::WriteFixed32ToArray(1, this->answer(), target);
}
// @@protoc_insertion_point(serialize_to_array_end:echo.AddResponse)
return target;
}
int AddResponse::ByteSize() const {
int total_size = 0;
// optional fixed32 answer = 1;
if (this->answer() != 0) {
total_size += 1 + 4;
}
GOOGLE_SAFE_CONCURRENT_WRITES_BEGIN();
_cached_size_ = total_size;
GOOGLE_SAFE_CONCURRENT_WRITES_END();
return total_size;
}
void AddResponse::MergeFrom(const ::google::protobuf::Message& from) {
if (GOOGLE_PREDICT_FALSE(&from == this)) MergeFromFail(__LINE__);
const AddResponse* source =
::google::protobuf::internal::DynamicCastToGenerated<const AddResponse>(
&from);
if (source == NULL) {
::google::protobuf::internal::ReflectionOps::Merge(from, this);
} else {
MergeFrom(*source);
}
}
void AddResponse::MergeFrom(const AddResponse& from) {
if (GOOGLE_PREDICT_FALSE(&from == this)) MergeFromFail(__LINE__);
if (from.answer() != 0) {
set_answer(from.answer());
}
}
void AddResponse::CopyFrom(const ::google::protobuf::Message& from) {
if (&from == this) return;
Clear();
MergeFrom(from);
}
void AddResponse::CopyFrom(const AddResponse& from) {
if (&from == this) return;
Clear();
MergeFrom(from);
}
bool AddResponse::IsInitialized() const {
return true;
}
void AddResponse::Swap(AddResponse* other) {
if (other == this) return;
InternalSwap(other);
}
void AddResponse::InternalSwap(AddResponse* other) {
std::swap(answer_, other->answer_);
_internal_metadata_.Swap(&other->_internal_metadata_);
std::swap(_cached_size_, other->_cached_size_);
}
::google::protobuf::Metadata AddResponse::GetMetadata() const {
protobuf_AssignDescriptorsOnce();
::google::protobuf::Metadata metadata;
metadata.descriptor = AddResponse_descriptor_;
metadata.reflection = AddResponse_reflection_;
return metadata;
}
#if PROTOBUF_INLINE_NOT_IN_HEADERS
// AddResponse
// optional fixed32 answer = 1;
void AddResponse::clear_answer() {
answer_ = 0u;
}
::google::protobuf::uint32 AddResponse::answer() const {
// @@protoc_insertion_point(field_get:echo.AddResponse.answer)
return answer_;
}
void AddResponse::set_answer(::google::protobuf::uint32 value) {
answer_ = value;
// @@protoc_insertion_point(field_set:echo.AddResponse.answer)
}
#endif // PROTOBUF_INLINE_NOT_IN_HEADERS
// @@protoc_insertion_point(namespace_scope) // @@protoc_insertion_point(namespace_scope)
} // namespace echo } // namespace echo

View file

@ -36,6 +36,8 @@ void protobuf_AddDesc_echo_2eproto();
void protobuf_AssignDesc_echo_2eproto(); void protobuf_AssignDesc_echo_2eproto();
void protobuf_ShutdownFile_echo_2eproto(); void protobuf_ShutdownFile_echo_2eproto();
class AddRequest;
class AddResponse;
class EchoRequest; class EchoRequest;
// =================================================================== // ===================================================================
@ -121,6 +123,169 @@ class EchoRequest : public ::google::protobuf::Message {
void InitAsDefaultInstance(); void InitAsDefaultInstance();
static EchoRequest* default_instance_; static EchoRequest* default_instance_;
}; };
// -------------------------------------------------------------------
class AddRequest : public ::google::protobuf::Message {
public:
AddRequest();
virtual ~AddRequest();
AddRequest(const AddRequest& from);
inline AddRequest& operator=(const AddRequest& from) {
CopyFrom(from);
return *this;
}
static const ::google::protobuf::Descriptor* descriptor();
static const AddRequest& default_instance();
void Swap(AddRequest* other);
// implements Message ----------------------------------------------
inline AddRequest* New() const { return New(NULL); }
AddRequest* New(::google::protobuf::Arena* arena) const;
void CopyFrom(const ::google::protobuf::Message& from);
void MergeFrom(const ::google::protobuf::Message& from);
void CopyFrom(const AddRequest& from);
void MergeFrom(const AddRequest& from);
void Clear();
bool IsInitialized() const;
int ByteSize() const;
bool MergePartialFromCodedStream(
::google::protobuf::io::CodedInputStream* input);
void SerializeWithCachedSizes(
::google::protobuf::io::CodedOutputStream* output) const;
::google::protobuf::uint8* SerializeWithCachedSizesToArray(::google::protobuf::uint8* output) const;
int GetCachedSize() const { return _cached_size_; }
private:
void SharedCtor();
void SharedDtor();
void SetCachedSize(int size) const;
void InternalSwap(AddRequest* other);
private:
inline ::google::protobuf::Arena* GetArenaNoVirtual() const {
return _internal_metadata_.arena();
}
inline void* MaybeArenaPtr() const {
return _internal_metadata_.raw_arena_ptr();
}
public:
::google::protobuf::Metadata GetMetadata() const;
// nested types ----------------------------------------------------
// accessors -------------------------------------------------------
// optional fixed32 addX = 1;
void clear_addx();
static const int kAddXFieldNumber = 1;
::google::protobuf::uint32 addx() const;
void set_addx(::google::protobuf::uint32 value);
// optional fixed32 addY = 2;
void clear_addy();
static const int kAddYFieldNumber = 2;
::google::protobuf::uint32 addy() const;
void set_addy(::google::protobuf::uint32 value);
// @@protoc_insertion_point(class_scope:echo.AddRequest)
private:
::google::protobuf::internal::InternalMetadataWithArena _internal_metadata_;
bool _is_default_instance_;
::google::protobuf::uint32 addx_;
::google::protobuf::uint32 addy_;
mutable int _cached_size_;
friend void protobuf_AddDesc_echo_2eproto();
friend void protobuf_AssignDesc_echo_2eproto();
friend void protobuf_ShutdownFile_echo_2eproto();
void InitAsDefaultInstance();
static AddRequest* default_instance_;
};
// -------------------------------------------------------------------
class AddResponse : public ::google::protobuf::Message {
public:
AddResponse();
virtual ~AddResponse();
AddResponse(const AddResponse& from);
inline AddResponse& operator=(const AddResponse& from) {
CopyFrom(from);
return *this;
}
static const ::google::protobuf::Descriptor* descriptor();
static const AddResponse& default_instance();
void Swap(AddResponse* other);
// implements Message ----------------------------------------------
inline AddResponse* New() const { return New(NULL); }
AddResponse* New(::google::protobuf::Arena* arena) const;
void CopyFrom(const ::google::protobuf::Message& from);
void MergeFrom(const ::google::protobuf::Message& from);
void CopyFrom(const AddResponse& from);
void MergeFrom(const AddResponse& from);
void Clear();
bool IsInitialized() const;
int ByteSize() const;
bool MergePartialFromCodedStream(
::google::protobuf::io::CodedInputStream* input);
void SerializeWithCachedSizes(
::google::protobuf::io::CodedOutputStream* output) const;
::google::protobuf::uint8* SerializeWithCachedSizesToArray(::google::protobuf::uint8* output) const;
int GetCachedSize() const { return _cached_size_; }
private:
void SharedCtor();
void SharedDtor();
void SetCachedSize(int size) const;
void InternalSwap(AddResponse* other);
private:
inline ::google::protobuf::Arena* GetArenaNoVirtual() const {
return _internal_metadata_.arena();
}
inline void* MaybeArenaPtr() const {
return _internal_metadata_.raw_arena_ptr();
}
public:
::google::protobuf::Metadata GetMetadata() const;
// nested types ----------------------------------------------------
// accessors -------------------------------------------------------
// optional fixed32 answer = 1;
void clear_answer();
static const int kAnswerFieldNumber = 1;
::google::protobuf::uint32 answer() const;
void set_answer(::google::protobuf::uint32 value);
// @@protoc_insertion_point(class_scope:echo.AddResponse)
private:
::google::protobuf::internal::InternalMetadataWithArena _internal_metadata_;
bool _is_default_instance_;
::google::protobuf::uint32 answer_;
mutable int _cached_size_;
friend void protobuf_AddDesc_echo_2eproto();
friend void protobuf_AssignDesc_echo_2eproto();
friend void protobuf_ShutdownFile_echo_2eproto();
void InitAsDefaultInstance();
static AddResponse* default_instance_;
};
// =================================================================== // ===================================================================
@ -172,7 +337,61 @@ inline void EchoRequest::set_allocated_message(::std::string* message) {
// @@protoc_insertion_point(field_set_allocated:echo.EchoRequest.message) // @@protoc_insertion_point(field_set_allocated:echo.EchoRequest.message)
} }
// -------------------------------------------------------------------
// AddRequest
// optional fixed32 addX = 1;
inline void AddRequest::clear_addx() {
addx_ = 0u;
}
inline ::google::protobuf::uint32 AddRequest::addx() const {
// @@protoc_insertion_point(field_get:echo.AddRequest.addX)
return addx_;
}
inline void AddRequest::set_addx(::google::protobuf::uint32 value) {
addx_ = value;
// @@protoc_insertion_point(field_set:echo.AddRequest.addX)
}
// optional fixed32 addY = 2;
inline void AddRequest::clear_addy() {
addy_ = 0u;
}
inline ::google::protobuf::uint32 AddRequest::addy() const {
// @@protoc_insertion_point(field_get:echo.AddRequest.addY)
return addy_;
}
inline void AddRequest::set_addy(::google::protobuf::uint32 value) {
addy_ = value;
// @@protoc_insertion_point(field_set:echo.AddRequest.addY)
}
// -------------------------------------------------------------------
// AddResponse
// optional fixed32 answer = 1;
inline void AddResponse::clear_answer() {
answer_ = 0u;
}
inline ::google::protobuf::uint32 AddResponse::answer() const {
// @@protoc_insertion_point(field_get:echo.AddResponse.answer)
return answer_;
}
inline void AddResponse::set_answer(::google::protobuf::uint32 value) {
answer_ = value;
// @@protoc_insertion_point(field_set:echo.AddResponse.answer)
}
#endif // !PROTOBUF_INLINE_NOT_IN_HEADERS #endif // !PROTOBUF_INLINE_NOT_IN_HEADERS
// -------------------------------------------------------------------
// -------------------------------------------------------------------
// @@protoc_insertion_point(namespace_scope) // @@protoc_insertion_point(namespace_scope)

View file

@ -1,4 +1,5 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
@ -9,10 +10,14 @@ import Control.Concurrent
import Control.Concurrent.Async import Control.Concurrent.Async
import Control.Monad import Control.Monad
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.Protobuf.Wire.Class
import qualified Data.Text as T
import Data.Word
import GHC.Generics (Generic)
import Network.GRPC.HighLevel.Server
import Network.GRPC.LowLevel import Network.GRPC.LowLevel
import Network.GRPC.LowLevel.Call
import qualified Network.GRPC.LowLevel.Server.Unregistered as U
import qualified Network.GRPC.LowLevel.Call.Unregistered as U import qualified Network.GRPC.LowLevel.Call.Unregistered as U
import qualified Network.GRPC.LowLevel.Server.Unregistered as U
serverMeta :: MetadataMap serverMeta :: MetadataMap
serverMeta = [("test_meta", "test_meta_value")] serverMeta = [("test_meta", "test_meta_value")]
@ -27,7 +32,7 @@ handler U.ServerCall{..} reqBody = do
unregMain :: IO () unregMain :: IO ()
unregMain = withGRPC $ \grpc -> do unregMain = withGRPC $ \grpc -> do
withServer grpc (ServerConfig "localhost" 50051 [] []) $ \server -> forever $ do withServer grpc defConfig $ \server -> forever $ do
result <- U.serverHandleNormalCall server serverMeta handler result <- U.serverHandleNormalCall server serverMeta handler
case result of case result of
Left x -> putStrLn $ "handle call result error: " ++ show x Left x -> putStrLn $ "handle call result error: " ++ show x
@ -35,8 +40,8 @@ unregMain = withGRPC $ \grpc -> do
regMain :: IO () regMain :: IO ()
regMain = withGRPC $ \grpc -> do regMain = withGRPC $ \grpc -> do
let methods = [(MethodName "/echo.Echo/DoEcho", Normal)] let ms = [(MethodName "/echo.Echo/DoEcho")]
withServer grpc (ServerConfig "localhost" 50051 methods []) $ \server -> withServer grpc (defConfig {methodsToRegisterNormal = ms}) $ \server ->
forever $ do forever $ do
let method = head (normalMethods server) let method = head (normalMethods server)
result <- serverHandleNormalCall server method serverMeta $ result <- serverHandleNormalCall server method serverMeta $
@ -63,13 +68,56 @@ regLoop server method = forever $ do
regMainThreaded :: IO () regMainThreaded :: IO ()
regMainThreaded = do regMainThreaded = do
withGRPC $ \grpc -> do withGRPC $ \grpc -> do
let methods = [(MethodName "/echo.Echo/DoEcho", Normal)] let ms = [(MethodName "/echo.Echo/DoEcho")]
withServer grpc (ServerConfig "localhost" 50051 methods []) $ \server -> do withServer grpc (defConfig {methodsToRegisterNormal = ms}) $ \server -> do
let method = head (normalMethods server) let method = head (normalMethods server)
tids <- replicateM 7 $ async $ do tputStrLn "starting handler" tids <- replicateM 7 $ async $ do tputStrLn "starting handler"
regLoop server method regLoop server method
waitAnyCancel tids waitAnyCancel tids
tputStrLn "finishing" tputStrLn "finishing"
-- NB: If you change these, make sure to change them in the client as well.
-- TODO: Put these in a common location (or just hack around it until CG is working)
data EchoRequest = EchoRequest {message :: T.Text} deriving (Show, Eq, Ord, Generic)
instance Message EchoRequest
data AddRequest = AddRequest {addX :: Word32, addY :: Word32} deriving (Show, Eq, Ord, Generic)
instance Message AddRequest
data AddResponse = AddResponse {answer :: Word32} deriving (Show, Eq, Ord, Generic)
instance Message AddResponse
highlevelMain :: IO ()
highlevelMain =
serverLoop defaultOptions{optNormalHandlers = [echoHandler, addHandler]}
where echoHandler =
UnaryHandler "/echo.Echo/DoEcho" $
\_c body m -> do
tputStrLn $ "UnaryHandler for DoEcho hit, body=" ++ show body
return ( body :: EchoRequest
, m
, StatusOk
, StatusDetails ""
)
addHandler =
--TODO: I can't get this one to execute. Is the generated method
--name different?
-- static const char* Add_method_names[] = {
-- "/echo.Add/DoAdd",
-- };
UnaryHandler "/echo.Add/DoAdd" $
\_c b m -> do
tputStrLn $ "UnaryHandler for DoAdd hit, b=" ++ show b
print (addX b)
print (addY b)
return ( AddResponse $ addX b + addY b
, m
, StatusOk
, StatusDetails ""
)
main :: IO () main :: IO ()
main = regMainThreaded main = highlevelMain
defConfig :: ServerConfig
defConfig = ServerConfig "localhost" 50051 [] [] [] [] []

View file

@ -9,3 +9,16 @@ service Echo {
message EchoRequest { message EchoRequest {
string message = 1; string message = 1;
} }
message AddRequest {
fixed32 addX = 1;
fixed32 addY = 2;
}
message AddResponse {
fixed32 answer = 1;
}
service Add {
rpc DoAdd (AddRequest) returns (AddResponse) {}
}

View file

@ -33,6 +33,8 @@ library
, managed >= 1.0.5 && < 1.1 , managed >= 1.0.5 && < 1.1
, pipes ==4.1.* , pipes ==4.1.*
, transformers , transformers
, proto3-wire
, protobuf-wire
, async , async
, tasty >= 0.11 && <0.12 , tasty >= 0.11 && <0.12
@ -63,6 +65,8 @@ library
Network.GRPC.LowLevel.Call Network.GRPC.LowLevel.Call
Network.GRPC.LowLevel.Call.Unregistered Network.GRPC.LowLevel.Call.Unregistered
Network.GRPC.LowLevel.Client Network.GRPC.LowLevel.Client
Network.GRPC.HighLevel
Network.GRPC.HighLevel.Server
extra-libraries: extra-libraries:
grpc grpc
includes: includes:
@ -87,10 +91,13 @@ executable echo-server
if flag(with-examples) if flag(with-examples)
build-depends: build-depends:
base ==4.8.* base ==4.8.*
, bytestring == 0.10.*
, grpc-haskell
, containers ==0.5.*
, async , async
, bytestring == 0.10.*
, containers ==0.5.*
, grpc-haskell
, proto3-wire
, protobuf-wire
, text
else else
buildable: False buildable: False
default-language: Haskell2010 default-language: Haskell2010
@ -102,9 +109,13 @@ executable echo-client
if flag(with-examples) if flag(with-examples)
build-depends: build-depends:
base ==4.8.* base ==4.8.*
, async
, bytestring == 0.10.* , bytestring == 0.10.*
, grpc-haskell
, containers ==0.5.* , containers ==0.5.*
, grpc-haskell
, proto3-wire
, protobuf-wire
, text
else else
buildable: False buildable: False
default-language: Haskell2010 default-language: Haskell2010

View file

@ -0,0 +1,10 @@
module Network.GRPC.HighLevel (
-- * Server
Handler(..)
, ServerOptions(..)
, defaultOptions
, serverLoop
)
where
import Network.GRPC.HighLevel.Server

View file

@ -0,0 +1,223 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
module Network.GRPC.HighLevel.Server where
import Control.Concurrent.Async
import Control.Monad
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as BL
import Data.Protobuf.Wire.Class
import Network.GRPC.LowLevel
import qualified Network.GRPC.LowLevel.Call.Unregistered as U
import Network.GRPC.LowLevel.GRPC
import qualified Network.GRPC.LowLevel.Server.Unregistered as U
type ServerHandler' a b =
forall c .
ServerCall c
-> a
-> MetadataMap
-> IO (b, MetadataMap, StatusCode, StatusDetails)
convertServerHandler :: (Message a, Message b)
=> ServerHandler' a b
-> ServerHandler
convertServerHandler f c bs m = case fromByteString bs of
Left{} -> error "TODO: find a way to keep this from killing the server."
Right x -> do (y, tm, sc, sd) <- f c x m
return (toBS y, tm, sc, sd)
type ServerReaderHandler' a b =
ServerCall ()
-> StreamRecv a
-> Streaming (Maybe b, MetadataMap, StatusCode, StatusDetails)
convertServerReaderHandler :: (Message a, Message b)
=> ServerReaderHandler' a b
-> ServerReaderHandler
convertServerReaderHandler f c recv =
serialize <$> f c (convertRecv recv)
where
serialize (mmsg, m, sc, sd) = (toBS <$> mmsg, m, sc, sd)
type ServerWriterHandler' a b =
ServerCall a
-> StreamSend b
-> Streaming (MetadataMap, StatusCode, StatusDetails)
convertServerWriterHandler :: (Message a, Message b) =>
ServerWriterHandler' a b
-> ServerWriterHandler
convertServerWriterHandler f c send =
f (convert <$> c) (convertSend send)
where
convert bs = case fromByteString bs of
Left x -> error $ "deserialization error: " ++ show x -- TODO FIXME
Right x -> x
type ServerRWHandler' a b =
ServerCall ()
-> StreamRecv a
-> StreamSend b
-> Streaming (MetadataMap, StatusCode, StatusDetails)
convertServerRWHandler :: (Message a, Message b)
=> ServerRWHandler' a b
-> ServerRWHandler
convertServerRWHandler f c recv send =
f c (convertRecv recv) (convertSend send)
convertRecv :: Message a => StreamRecv ByteString -> StreamRecv a
convertRecv =
fmap $ \e -> do
msg <- e
case msg of
Nothing -> return Nothing
Just bs -> case fromByteString bs of
Left x -> Left (GRPCIODecodeError x)
Right x -> return (Just x)
convertSend :: Message a => StreamSend ByteString -> StreamSend a
convertSend s = s . toBS
toBS :: Message a => a -> ByteString
toBS = BL.toStrict . toLazyByteString
data Handler a where
UnaryHandler
:: (Message c, Message d)
=> MethodName
-> ServerHandler' c d
-> Handler 'Normal
ClientStreamHandler
:: (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
handlerMethodName :: Handler a -> MethodName
handlerMethodName (UnaryHandler m _) = m
handlerMethodName (ClientStreamHandler m _) = m
handlerMethodName (ServerStreamHandler m _) = m
handlerMethodName (BiDiStreamHandler m _) = m
-- TODO: find some idiomatic way to do logging that doesn't force the user
-- into anything they don't want.
logShow :: Show a => a -> IO ()
logShow = print
logAskReport :: Show a => a -> IO ()
logAskReport x =
logShow $ show x ++ " This probably indicates a bug in gRPC-haskell. Please report this error."
-- | Handles errors that result from trying to handle a call on the server.
-- For each error, takes a different action depending on the severity in the
-- context of handling a server call. This also tries to give an indication of
-- whether the error is our fault or user error.
handleCallError :: Either GRPCIOError a -> IO ()
handleCallError (Right _) = return ()
handleCallError (Left GRPCIOTimeout) =
--Probably a benign timeout (such as a client disappearing), noop for now.
return ()
handleCallError (Left GRPCIOShutdown) =
--Server shutting down. Benign.
return ()
handleCallError (Left x) = logAskReport x
loopWError :: IO (Either GRPCIOError a) -> IO ()
loopWError f = forever $ f >>= handleCallError
--TODO: options for setting initial/trailing metadata
handleLoop :: Server -> (Handler a, RegisteredMethod a) -> IO ()
handleLoop s (UnaryHandler _ f, rm) =
loopWError $ do
grpcDebug' "handleLoop about to block on serverHandleNormalCall"
serverHandleNormalCall s rm mempty $ convertServerHandler f
handleLoop s (ClientStreamHandler _ f, rm) =
loopWError $ serverReader s rm mempty $ convertServerReaderHandler f
handleLoop s (ServerStreamHandler _ f, rm) =
loopWError $ serverWriter s rm mempty $ convertServerWriterHandler f
handleLoop s (BiDiStreamHandler _ f, rm) =
loopWError $ serverRW s rm mempty $ convertServerRWHandler f
data ServerOptions = ServerOptions
{optNormalHandlers :: [Handler 'Normal],
optClientStreamHandlers :: [Handler 'ClientStreaming],
optServerStreamHandlers :: [Handler 'ServerStreaming],
optBiDiStreamHandlers :: [Handler 'BiDiStreaming],
optServerPort :: Port,
optUseCompression :: Bool,
optUserAgentPrefix :: String,
optUserAgentSuffix :: String}
defaultOptions :: ServerOptions
defaultOptions =
ServerOptions {optNormalHandlers = [],
optClientStreamHandlers = [],
optServerStreamHandlers = [],
optBiDiStreamHandlers = [],
optServerPort = 50051,
optUseCompression = False,
optUserAgentPrefix = "grpc-haskell/0.0.0",
optUserAgentSuffix = ""}
serverLoop :: ServerOptions -> IO ()
serverLoop opts =
withGRPC $ \grpc ->
withServer grpc (mkConfig opts) $ \server -> do
let rmsN = zip (optNormalHandlers opts) $ normalMethods server
let rmsCS = zip (optClientStreamHandlers opts) $ cstreamingMethods server
let rmsSS = zip (optServerStreamHandlers opts) $ sstreamingMethods server
let rmsB = zip (optBiDiStreamHandlers opts) $ bidiStreamingMethods server
--TODO: Perhaps assert that no methods disappeared after registration.
let loop :: forall a. (Handler a, RegisteredMethod a) -> IO ()
loop = handleLoop server
asyncsN <- mapM async $ map loop rmsN
asyncsCS <- mapM async $ map loop rmsCS
asyncsSS <- mapM async $ map loop rmsSS
asyncsB <- mapM async $ map loop rmsB
asyncUnk <- async $ loopWError $ unknownHandler server
waitAnyCancel $ asyncUnk : asyncsN ++ asyncsCS ++ asyncsSS ++ asyncsB
return ()
where
mkConfig ServerOptions{..} =
ServerConfig
{ host = "localhost"
, port = optServerPort
, methodsToRegisterNormal = map handlerMethodName optNormalHandlers
, methodsToRegisterClientStreaming =
map handlerMethodName optClientStreamHandlers
, methodsToRegisterServerStreaming =
map handlerMethodName optServerStreamHandlers
, methodsToRegisterBiDiStreaming =
map handlerMethodName optBiDiStreamHandlers
, serverArgs =
([CompressionAlgArg GrpcCompressDeflate | optUseCompression]
++
[UserAgentPrefix optUserAgentPrefix
, UserAgentSuffix optUserAgentSuffix])
}
unknownHandler s =
--TODO: is this working?
U.serverHandleNormalCall s mempty $ \call _ -> do
logShow $ "Requested unknown endpoint: " ++ show (U.callMethod call)
return ("", mempty, StatusNotFound,
StatusDetails "Unknown method")

View file

@ -29,6 +29,7 @@ GRPC
-- * Configuration options -- * Configuration options
, Arg(..) , Arg(..)
, CompressionAlgorithm(..) , CompressionAlgorithm(..)
, Port
-- * Server -- * Server
, ServerConfig(..) , ServerConfig(..)
@ -37,12 +38,16 @@ GRPC
, ServerCall(optionalPayload, requestMetadataRecv) , ServerCall(optionalPayload, requestMetadataRecv)
, withServer , withServer
, serverHandleNormalCall , serverHandleNormalCall
, ServerHandler
, withServerCall , withServerCall
, serverCallCancel , serverCallCancel
, serverCallIsExpired , serverCallIsExpired
, serverReader -- for client streaming , serverReader -- for client streaming
, ServerReaderHandler
, serverWriter -- for server streaming , serverWriter -- for server streaming
, ServerWriterHandler
, serverRW -- for bidirectional streaming , serverRW -- for bidirectional streaming
, ServerRWHandler
-- * Client -- * Client
, ClientConfig(..) , ClientConfig(..)
@ -51,7 +56,10 @@ GRPC
, ConnectivityState(..) , ConnectivityState(..)
, clientConnectivity , clientConnectivity
, withClient , withClient
, clientRegisterMethod , clientRegisterMethodNormal
, clientRegisterMethodClientStreaming
, clientRegisterMethodServerStreaming
, clientRegisterMethodBiDiStreaming
, clientRequest , clientRequest
, clientReader -- for server streaming , clientReader -- for server streaming
, clientWriter -- for client streaming , clientWriter -- for client streaming
@ -64,6 +72,11 @@ GRPC
, Op(..) , Op(..)
, OpRecvResult(..) , OpRecvResult(..)
-- * Streaming utilities
, Streaming
, StreamSend
, StreamRecv
) where ) where
import Network.GRPC.LowLevel.GRPC import Network.GRPC.LowLevel.GRPC

View file

@ -1,25 +1,34 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-} {-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
-- | This module defines data structures and operations pertaining to registered -- | This module defines data structures and operations pertaining to registered
-- calls; for unregistered call support, see -- calls; for unregistered call support, see
-- `Network.GRPC.LowLevel.Call.Unregistered`. -- `Network.GRPC.LowLevel.Call.Unregistered`.
module Network.GRPC.LowLevel.Call where module Network.GRPC.LowLevel.Call where
import Control.Monad.Managed (Managed, managed)
import Control.Exception (bracket)
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.List (intersperse)
import Data.String (IsString) import Data.String (IsString)
#ifdef DEBUG import Foreign.Marshal.Alloc (free, malloc)
import Foreign.Storable (peek) import Foreign.Ptr (Ptr, nullPtr)
#endif import Foreign.Storable (Storable, peek)
import System.Clock import Network.GRPC.LowLevel.CompletionQueue.Internal
import Network.GRPC.LowLevel.GRPC (MetadataMap,
grpcDebug)
import qualified Network.GRPC.Unsafe as C import qualified Network.GRPC.Unsafe as C
import qualified Network.GRPC.Unsafe.ByteBuffer as C
import qualified Network.GRPC.Unsafe.Op as C import qualified Network.GRPC.Unsafe.Op as C
import System.Clock
import Network.GRPC.LowLevel.GRPC (MetadataMap, grpcDebug)
-- | Models the four types of RPC call supported by gRPC (and correspond to -- | Models the four types of RPC call supported by gRPC (and correspond to
-- DataKinds phantom types on RegisteredMethods). -- DataKinds phantom types on RegisteredMethods).
@ -30,6 +39,23 @@ data GRPCMethodType
| BiDiStreaming | BiDiStreaming
deriving (Show, Eq, Ord, Enum) deriving (Show, Eq, Ord, Enum)
type family MethodPayload a where
MethodPayload 'Normal = ByteString
MethodPayload 'ClientStreaming = ()
MethodPayload 'ServerStreaming = ByteString
MethodPayload 'BiDiStreaming = ()
--TODO: try replacing this class with a plain old function so we don't have the
-- Payloadable constraint everywhere.
payload :: RegisteredMethod mt -> Ptr C.ByteBuffer -> IO (MethodPayload mt)
payload (RegisteredMethodNormal _ _ _) p =
peek p >>= C.copyByteBufferToByteString
payload (RegisteredMethodClientStreaming _ _ _) _ = return ()
payload (RegisteredMethodServerStreaming _ _ _) p =
peek p >>= C.copyByteBufferToByteString
payload (RegisteredMethodBiDiStreaming _ _ _) _ = return ()
newtype MethodName = MethodName {unMethodName :: String} newtype MethodName = MethodName {unMethodName :: String}
deriving (Show, Eq, IsString) deriving (Show, Eq, IsString)
@ -53,32 +79,82 @@ endpoint (Host h) (Port p) = Endpoint (h ++ ":" ++ show p)
-- Contains state for identifying that method in the underlying gRPC -- Contains state for identifying that method in the underlying gRPC
-- library. Note that we use a DataKind-ed phantom type to help constrain use of -- library. Note that we use a DataKind-ed phantom type to help constrain use of
-- different kinds of registered methods. -- different kinds of registered methods.
data RegisteredMethod (mt :: GRPCMethodType) = RegisteredMethod data RegisteredMethod (mt :: GRPCMethodType) where
{ methodType :: GRPCMethodType RegisteredMethodNormal :: MethodName
, methodName :: MethodName -> Endpoint
, methodEndpoint :: Endpoint -> C.CallHandle
, methodHandle :: C.CallHandle -> RegisteredMethod 'Normal
} RegisteredMethodClientStreaming :: MethodName
-> Endpoint
-> C.CallHandle
-> RegisteredMethod 'ClientStreaming
RegisteredMethodServerStreaming :: MethodName
-> Endpoint
-> C.CallHandle
-> RegisteredMethod 'ServerStreaming
RegisteredMethodBiDiStreaming :: MethodName
-> Endpoint
-> C.CallHandle
-> RegisteredMethod 'BiDiStreaming
instance Show (RegisteredMethod a) where
show (RegisteredMethodNormal x y z) =
"RegisteredMethodNormal "
++ concat (intersperse " " [show x, show y, show z])
show (RegisteredMethodClientStreaming x y z) =
"RegisteredMethodClientStreaming "
++ concat (intersperse " " [show x, show y, show z])
show (RegisteredMethodServerStreaming x y z) =
"RegisteredMethodServerStreaming "
++ concat (intersperse " " [show x, show y, show z])
show (RegisteredMethodBiDiStreaming x y z) =
"RegisteredMethodBiDiStreaming "
++ concat (intersperse " " [show x, show y, show z])
methodName :: RegisteredMethod mt -> MethodName
methodName (RegisteredMethodNormal x _ _) = x
methodName (RegisteredMethodClientStreaming x _ _) = x
methodName (RegisteredMethodServerStreaming x _ _) = x
methodName (RegisteredMethodBiDiStreaming x _ _) = x
methodEndpoint :: RegisteredMethod mt -> Endpoint
methodEndpoint (RegisteredMethodNormal _ x _) = x
methodEndpoint (RegisteredMethodClientStreaming _ x _) = x
methodEndpoint (RegisteredMethodServerStreaming _ x _) = x
methodEndpoint (RegisteredMethodBiDiStreaming _ x _) = x
methodHandle :: RegisteredMethod mt -> C.CallHandle
methodHandle (RegisteredMethodNormal _ _ x) = x
methodHandle (RegisteredMethodClientStreaming _ _ x) = x
methodHandle (RegisteredMethodServerStreaming _ _ x) = x
methodHandle (RegisteredMethodBiDiStreaming _ _ x) = x
methodType :: RegisteredMethod mt -> GRPCMethodType
methodType (RegisteredMethodNormal _ _ _) = Normal
methodType (RegisteredMethodClientStreaming _ _ _) = ClientStreaming
methodType (RegisteredMethodServerStreaming _ _ _) = ServerStreaming
methodType (RegisteredMethodBiDiStreaming _ _ _) = BiDiStreaming
-- | Represents one GRPC call (i.e. request) on the client. -- | Represents one GRPC call (i.e. request) on the client.
-- This is used to associate send/receive 'Op's with a request. -- This is used to associate send/receive 'Op's with a request.
data ClientCall = ClientCall { unClientCall :: C.Call } data ClientCall = ClientCall { unsafeCC :: C.Call }
clientCallCancel :: ClientCall -> IO () clientCallCancel :: ClientCall -> IO ()
clientCallCancel cc = C.grpcCallCancel (unClientCall cc) C.reserved clientCallCancel cc = C.grpcCallCancel (unsafeCC cc) C.reserved
-- | Represents one registered GRPC call on the server. Contains pointers to all -- | Represents one registered GRPC call on the server. Contains pointers to all
-- the C state needed to respond to a registered call. -- the C state needed to respond to a registered call.
data ServerCall = ServerCall data ServerCall a = ServerCall
{ unServerCall :: C.Call, { unsafeSC :: C.Call
requestMetadataRecv :: MetadataMap, , callCQ :: CompletionQueue
optionalPayload :: Maybe ByteString, , requestMetadataRecv :: MetadataMap
callDeadline :: TimeSpec , optionalPayload :: a
} , callDeadline :: TimeSpec
} deriving (Functor, Show)
serverCallCancel :: ServerCall -> C.StatusCode -> String -> IO () serverCallCancel :: ServerCall a -> C.StatusCode -> String -> IO ()
serverCallCancel sc code reason = serverCallCancel sc code reason =
C.grpcCallCancelWithStatus (unServerCall sc) code reason C.reserved C.grpcCallCancelWithStatus (unsafeSC sc) code reason C.reserved
-- | NB: For now, we've assumed that the method type is all the info we need to -- | NB: For now, we've assumed that the method type is all the info we need to
-- decide the server payload handling method. -- decide the server payload handling method.
@ -88,7 +164,17 @@ payloadHandling ClientStreaming = C.SrmPayloadNone
payloadHandling ServerStreaming = C.SrmPayloadReadInitialByteBuffer payloadHandling ServerStreaming = C.SrmPayloadReadInitialByteBuffer
payloadHandling BiDiStreaming = C.SrmPayloadNone payloadHandling BiDiStreaming = C.SrmPayloadNone
serverCallIsExpired :: ServerCall -> IO Bool -- | Optionally allocate a managed byte buffer for a payload, depending on the
-- given method type. If no payload is needed, the returned pointer is null
mgdPayload :: GRPCMethodType -> Managed (Ptr C.ByteBuffer)
mgdPayload mt
| payloadHandling mt == C.SrmPayloadNone = return nullPtr
| otherwise = managed C.withByteBufferPtr
mgdPtr :: forall a. Storable a => Managed (Ptr a)
mgdPtr = managed (bracket malloc free)
serverCallIsExpired :: ServerCall a -> IO Bool
serverCallIsExpired sc = do serverCallIsExpired sc = do
currTime <- getTime Monotonic currTime <- getTime Monotonic
return $ currTime > (callDeadline sc) return $ currTime > (callDeadline sc)
@ -102,27 +188,27 @@ debugClientCall (ClientCall (C.Call ptr)) =
debugClientCall = const $ return () debugClientCall = const $ return ()
#endif #endif
debugServerCall :: ServerCall -> IO () debugServerCall :: ServerCall a -> IO ()
#ifdef DEBUG #ifdef DEBUG
debugServerCall call@(ServerCall (C.Call ptr) _ _ _) = do debugServerCall sc@(ServerCall (C.Call ptr) _ _ _ _) = do
grpcDebug $ "debugServerCall(R): server call: " ++ (show ptr) let dbug = grpcDebug . ("debugServerCall(R): " ++)
grpcDebug $ "debugServerCall(R): metadata ptr: " dbug $ "server call: " ++ show ptr
++ show (requestMetadataRecv call) dbug $ "callCQ: " ++ show (callCQ sc)
grpcDebug $ "debugServerCall(R): payload ptr: " ++ show (optionalPayload call) dbug $ "metadata ptr: " ++ show (requestMetadataRecv sc)
grpcDebug $ "debugServerCall(R): deadline ptr: " ++ show (callDeadline call) dbug $ "deadline ptr: " ++ show (callDeadline sc)
#else #else
{-# INLINE debugServerCall #-} {-# INLINE debugServerCall #-}
debugServerCall = const $ return () debugServerCall = const $ return ()
#endif #endif
destroyClientCall :: ClientCall -> IO () destroyClientCall :: ClientCall -> IO ()
destroyClientCall ClientCall{..} = do destroyClientCall cc = do
grpcDebug "Destroying client-side call object." grpcDebug "Destroying client-side call object."
C.grpcCallDestroy unClientCall C.grpcCallDestroy (unsafeCC cc)
destroyServerCall :: ServerCall -> IO () destroyServerCall :: ServerCall a -> IO ()
destroyServerCall call@ServerCall{..} = do destroyServerCall sc@ServerCall{ unsafeSC = c } = do
grpcDebug "destroyServerCall(R): entered." grpcDebug "destroyServerCall(R): entered."
debugServerCall call debugServerCall sc
grpcDebug $ "Destroying server-side call object: " ++ show unServerCall grpcDebug $ "Destroying server-side call object: " ++ show c
C.grpcCallDestroy unServerCall C.grpcCallDestroy c

View file

@ -8,18 +8,20 @@ import Foreign.Ptr (Ptr)
#ifdef DEBUG #ifdef DEBUG
import Foreign.Storable (peek) import Foreign.Storable (peek)
#endif #endif
import System.Clock (TimeSpec) import Network.GRPC.LowLevel.Call (Host (..),
MethodName (..))
import Network.GRPC.LowLevel.Call (Host (..), MethodName (..)) import Network.GRPC.LowLevel.CompletionQueue.Internal
import Network.GRPC.LowLevel.GRPC (MetadataMap, grpcDebug) import Network.GRPC.LowLevel.GRPC (MetadataMap,
grpcDebug)
import qualified Network.GRPC.Unsafe as C import qualified Network.GRPC.Unsafe as C
import qualified Network.GRPC.Unsafe.Op as C import qualified Network.GRPC.Unsafe.Op as C
import System.Clock (TimeSpec)
-- | Represents one unregistered GRPC call on the server. -- | Represents one unregistered GRPC call on the server. Contains pointers to
-- Contains pointers to all the C state needed to respond to an unregistered -- all the C state needed to respond to an unregistered call.
-- call.
data ServerCall = ServerCall data ServerCall = ServerCall
{ unServerCall :: C.Call { unsafeSC :: C.Call
, callCQ :: CompletionQueue
, requestMetadataRecv :: MetadataMap , requestMetadataRecv :: MetadataMap
, parentPtr :: Maybe (Ptr C.Call) , parentPtr :: Maybe (Ptr C.Call)
, callDeadline :: TimeSpec , callDeadline :: TimeSpec
@ -29,18 +31,25 @@ data ServerCall = ServerCall
serverCallCancel :: ServerCall -> C.StatusCode -> String -> IO () serverCallCancel :: ServerCall -> C.StatusCode -> String -> IO ()
serverCallCancel sc code reason = serverCallCancel sc code reason =
C.grpcCallCancelWithStatus (unServerCall sc) code reason C.reserved C.grpcCallCancelWithStatus (unsafeSC sc) code reason C.reserved
debugServerCall :: ServerCall -> IO () debugServerCall :: ServerCall -> IO ()
#ifdef DEBUG #ifdef DEBUG
debugServerCall ServerCall{..} = do debugServerCall ServerCall{..} = do
let C.Call ptr = unServerCall let C.Call ptr = unsafeSC
grpcDebug $ "debugServerCall(U): server call: " ++ show ptr dbug = grpcDebug . ("debugServerCall(U): " ++)
grpcDebug $ "debugServerCall(U): metadata: "
++ show requestMetadataRecv dbug $ "server call: " ++ show ptr
grpcDebug $ "debugServerCall(U): deadline: " ++ show callDeadline dbug $ "metadata: " ++ show requestMetadataRecv
grpcDebug $ "debugServerCall(U): method: " ++ show callMethod
grpcDebug $ "debugServerCall(U): host: " ++ show callHost forM_ parentPtr $ \parentPtr' -> do
dbug $ "parent ptr: " ++ show parentPtr'
C.Call parent <- peek parentPtr'
dbug $ "parent: " ++ show parent
dbug $ "deadline: " ++ show callDeadline
dbug $ "method: " ++ show callMethod
dbug $ "host: " ++ show callHost
#else #else
{-# INLINE debugServerCall #-} {-# INLINE debugServerCall #-}
debugServerCall = const $ return () debugServerCall = const $ return ()
@ -50,7 +59,7 @@ destroyServerCall :: ServerCall -> IO ()
destroyServerCall call@ServerCall{..} = do destroyServerCall call@ServerCall{..} = do
grpcDebug "destroyServerCall(U): entered." grpcDebug "destroyServerCall(U): entered."
debugServerCall call debugServerCall call
grpcDebug $ "Destroying server-side call object: " ++ show unServerCall grpcDebug $ "Destroying server-side call object: " ++ show unsafeSC
C.grpcCallDestroy unServerCall C.grpcCallDestroy unsafeSC
grpcDebug $ "freeing parentPtr: " ++ show parentPtr grpcDebug $ "freeing parentPtr: " ++ show parentPtr
forM_ parentPtr free forM_ parentPtr free

View file

@ -10,10 +10,8 @@
-- `Network.GRPC.LowLevel.Client.Unregistered`. -- `Network.GRPC.LowLevel.Client.Unregistered`.
module Network.GRPC.LowLevel.Client where module Network.GRPC.LowLevel.Client where
import Control.Arrow
import Control.Exception (bracket, finally) import Control.Exception (bracket, finally)
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 Network.GRPC.LowLevel.Call import Network.GRPC.LowLevel.Call
@ -26,9 +24,6 @@ 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 qualified Network.GRPC.Unsafe.Time as C
import qualified Pipes as P
import qualified Pipes.Core as P
-- | Represents the context needed to perform client-side gRPC operations. -- | Represents the context needed to perform client-side gRPC operations.
data Client = Client {clientChannel :: C.Channel, data Client = Client {clientChannel :: C.Channel,
clientCQ :: CompletionQueue, clientCQ :: CompletionQueue,
@ -76,17 +71,54 @@ clientConnectivity :: Client -> IO C.ConnectivityState
clientConnectivity Client{..} = clientConnectivity Client{..} =
C.grpcChannelCheckConnectivityState clientChannel False C.grpcChannelCheckConnectivityState clientChannel False
--TODO: We should probably also register client methods on startup.
-- | Register a method on the client so that we can call it with -- | Register a method on the client so that we can call it with
-- 'clientRequest'. -- 'clientRequest'.
clientRegisterMethod :: Client clientRegisterMethod :: Client
-> MethodName -> MethodName
-> GRPCMethodType -> IO (C.CallHandle)
-> IO (RegisteredMethod mt) clientRegisterMethod Client{..} meth = do
clientRegisterMethod Client{..} meth mty = do
let e = clientEndpoint clientConfig let e = clientEndpoint clientConfig
RegisteredMethod mty meth e <$>
C.grpcChannelRegisterCall clientChannel C.grpcChannelRegisterCall clientChannel
(unMethodName meth) (unEndpoint e) C.reserved (unMethodName meth)
(unEndpoint e)
C.reserved
clientRegisterMethodNormal :: Client
-> MethodName
-> IO (RegisteredMethod 'Normal)
clientRegisterMethodNormal c meth = do
let e = clientEndpoint (clientConfig c)
h <- clientRegisterMethod c meth
return $ RegisteredMethodNormal meth e h
clientRegisterMethodClientStreaming :: Client
-> MethodName
-> IO (RegisteredMethod 'ClientStreaming)
clientRegisterMethodClientStreaming c meth = do
let e = clientEndpoint (clientConfig c)
h <- clientRegisterMethod c meth
return $ RegisteredMethodClientStreaming meth e h
clientRegisterMethodServerStreaming :: Client
-> MethodName
-> IO (RegisteredMethod 'ServerStreaming)
clientRegisterMethodServerStreaming c meth = do
let e = clientEndpoint (clientConfig c)
h <- clientRegisterMethod c meth
return $ RegisteredMethodServerStreaming meth e h
clientRegisterMethodBiDiStreaming :: Client
-> MethodName
-> IO (RegisteredMethod 'BiDiStreaming)
clientRegisterMethodBiDiStreaming c meth = do
let e = clientEndpoint (clientConfig c)
h <- clientRegisterMethod c meth
return $ RegisteredMethodBiDiStreaming meth e h
-- | Create a new call on the client for a registered method. -- | Create a new call on the client for a registered method.
-- Returns 'Left' if the CQ is shutting down or if the job to create a call -- Returns 'Left' if the CQ is shutting down or if the job to create a call
@ -103,13 +135,13 @@ clientCreateCall c rm ts = clientCreateCallParent c rm ts Nothing
clientCreateCallParent :: Client clientCreateCallParent :: Client
-> RegisteredMethod mt -> RegisteredMethod mt
-> TimeoutSeconds -> TimeoutSeconds
-> Maybe ServerCall -> Maybe (ServerCall a)
-- ^ Optional parent call for cascading cancellation. -- ^ Optional parent call for cascading cancellation.
-> IO (Either GRPCIOError ClientCall) -> IO (Either GRPCIOError ClientCall)
clientCreateCallParent Client{..} RegisteredMethod{..} timeout parent = do clientCreateCallParent Client{..} rm timeout parent = do
C.withDeadlineSeconds timeout $ \deadline -> do C.withDeadlineSeconds timeout $ \deadline -> do
channelCreateCall clientChannel parent C.propagateDefaults channelCreateCall clientChannel parent C.propagateDefaults
clientCQ methodHandle deadline clientCQ (methodHandle rm) deadline
-- | Handles safe creation and cleanup of a client call -- | Handles safe creation and cleanup of a client call
withClientCall :: Client withClientCall :: Client
@ -117,8 +149,7 @@ withClientCall :: Client
-> TimeoutSeconds -> TimeoutSeconds
-> (ClientCall -> IO (Either GRPCIOError a)) -> (ClientCall -> IO (Either GRPCIOError a))
-> IO (Either GRPCIOError a) -> IO (Either GRPCIOError a)
withClientCall client regmethod timeout f = withClientCall cl rm tm = withClientCallParent cl rm tm Nothing
withClientCallParent client regmethod timeout Nothing f
-- | Handles safe creation and cleanup of a client call, with an optional parent -- | Handles safe creation and cleanup of a client call, with an optional parent
-- call parameter. This allows for cancellation to cascade from the parent -- call parameter. This allows for cancellation to cascade from the parent
@ -127,17 +158,17 @@ withClientCall client regmethod timeout f =
withClientCallParent :: Client withClientCallParent :: Client
-> RegisteredMethod mt -> RegisteredMethod mt
-> TimeoutSeconds -> TimeoutSeconds
-> (Maybe ServerCall) -> Maybe (ServerCall a)
-- ^ Optional parent call for cascading cancellation. -- ^ Optional parent call for cascading cancellation
-> (ClientCall -> IO (Either GRPCIOError a)) -> (ClientCall -> IO (Either GRPCIOError a))
-> IO (Either GRPCIOError a) -> IO (Either GRPCIOError a)
withClientCallParent client regmethod timeout parent f = do withClientCallParent cl rm tm parent f =
createResult <- clientCreateCallParent client regmethod timeout parent clientCreateCallParent cl rm tm parent >>= \case
case createResult of Left e -> return (Left e)
Left x -> return $ Left x Right c -> f c `finally` do
Right call -> f call `finally` logDestroy call debugClientCall c
where logDestroy c = grpcDebug "withClientCall(R): destroying." grpcDebug "withClientCall(R): destroying."
>> destroyClientCall c destroyClientCall c
data NormalRequestResult = NormalRequestResult data NormalRequestResult = NormalRequestResult
{ rspBody :: ByteString { rspBody :: ByteString
@ -166,7 +197,7 @@ 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 -> Streaming () type ClientReaderHandler = MetadataMap -> StreamRecv ByteString -> Streaming ()
clientReader :: Client clientReader :: Client
-> RegisteredMethod 'ServerStreaming -> RegisteredMethod 'ServerStreaming
@ -178,8 +209,7 @@ clientReader :: Client
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
go cc@(unClientCall -> c) = runExceptT $ do go (unsafeCC -> c) = runExceptT $ do
lift (debugClientCall cc)
runOps' c cq [ OpSendInitialMetadata initMeta runOps' c cq [ OpSendInitialMetadata initMeta
, OpSendMessage body , OpSendMessage body
, OpSendCloseFromClient , OpSendCloseFromClient
@ -191,7 +221,7 @@ clientReader cl@Client{ clientCQ = cq } rm tm body initMeta f =
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- clientWriter (client side of client streaming mode) -- clientWriter (client side of client streaming mode)
type ClientWriterHandler = StreamSend -> Streaming () type ClientWriterHandler = StreamSend ByteString -> Streaming ()
type ClientWriterResult = (Maybe ByteString, MetadataMap, MetadataMap, type ClientWriterResult = (Maybe ByteString, MetadataMap, MetadataMap,
C.StatusCode, StatusDetails) C.StatusCode, StatusDetails)
@ -209,9 +239,8 @@ clientWriterCmn :: Client -- ^ The active client
-> ClientWriterHandler -> ClientWriterHandler
-> ClientCall -- ^ The active client call -> ClientCall -- ^ The active client call
-> IO (Either GRPCIOError ClientWriterResult) -> IO (Either GRPCIOError ClientWriterResult)
clientWriterCmn (clientCQ -> cq) initMeta f cc@(unClientCall -> c) = clientWriterCmn (clientCQ -> cq) initMeta f (unsafeCC -> c) =
runExceptT $ do runExceptT $ do
lift (debugClientCall cc)
sendInitialMetadata c cq initMeta sendInitialMetadata c cq initMeta
runStreamingProxy "clientWriterCmn" c cq (f streamSend) runStreamingProxy "clientWriterCmn" c cq (f streamSend)
sendSingle c cq OpSendCloseFromClient sendSingle c cq OpSendCloseFromClient
@ -231,7 +260,10 @@ 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. -- | First parameter is initial server metadata.
type ClientRWHandler = MetadataMap -> StreamRecv -> StreamSend -> Streaming () type ClientRWHandler = MetadataMap
-> StreamRecv ByteString
-> StreamSend ByteString
-> Streaming ()
-- | For bidirectional-streaming registered requests -- | For bidirectional-streaming registered requests
clientRW :: Client clientRW :: Client
@ -241,16 +273,15 @@ clientRW :: Client
-- ^ request metadata -- ^ request metadata
-> ClientRWHandler -> ClientRWHandler
-> IO (Either GRPCIOError (MetadataMap, C.StatusCode, StatusDetails)) -> IO (Either GRPCIOError (MetadataMap, C.StatusCode, StatusDetails))
clientRW c@Client{ clientCQ = cq } rm tm initMeta f = clientRW cl@(clientCQ -> cq) rm tm initMeta f =
withClientCall c rm tm go withClientCall cl rm tm go
where where
go cc@(unClientCall -> call) = runExceptT $ do go (unsafeCC -> c) = runExceptT $ do
lift (debugClientCall cc) sendInitialMetadata c cq initMeta
sendInitialMetadata call cq initMeta srvMeta <- recvInitialMetadata c cq
srvMeta <- recvInitialMetadata call cq runStreamingProxy "clientRW" c cq (f srvMeta streamRecv streamSend)
runStreamingProxy "clientRW" call cq (f srvMeta streamRecv streamSend) runOps' c cq [OpSendCloseFromClient] -- WritesDone()
runOps' call cq [OpSendCloseFromClient] -- WritesDone() recvStatusOnClient c cq -- Finish()
recvStatusOnClient call cq -- Finish()
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- clientRequest (client side of normal request/response) -- clientRequest (client side of normal request/response)
@ -265,15 +296,13 @@ clientRequest :: Client
-> MetadataMap -> MetadataMap
-- ^ Metadata to send with the request -- ^ Metadata to send with the request
-> IO (Either GRPCIOError NormalRequestResult) -> IO (Either GRPCIOError NormalRequestResult)
clientRequest c@Client{ clientCQ = cq } rm tm body initMeta = clientRequest cl@(clientCQ -> cq) rm tm body initMeta =
withClientCall c rm tm (fmap join . go) withClientCall cl rm tm (fmap join . go)
where where
go cc@(unClientCall -> call) = do go (unsafeCC -> c) =
grpcDebug "clientRequest(R): created call."
debugClientCall cc
-- NB: the send and receive operations below *must* be in separate -- NB: the send and receive operations below *must* be in separate
-- batches, or the client hangs when the server can't be reached. -- batches, or the client hangs when the server can't be reached.
runOps call cq runOps c cq
[ OpSendInitialMetadata initMeta [ OpSendInitialMetadata initMeta
, OpSendMessage body , OpSendMessage body
, OpSendCloseFromClient , OpSendCloseFromClient
@ -283,7 +312,7 @@ clientRequest c@Client{ clientCQ = cq } rm tm body initMeta =
grpcDebug "clientRequest(R) : batch error sending." grpcDebug "clientRequest(R) : batch error sending."
return $ Left x return $ Left x
Right rs -> Right rs ->
runOps call cq runOps c cq
[ OpRecvInitialMetadata [ OpRecvInitialMetadata
, OpRecvMessage , OpRecvMessage
, OpRecvStatusOnClient , OpRecvStatusOnClient

View file

@ -1,4 +1,5 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
module Network.GRPC.LowLevel.Client.Unregistered where module Network.GRPC.LowLevel.Client.Unregistered where
@ -59,10 +60,12 @@ clientRequest :: Client
-> MetadataMap -> MetadataMap
-- ^ Request metadata. -- ^ Request metadata.
-> IO (Either GRPCIOError NormalRequestResult) -> IO (Either GRPCIOError NormalRequestResult)
clientRequest client@Client{..} meth timeLimit body meta = clientRequest cl@(clientCQ -> cq) meth tm body initMeta =
fmap join $ withClientCall client meth timeLimit $ \call -> do join <$> withClientCall cl meth tm go
results <- runOps (unClientCall call) clientCQ where
[ OpSendInitialMetadata meta go (unsafeCC -> c) = do
results <- runOps c cq
[ OpSendInitialMetadata initMeta
, OpSendMessage body , OpSendMessage body
, OpSendCloseFromClient , OpSendCloseFromClient
, OpRecvInitialMetadata , OpRecvInitialMetadata

View file

@ -16,6 +16,7 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
module Network.GRPC.LowLevel.CompletionQueue module Network.GRPC.LowLevel.CompletionQueue
( CompletionQueue ( CompletionQueue
@ -40,7 +41,6 @@ import Control.Concurrent.STM.TVar (newTVarIO,
readTVar, readTVar,
writeTVar) writeTVar)
import Control.Exception (bracket) import Control.Exception (bracket)
import Control.Monad (liftM2)
import Control.Monad.Managed import Control.Monad.Managed
import Control.Monad.Trans.Class (MonadTrans (lift)) import Control.Monad.Trans.Class (MonadTrans (lift))
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
@ -120,7 +120,7 @@ shutdownCompletionQueue CompletionQueue{..} = do
C.OpComplete -> drainLoop C.OpComplete -> drainLoop
channelCreateCall :: C.Channel channelCreateCall :: C.Channel
-> (Maybe ServerCall) -> Maybe (ServerCall a)
-> C.PropagationMask -> C.PropagationMask
-> CompletionQueue -> CompletionQueue
-> C.CallHandle -> C.CallHandle
@ -129,7 +129,7 @@ channelCreateCall :: C.Channel
channelCreateCall channelCreateCall
chan parent mask cq@CompletionQueue{..} handle deadline = chan parent mask cq@CompletionQueue{..} handle deadline =
withPermission Push cq $ do withPermission Push cq $ do
let parentPtr = maybe (C.Call nullPtr) unServerCall parent let parentPtr = maybe (C.Call nullPtr) unsafeSC parent
grpcDebug $ "channelCreateCall: call with " grpcDebug $ "channelCreateCall: call with "
++ concat (intersperse " " [show chan, show parentPtr, ++ concat (intersperse " " [show chan, show parentPtr,
show mask, show mask,
@ -140,56 +140,50 @@ channelCreateCall
return $ Right $ ClientCall call return $ Right $ ClientCall call
-- | Create the call object to handle a registered call. -- | Create the call object to handle a registered call.
serverRequestCall :: C.Server serverRequestCall :: RegisteredMethod mt
-> CompletionQueue -> C.Server
-> RegisteredMethod mt -> CompletionQueue -- ^ server CQ
-> IO (Either GRPCIOError ServerCall) -> CompletionQueue -- ^ call CQ
serverRequestCall s cq@CompletionQueue{.. } rm = -> IO (Either GRPCIOError (ServerCall (MethodPayload mt)))
serverRequestCall rm s scq ccq =
-- NB: The method type dictates whether or not a payload is present, according -- NB: The method type dictates whether or not a payload is present, according
-- to the payloadHandling function. We do not allocate a buffer for the -- to the payloadHandling function. We do not allocate a buffer for the
-- payload when it is not present. -- payload when it is not present.
withPermission Push cq . with allocs $ \(dead, call, pay, meta) -> do withPermission Push scq . with allocs $ \(dead, call, pay, meta) ->
dbug "pre-pluck block" withPermission Pluck scq $ do
withPermission Pluck cq $ do
md <- peek meta md <- peek meta
tag <- newTag cq tag <- newTag scq
dbug $ "got pluck permission, registering call for tag=" ++ show tag dbug $ "got pluck permission, registering call for tag=" ++ show tag
ce <- C.grpcServerRequestRegisteredCall s (methodHandle rm) call dead md pay unsafeCQ unsafeCQ tag ce <- C.grpcServerRequestRegisteredCall s (methodHandle rm) call dead md
pay (unsafeCQ ccq) (unsafeCQ scq) tag
runExceptT $ case ce of runExceptT $ case ce of
C.CallOk -> do C.CallOk -> do
ExceptT $ do ExceptT $ do
r <- pluck' cq tag Nothing r <- pluck' scq tag Nothing
dbug $ "pluck' finished:" ++ show r dbug $ "pluck' finished:" ++ show r
return r return r
lift $ lift $
ServerCall ServerCall
<$> peek call <$> peek call
<*> return ccq
<*> C.getAllMetadataArray md <*> C.getAllMetadataArray md
<*> (if havePay then toBS pay else return Nothing) <*> payload rm pay
<*> convertDeadline dead <*> convertDeadline dead
_ -> do _ -> do
lift $ dbug $ "Throwing callError: " ++ show ce lift $ dbug $ "Throwing callError: " ++ show ce
throwE (GRPCIOCallError ce) throwE (GRPCIOCallError ce)
where where
allocs = (,,,) <$> ptr <*> ptr <*> pay <*> md allocs = (,,,)
where <$> mgdPtr
md = managed C.withMetadataArrayPtr <*> mgdPtr
pay = if havePay then managed C.withByteBufferPtr else return nullPtr <*> mgdPayload (methodType rm)
ptr :: forall a. Storable a => Managed (Ptr a) <*> managed C.withMetadataArrayPtr
ptr = managed (bracket malloc free)
dbug = grpcDebug . ("serverRequestCall(R): " ++) dbug = grpcDebug . ("serverRequestCall(R): " ++)
havePay = payloadHandling (methodType rm) /= C.SrmPayloadNone
toBS p = peek p >>= \bb@(C.ByteBuffer rawPtr) ->
if | rawPtr == nullPtr -> return Nothing
| otherwise -> Just <$> C.copyByteBufferToByteString bb
convertDeadline deadline = do
deadline' <- C.timeSpec <$> peek deadline
-- On OS X, gRPC gives us a deadline that is just a delta, so we convert -- On OS X, gRPC gives us a deadline that is just a delta, so we convert
-- it to an actual deadline. -- it to an actual deadline.
if os == "darwin" convertDeadline (fmap C.timeSpec . peek -> d)
then do now <- getTime Monotonic | os == "darwin" = (+) <$> d <*> getTime Monotonic
return $ now + deadline' | otherwise = d
else return deadline'
-- | Register the server's completion queue. Must be done before the server is -- | Register the server's completion queue. Must be done before the server is
-- started. -- started.

View file

@ -5,7 +5,6 @@ module Network.GRPC.LowLevel.CompletionQueue.Internal where
import Control.Concurrent.STM (atomically, retry) import Control.Concurrent.STM (atomically, retry)
import Control.Concurrent.STM.TVar (TVar, modifyTVar', readTVar, import Control.Concurrent.STM.TVar (TVar, modifyTVar', readTVar,
writeTVar) writeTVar)
import Control.Monad.IO.Class
import Control.Exception (bracket) import Control.Exception (bracket)
import Control.Monad import Control.Monad
import Data.IORef (IORef, atomicModifyIORef') import Data.IORef (IORef, atomicModifyIORef')
@ -62,6 +61,8 @@ data CompletionQueue = CompletionQueue {unsafeCQ :: C.CompletionQueue,
-- items pushed onto the queue. -- items pushed onto the queue.
} }
instance Show CompletionQueue where show = show . unsafeCQ
type TimeoutSeconds = Int type TimeoutSeconds = Int
data CQOpType = Push | Pluck deriving (Show, Eq, Enum) data CQOpType = Push | Pluck deriving (Show, Eq, Enum)

View file

@ -1,10 +1,20 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
module Network.GRPC.LowLevel.CompletionQueue.Unregistered where module Network.GRPC.LowLevel.CompletionQueue.Unregistered where
import Control.Exception (bracket) import Control.Exception (bracket)
import Control.Monad.Managed
import Control.Monad.Trans.Class (MonadTrans (lift))
import Control.Monad.Trans.Except
import Foreign.Marshal.Alloc (free, malloc) import Foreign.Marshal.Alloc (free, malloc)
import Foreign.Storable (peek) import Foreign.Ptr (Ptr)
import Foreign.Storable (Storable, peek)
import Network.GRPC.LowLevel.Call import Network.GRPC.LowLevel.Call
import qualified Network.GRPC.LowLevel.Call.Unregistered as U import qualified Network.GRPC.LowLevel.Call.Unregistered as U
import Network.GRPC.LowLevel.CompletionQueue.Internal import Network.GRPC.LowLevel.CompletionQueue.Internal
@ -30,47 +40,37 @@ channelCreateCall chan parent mask cq@CompletionQueue{..} meth endpt deadline =
serverRequestCall :: C.Server serverRequestCall :: C.Server
-> CompletionQueue -> CompletionQueue -- ^ server CQ / notification CQ
-> CompletionQueue -- ^ call CQ
-> IO (Either GRPCIOError U.ServerCall) -> IO (Either GRPCIOError U.ServerCall)
serverRequestCall server cq@CompletionQueue{..} = serverRequestCall s scq ccq =
withPermission Push cq $ withPermission Push scq . with allocs $ \(call, meta, cd) ->
bracket malloc free $ \callPtr -> withPermission Pluck scq $ do
C.withMetadataArrayPtr $ \metadataArrayPtr -> md <- peek meta
C.withCallDetails $ \callDetails -> tag <- newTag scq
withPermission Pluck cq $ do dbug $ "got pluck permission, registering call for tag=" ++ show tag
grpcDebug $ "serverRequestCall: callPtr is " ++ show callPtr ce <- C.grpcServerRequestCall s call cd md (unsafeCQ ccq) (unsafeCQ scq) tag
metadataArray <- peek metadataArrayPtr runExceptT $ case ce of
tag <- newTag cq C.CallOk -> do
callError <- C.grpcServerRequestCall server callPtr callDetails ExceptT $ do
metadataArray unsafeCQ unsafeCQ tag r <- pluck' scq tag Nothing
grpcDebug $ "serverRequestCall: callError was " ++ show callError dbug $ "pluck' finished: " ++ show r
if callError /= C.CallOk return r
then do grpcDebug "serverRequestCall: got call error; cleaning up." lift $
return $ Left $ GRPCIOCallError callError U.ServerCall
else do pluckResult <- pluck cq tag Nothing <$> peek call
grpcDebug $ "serverRequestCall: pluckResult was " <*> return ccq
++ show pluckResult <*> C.getAllMetadataArray md
case pluckResult of <*> return Nothing
Left x -> do <*> (C.timeSpec <$> C.callDetailsGetDeadline cd)
grpcDebug "serverRequestCall: pluck error." <*> (MethodName <$> C.callDetailsGetMethod cd)
return $ Left x <*> (Host <$> C.callDetailsGetHost cd)
Right () -> do _ -> do
rawCall <- peek callPtr lift $ dbug $ "Throwing callError: " ++ show ce
metadata <- C.getAllMetadataArray metadataArray throwE $ GRPCIOCallError ce
deadline <- getDeadline callDetails where
method <- getMethod callDetails allocs = (,,)
host <- getHost callDetails <$> mgdPtr
let call = U.ServerCall rawCall <*> managed C.withMetadataArrayPtr
metadata <*> managed C.withCallDetails
Nothing dbug = grpcDebug . ("serverRequestCall(U): " ++)
deadline
method
host
return $ Right call
where getDeadline callDetails = do
C.timeSpec <$> C.callDetailsGetDeadline callDetails
getMethod callDetails =
MethodName <$> C.callDetailsGetMethod callDetails
getHost callDetails =
Host <$> C.callDetailsGetHost callDetails

View file

@ -11,7 +11,7 @@ import qualified Data.ByteString as B
import qualified Data.Map as M import qualified Data.Map as M
import qualified Network.GRPC.Unsafe as C import qualified Network.GRPC.Unsafe as C
import qualified Network.GRPC.Unsafe.Op as C import qualified Network.GRPC.Unsafe.Op as C
import Proto3.Wire.Decode (ParseError)
#ifdef DEBUG #ifdef DEBUG
import GHC.Conc (myThreadId) import GHC.Conc (myThreadId)
@ -47,7 +47,7 @@ data GRPCIOError = GRPCIOCallError C.CallError
-- reasonable amount of time. -- reasonable amount of time.
| GRPCIOUnknownError | GRPCIOUnknownError
| GRPCIOBadStatusCode C.StatusCode StatusDetails | GRPCIOBadStatusCode C.StatusCode StatusDetails
| GRPCIODecodeError ParseError
| GRPCIOInternalMissingExpectedPayload | GRPCIOInternalMissingExpectedPayload
| GRPCIOInternalUnexpectedRecv String -- debugging description | GRPCIOInternalUnexpectedRecv String -- debugging description
deriving (Show, Eq) deriving (Show, Eq)

View file

@ -345,12 +345,12 @@ streamingProxy nm c cq = maybe recv send
run = lift . runOps c cq run = lift . runOps c cq
urecv = GRPCIOInternalUnexpectedRecv . (nm ++) urecv = GRPCIOInternalUnexpectedRecv . (nm ++)
type StreamRecv = Streaming (Either GRPCIOError (Maybe ByteString)) type StreamRecv a = Streaming (Either GRPCIOError (Maybe a))
streamRecv :: StreamRecv streamRecv :: StreamRecv ByteString
streamRecv = P.request Nothing streamRecv = P.request Nothing
type StreamSend = ByteString -> Streaming (Either GRPCIOError ()) type StreamSend a = a -> Streaming (Either GRPCIOError ())
streamSend :: StreamSend streamSend :: StreamSend ByteString
streamSend = fmap void . P.request . Just streamSend = fmap void . P.request . Just
pattern RecvMsgRslt mmsg <- Right [OpRecvMessageResult mmsg] pattern RecvMsgRslt mmsg <- Right [OpRecvMessageResult mmsg]

View file

@ -6,16 +6,16 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | This module defines data structures and operations pertaining to registered -- | This module defines data structures and operations pertaining to registered
-- servers using registered calls; for unregistered support, see -- servers using registered calls; for unregistered support, see
-- `Network.GRPC.LowLevel.Server.Unregistered`. -- `Network.GRPC.LowLevel.Server.Unregistered`.
module Network.GRPC.LowLevel.Server where module Network.GRPC.LowLevel.Server where
import Control.Arrow
import Control.Exception (bracket, finally) import Control.Exception (bracket, finally)
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 Network.GRPC.LowLevel.Call import Network.GRPC.LowLevel.Call
@ -25,18 +25,18 @@ import Network.GRPC.LowLevel.CompletionQueue (CompletionQueue,
serverRegisterCompletionQueue, serverRegisterCompletionQueue,
serverRequestCall, serverRequestCall,
serverShutdownAndNotify, serverShutdownAndNotify,
shutdownCompletionQueue) shutdownCompletionQueue,
withCompletionQueue)
import Network.GRPC.LowLevel.GRPC import Network.GRPC.LowLevel.GRPC
import Network.GRPC.LowLevel.Op import Network.GRPC.LowLevel.Op
import qualified Network.GRPC.Unsafe as C import qualified Network.GRPC.Unsafe as C
import qualified Network.GRPC.Unsafe.ChannelArgs as C import qualified Network.GRPC.Unsafe.ChannelArgs as C
import qualified Network.GRPC.Unsafe.Op as C import qualified Network.GRPC.Unsafe.Op as C
import qualified Pipes as P
import qualified Pipes.Core as P
-- | Wraps various gRPC state needed to run a server. -- | Wraps various gRPC state needed to run a server.
data Server = Server data Server = Server
{ internalServer :: C.Server { serverGRPC :: GRPC
, unsafeServer :: C.Server
, serverCQ :: CompletionQueue , serverCQ :: CompletionQueue
, normalMethods :: [RegisteredMethod 'Normal] , normalMethods :: [RegisteredMethod 'Normal]
, sstreamingMethods :: [RegisteredMethod 'ServerStreaming] , sstreamingMethods :: [RegisteredMethod 'ServerStreaming]
@ -52,9 +52,11 @@ data ServerConfig = ServerConfig
-- used. Setting to "localhost" works fine in tests. -- used. Setting to "localhost" works fine in tests.
, port :: Port , port :: Port
-- ^ Port on which to listen for requests. -- ^ Port on which to listen for requests.
, methodsToRegister :: [(MethodName, GRPCMethodType)] , methodsToRegisterNormal :: [MethodName]
-- ^ List of (method name, method type) tuples specifying all methods to -- ^ List of normal (non-streaming) methods to register.
-- register. , methodsToRegisterClientStreaming :: [MethodName]
, methodsToRegisterServerStreaming :: [MethodName]
, methodsToRegisterBiDiStreaming :: [MethodName]
, serverArgs :: [C.Arg] , serverArgs :: [C.Arg]
-- ^ Optional arguments for setting up the channel on the server. Supplying an -- ^ Optional arguments for setting up the channel on the server. Supplying an
-- empty list will cause the channel to use gRPC's default options. -- empty list will cause the channel to use gRPC's default options.
@ -73,47 +75,47 @@ startServer grpc conf@ServerConfig{..} =
when (actualPort /= unPort port) $ when (actualPort /= unPort port) $
error $ "Unable to bind port: " ++ show port error $ "Unable to bind port: " ++ show port
cq <- createCompletionQueue grpc cq <- createCompletionQueue grpc
grpcDebug $ "startServer: server CQ: " ++ show cq
serverRegisterCompletionQueue server cq serverRegisterCompletionQueue server cq
-- Register methods according to their GRPCMethodType kind. It's a bit ugly -- Register methods according to their GRPCMethodType kind. It's a bit ugly
-- to partition them this way, but we get very convenient phantom typing -- to partition them this way, but we get very convenient phantom typing
-- elsewhere by doing so. -- elsewhere by doing so.
(ns, ss, cs, bs) <- do -- TODO: change order of args so we can eta reduce.
let f (ns, ss, cs, bs) (nm, mt) = do ns <- mapM (\nm -> serverRegisterMethodNormal server nm e)
let reg = serverRegisterMethod server nm e mt methodsToRegisterNormal
case mt of ss <- mapM (\nm -> serverRegisterMethodServerStreaming server nm e)
Normal -> ( , ss, cs, bs) . (:ns) <$> reg methodsToRegisterServerStreaming
ServerStreaming -> (ns, , cs, bs) . (:ss) <$> reg cs <- mapM (\nm -> serverRegisterMethodClientStreaming server nm e)
ClientStreaming -> (ns, ss, , bs) . (:cs) <$> reg methodsToRegisterClientStreaming
BiDiStreaming -> (ns, ss, cs, ) . (:bs) <$> reg bs <- mapM (\nm -> serverRegisterMethodBiDiStreaming server nm e)
foldM f ([],[],[],[]) methodsToRegister methodsToRegisterBiDiStreaming
C.grpcServerStart server C.grpcServerStart server
return $ Server server cq ns ss cs bs conf return $ Server grpc server cq ns ss cs bs conf
stopServer :: Server -> IO () stopServer :: Server -> IO ()
-- TODO: Do method handles need to be freed? -- TODO: Do method handles need to be freed?
stopServer Server{..} = do stopServer Server{ unsafeServer = s, serverCQ = scq } = do
grpcDebug "stopServer: calling shutdownNotify." grpcDebug "stopServer: calling shutdownNotify."
shutdownNotify shutdownNotify
grpcDebug "stopServer: cancelling all calls." grpcDebug "stopServer: cancelling all calls."
C.grpcServerCancelAllCalls internalServer C.grpcServerCancelAllCalls s
grpcDebug "stopServer: call grpc_server_destroy." grpcDebug "stopServer: call grpc_server_destroy."
C.grpcServerDestroy internalServer C.grpcServerDestroy s
grpcDebug "stopServer: shutting down CQ." grpcDebug "stopServer: shutting down CQ."
shutdownCQ shutdownCQ
where shutdownCQ = do where shutdownCQ = do
shutdownResult <- shutdownCompletionQueue serverCQ shutdownResult <- shutdownCompletionQueue scq
case shutdownResult of case shutdownResult of
Left _ -> do putStrLn "Warning: completion queue didn't shut down." Left _ -> do putStrLn "Warning: completion queue didn't shut down."
putStrLn "Trying to stop server anyway." putStrLn "Trying to stop server anyway."
Right _ -> return () Right _ -> return ()
shutdownNotify = do shutdownNotify = do
let shutdownTag = C.tag 0 let shutdownTag = C.tag 0
serverShutdownAndNotify internalServer serverCQ shutdownTag serverShutdownAndNotify s scq shutdownTag
grpcDebug "called serverShutdownAndNotify; plucking." grpcDebug "called serverShutdownAndNotify; plucking."
shutdownEvent <- pluck serverCQ shutdownTag (Just 30) shutdownEvent <- pluck scq shutdownTag (Just 30)
grpcDebug $ "shutdownNotify: got shutdown event" ++ show shutdownEvent grpcDebug $ "shutdownNotify: got shutdown event" ++ show shutdownEvent
case shutdownEvent of case shutdownEvent of
-- This case occurs when we pluck but the queue is already in the -- This case occurs when we pluck but the queue is already in the
@ -126,11 +128,42 @@ stopServer Server{..} = do
withServer :: GRPC -> ServerConfig -> (Server -> IO a) -> IO a withServer :: GRPC -> ServerConfig -> (Server -> IO a) -> IO a
withServer grpc cfg = bracket (startServer grpc cfg) stopServer withServer grpc cfg = bracket (startServer grpc cfg) stopServer
-- | Less precisely-typed registration function used in
-- 'serverRegisterMethodNormal', 'serverRegisterMethodServerStreaming',
-- 'serverRegisterMethodClientStreaming', and
-- 'serverRegisterMethodBiDiStreaming'.
serverRegisterMethod :: C.Server
-> MethodName
-> Endpoint
-> GRPCMethodType
-> IO (C.CallHandle)
serverRegisterMethod s nm e mty =
C.grpcServerRegisterMethod s
(unMethodName nm)
(unEndpoint e)
(payloadHandling mty)
{-
TODO: Consolidate the register functions below.
It seems like we'd need true dependent types to use only one
registration function. Ideally we'd want a type like
serverRegisterMethod :: C.Server
-> MethodName
-> Endpoint
-> (t :: GRPCMethodType)
-> IO (RegisteredMethod (Lifted t))
where `Lifted t` is the type in the t data kind that corresponds to the data
constructor t the function was given.
-}
-- | Register a method on a server. The 'RegisteredMethod' type can then be used -- | Register a method on a server. The 'RegisteredMethod' type can then be used
-- to wait for a request to arrive. Note: gRPC claims this must be called before -- to wait for a request to arrive. Note: gRPC claims this must be called before
-- the server is started, so we do it during startup according to the -- the server is started, so we do it during startup according to the
-- 'ServerConfig'. -- 'ServerConfig'.
serverRegisterMethod :: C.Server serverRegisterMethodNormal :: C.Server
-> MethodName -> MethodName
-- ^ method name, e.g. "/foo" -- ^ method name, e.g. "/foo"
-> Endpoint -> Endpoint
@ -139,42 +172,86 @@ serverRegisterMethod :: C.Server
-- parameters to start a server in the first place. It -- parameters to start a server in the first place. It
-- doesn't seem to have any effect, even if it's filled -- doesn't seem to have any effect, even if it's filled
-- with nonsense. -- with nonsense.
-> GRPCMethodType -> IO (RegisteredMethod 'Normal)
-- ^ Type of method this will be. In the future, this will serverRegisterMethodNormal internalServer meth e = do
-- be used to switch to the correct handling logic. h <- serverRegisterMethod internalServer meth e Normal
-> IO (RegisteredMethod mt) return $ RegisteredMethodNormal meth e h
serverRegisterMethod internalServer meth e mty =
RegisteredMethod mty meth e <$> do serverRegisterMethodClientStreaming
h <- C.grpcServerRegisterMethod internalServer :: C.Server
(unMethodName meth) (unEndpoint e) (payloadHandling mty) -> MethodName
grpcDebug $ "registered method handle: " ++ show h ++ " of type " ++ show mty -- ^ method name, e.g. "/foo"
return h -> Endpoint
-- ^ Endpoint name name, e.g. "localhost:9999". I have no
-- idea why this is needed since we have to provide these
-- parameters to start a server in the first place. It
-- doesn't seem to have any effect, even if it's filled
-- with nonsense.
-> IO (RegisteredMethod 'ClientStreaming)
serverRegisterMethodClientStreaming internalServer meth e = do
h <- serverRegisterMethod internalServer meth e ClientStreaming
return $ RegisteredMethodClientStreaming meth e h
serverRegisterMethodServerStreaming
:: C.Server
-> MethodName
-- ^ method name, e.g. "/foo"
-> Endpoint
-- ^ Endpoint name name, e.g. "localhost:9999". I have no
-- idea why this is needed since we have to provide these
-- parameters to start a server in the first place. It
-- doesn't seem to have any effect, even if it's filled
-- with nonsense.
-> IO (RegisteredMethod 'ServerStreaming)
serverRegisterMethodServerStreaming internalServer meth e = do
h <- serverRegisterMethod internalServer meth e ServerStreaming
return $ RegisteredMethodServerStreaming meth e h
serverRegisterMethodBiDiStreaming
:: C.Server
-> MethodName
-- ^ method name, e.g. "/foo"
-> Endpoint
-- ^ Endpoint name name, e.g. "localhost:9999". I have no
-- idea why this is needed since we have to provide these
-- parameters to start a server in the first place. It
-- doesn't seem to have any effect, even if it's filled
-- with nonsense.
-> IO (RegisteredMethod 'BiDiStreaming)
serverRegisterMethodBiDiStreaming internalServer meth e = do
h <- serverRegisterMethod internalServer meth e BiDiStreaming
return $ RegisteredMethodBiDiStreaming meth e h
-- | Create a 'Call' with which to wait for the invocation of a registered -- | Create a 'Call' with which to wait for the invocation of a registered
-- method. -- method.
serverCreateCall :: Server serverCreateCall :: Server
-> RegisteredMethod mt -> RegisteredMethod mt
-> IO (Either GRPCIOError ServerCall) -> CompletionQueue -- ^ call CQ
serverCreateCall Server{..} = serverRequestCall internalServer serverCQ -> IO (Either GRPCIOError (ServerCall (MethodPayload mt)))
serverCreateCall Server{..} rm = serverRequestCall rm unsafeServer serverCQ
withServerCall :: Server withServerCall :: Server
-> RegisteredMethod mt -> RegisteredMethod mt
-> (ServerCall -> IO (Either GRPCIOError a)) -> (ServerCall (MethodPayload mt) -> IO (Either GRPCIOError a))
-> IO (Either GRPCIOError a) -> IO (Either GRPCIOError a)
withServerCall server regmethod f = do withServerCall s rm f =
createResult <- serverCreateCall server regmethod withCompletionQueue (serverGRPC s) $
case createResult of serverCreateCall s rm >=> \case
Left x -> return $ Left x Left e -> return (Left e)
Right call -> f call `finally` logDestroy call Right c -> do
where logDestroy c = grpcDebug "withServerRegisteredCall: destroying." debugServerCall c
>> destroyServerCall c f c `finally` do
grpcDebug "withServerCall(R): destroying."
destroyServerCall c
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- serverReader (server side of client streaming mode) -- serverReader (server side of client streaming mode)
type ServerReaderHandler type ServerReaderHandler
= ServerCall = ServerCall ()
-> StreamRecv -> StreamRecv ByteString
-> Streaming (Maybe ByteString, MetadataMap, C.StatusCode, StatusDetails) -> Streaming (Maybe ByteString, MetadataMap, C.StatusCode, StatusDetails)
serverReader :: Server serverReader :: Server
@ -182,14 +259,13 @@ serverReader :: Server
-> MetadataMap -- ^ initial server metadata -> MetadataMap -- ^ initial server metadata
-> ServerReaderHandler -> ServerReaderHandler
-> IO (Either GRPCIOError ()) -> IO (Either GRPCIOError ())
serverReader s@Server{ serverCQ = cq } rm initMeta f = withServerCall s rm go serverReader s rm initMeta f = withServerCall s rm go
where where
go sc@(unServerCall -> c) = runExceptT $ do go sc@ServerCall{ unsafeSC = c, callCQ = ccq } = runExceptT $ do
lift $ debugServerCall sc (mmsg, trailMeta, st, ds) <-
(mmsg, trailMD, st, ds) <- runStreamingProxy "serverReader" c ccq (f sc streamRecv)
runStreamingProxy "serverReader" c cq (f sc streamRecv) runOps' c ccq ( OpSendInitialMetadata initMeta
runOps' c cq ( OpSendInitialMetadata initMeta : OpSendStatusFromServer trailMeta st ds
: OpSendStatusFromServer trailMD st ds
: maybe [] ((:[]) . OpSendMessage) mmsg : maybe [] ((:[]) . OpSendMessage) mmsg
) )
return () return ()
@ -198,8 +274,8 @@ serverReader s@Server{ serverCQ = cq } rm initMeta f = withServerCall s rm go
-- serverWriter (server side of server streaming mode) -- serverWriter (server side of server streaming mode)
type ServerWriterHandler type ServerWriterHandler
= ServerCall = ServerCall ByteString
-> StreamSend -> StreamSend ByteString
-> Streaming (MetadataMap, C.StatusCode, StatusDetails) -> Streaming (MetadataMap, C.StatusCode, StatusDetails)
-- | Wait for and then handle a registered, server-streaming call. -- | Wait for and then handle a registered, server-streaming call.
@ -209,21 +285,20 @@ serverWriter :: Server
-- ^ Initial server metadata -- ^ Initial server metadata
-> ServerWriterHandler -> ServerWriterHandler
-> IO (Either GRPCIOError ()) -> IO (Either GRPCIOError ())
serverWriter s@Server{ serverCQ = cq } rm initMeta f = withServerCall s rm go serverWriter s rm initMeta f = withServerCall s rm go
where where
go sc@ServerCall{ unServerCall = c } = runExceptT $ do go sc@ServerCall{ unsafeSC = c, callCQ = ccq } = runExceptT $ do
lift (debugServerCall sc) sendInitialMetadata c ccq initMeta
sendInitialMetadata c cq initMeta st <- runStreamingProxy "serverWriter" c ccq (f sc streamSend)
st <- runStreamingProxy "serverWriter" c cq (f sc streamSend) sendStatusFromServer c ccq st
sendStatusFromServer c cq st
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- serverRW (server side of bidirectional streaming mode) -- serverRW (server side of bidirectional streaming mode)
type ServerRWHandler type ServerRWHandler
= ServerCall = ServerCall ()
-> StreamRecv -> StreamRecv ByteString
-> StreamSend -> StreamSend ByteString
-> Streaming (MetadataMap, C.StatusCode, StatusDetails) -> Streaming (MetadataMap, C.StatusCode, StatusDetails)
serverRW :: Server serverRW :: Server
@ -232,13 +307,12 @@ serverRW :: Server
-- ^ initial server metadata -- ^ initial server metadata
-> ServerRWHandler -> ServerRWHandler
-> IO (Either GRPCIOError ()) -> IO (Either GRPCIOError ())
serverRW s@Server{ serverCQ = cq } rm initMeta f = withServerCall s rm go serverRW s rm initMeta f = withServerCall s rm go
where where
go sc@(unServerCall -> c) = runExceptT $ do go sc@ServerCall{ unsafeSC = c, callCQ = ccq } = runExceptT $ do
lift $ debugServerCall sc sendInitialMetadata c ccq initMeta
sendInitialMetadata c cq initMeta st <- runStreamingProxy "serverRW" c ccq (f sc streamRecv streamSend)
st <- runStreamingProxy "serverRW" c cq (f sc streamRecv streamSend) sendStatusFromServer c ccq st
sendStatusFromServer c cq st
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- serverHandleNormalCall (server side of normal request/response) -- serverHandleNormalCall (server side of normal request/response)
@ -250,7 +324,9 @@ serverRW s@Server{ serverCQ = cq } 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 ServerHandler type ServerHandler
= ServerCall -> ByteString -> MetadataMap = ServerCall ByteString
-> ByteString
-> MetadataMap
-> 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.
@ -260,21 +336,15 @@ serverHandleNormalCall :: Server
-- ^ Initial server metadata -- ^ Initial server metadata
-> ServerHandler -> ServerHandler
-> IO (Either GRPCIOError ()) -> IO (Either GRPCIOError ())
serverHandleNormalCall s@Server{ serverCQ = cq } rm initMeta f = serverHandleNormalCall s rm initMeta f =
withServerCall s rm go withServerCall s rm go
where where
go sc@(unServerCall -> call) = do go sc@ServerCall{..} = do
grpcDebug "serverHandleNormalCall(R): starting batch." (rsp, trailMeta, st, ds) <- f sc optionalPayload requestMetadataRecv
debugServerCall sc void <$> runOps unsafeSC callCQ
case optionalPayload sc of
Nothing -> return (Left GRPCIOInternalMissingExpectedPayload)
Just pay -> do
(rspBody, trailMeta, status, ds) <- f sc pay (requestMetadataRecv sc)
eea <- runOps call cq
[ OpSendInitialMetadata initMeta [ OpSendInitialMetadata initMeta
, OpRecvCloseOnServer , OpRecvCloseOnServer
, OpSendMessage rspBody , OpSendMessage rsp
, OpSendStatusFromServer trailMeta status ds , OpSendStatusFromServer trailMeta st ds
] ]
<* grpcDebug "serverHandleNormalCall(R): finished response ops." <* grpcDebug "serverHandleNormalCall(R): finished response ops."
return (void eea)

View file

@ -4,8 +4,10 @@
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 Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Network.GRPC.LowLevel.Call.Unregistered import Network.GRPC.LowLevel.Call.Unregistered
import Network.GRPC.LowLevel.CompletionQueue (CompletionQueue, withCompletionQueue)
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 (..), OpRecvResult (..), import Network.GRPC.LowLevel.Op (Op (..), OpRecvResult (..),
@ -13,20 +15,21 @@ import Network.GRPC.LowLevel.Op (Op (..), Op
import Network.GRPC.LowLevel.Server (Server (..)) import Network.GRPC.LowLevel.Server (Server (..))
import qualified Network.GRPC.Unsafe.Op as C import qualified Network.GRPC.Unsafe.Op as C
serverCreateCall :: Server -> IO (Either GRPCIOError ServerCall) serverCreateCall :: Server
serverCreateCall Server{..} = -> CompletionQueue -- ^ call CQ
serverRequestCall internalServer serverCQ -> IO (Either GRPCIOError ServerCall)
serverCreateCall Server{..} = serverRequestCall unsafeServer serverCQ
withServerCall :: Server withServerCall :: Server
-> (ServerCall -> IO (Either GRPCIOError a)) -> (ServerCall -> IO (Either GRPCIOError a))
-> IO (Either GRPCIOError a) -> IO (Either GRPCIOError a)
withServerCall server f = do withServerCall s f =
createResult <- serverCreateCall server withCompletionQueue (serverGRPC s) $
case createResult of serverCreateCall s >=> \case
Left x -> return $ Left x Left e -> return (Left e)
Right call -> f call `finally` logDestroy call Right c -> f c `finally` do
where logDestroy c = grpcDebug "withServerCall: destroying." grpcDebug "withServerCall: destroying."
>> destroyServerCall c destroyServerCall 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.
-- TODO: We have to put 'OpRecvCloseOnServer' in the response ops, or else the -- TODO: We have to put 'OpRecvCloseOnServer' in the response ops, or else the
@ -51,7 +54,8 @@ serverOpsSendNormalResponse body 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
= ServerCall -> ByteString = ServerCall
-> ByteString
-> IO (ByteString, MetadataMap, C.StatusCode, StatusDetails) -> IO (ByteString, MetadataMap, C.StatusCode, StatusDetails)
-- | Handle one unregistered call. -- | Handle one unregistered call.
@ -59,11 +63,12 @@ serverHandleNormalCall :: Server
-> MetadataMap -- ^ Initial server metadata. -> MetadataMap -- ^ Initial server metadata.
-> ServerHandler -> ServerHandler
-> IO (Either GRPCIOError ()) -> IO (Either GRPCIOError ())
serverHandleNormalCall s@Server{..} srvMetadata f = serverHandleNormalCall s initMeta f = withServerCall s go
withServerCall s $ \call@ServerCall{..} -> do where
go sc@ServerCall{ unsafeSC = c, callCQ = cq, .. } = do
grpcDebug "serverHandleNormalCall(U): starting batch." grpcDebug "serverHandleNormalCall(U): starting batch."
runOps unServerCall serverCQ runOps c cq
[ OpSendInitialMetadata srvMetadata [ OpSendInitialMetadata initMeta
, OpRecvMessage , OpRecvMessage
] ]
>>= \case >>= \case
@ -73,11 +78,11 @@ serverHandleNormalCall s@Server{..} srvMetadata f =
Right [OpRecvMessageResult (Just body)] -> do Right [OpRecvMessageResult (Just body)] -> do
grpcDebug $ "got client metadata: " ++ show requestMetadataRecv grpcDebug $ "got client metadata: " ++ show requestMetadataRecv
grpcDebug $ "call_details host is: " ++ show callHost grpcDebug $ "call_details host is: " ++ show callHost
(rspBody, rspMeta, status, ds) <- f call body (rsp, trailMeta, st, ds) <- f sc body
runOps unServerCall serverCQ runOps c cq
[ OpRecvCloseOnServer [ OpRecvCloseOnServer
, OpSendMessage rspBody, , OpSendMessage rsp,
OpSendStatusFromServer rspMeta status ds OpSendStatusFromServer trailMeta st ds
] ]
>>= \case >>= \case
Left x -> do Left x -> do

View file

@ -7,6 +7,14 @@ resolver: lts-5.10
# Local packages, usually specified by relative directory name # Local packages, usually specified by relative directory name
packages: packages:
- '.' - '.'
- location:
git: git@github.mv.awakenetworks.net:awakenetworks/protobuf-wire.git
commit: e5a6985eeb5eb1eded7b46b2892874000e2ae835
extra-dep: true
- location:
git: git@github.mv.awakenetworks.net:awakenetworks/proto3-wire.git
commit: 9898a793ab61fd582b5b7172d349ffd248b20095
extra-dep: true
# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
extra-deps: [managed-1.0.5] extra-deps: [managed-1.0.5]

View file

@ -70,24 +70,24 @@ testClientCreateDestroy =
testClientTimeoutNoServer :: TestTree testClientTimeoutNoServer :: TestTree
testClientTimeoutNoServer = testClientTimeoutNoServer =
clientOnlyTest "request timeout when server DNE" $ \c -> do clientOnlyTest "request timeout when server DNE" $ \c -> do
rm <- clientRegisterMethod c "/foo" Normal rm <- clientRegisterMethodNormal c "/foo"
r <- clientRequest c rm 1 "Hello" mempty r <- clientRequest c rm 1 "Hello" mempty
r @?= Left GRPCIOTimeout r @?= Left GRPCIOTimeout
testServerCreateDestroy :: TestTree testServerCreateDestroy :: TestTree
testServerCreateDestroy = testServerCreateDestroy =
serverOnlyTest "start/stop" [] nop serverOnlyTest "start/stop" (["/foo"],[],[],[]) nop
testMixRegisteredUnregistered :: TestTree testMixRegisteredUnregistered :: TestTree
testMixRegisteredUnregistered = testMixRegisteredUnregistered =
csTest "server uses unregistered calls to handle unknown endpoints" csTest "server uses unregistered calls to handle unknown endpoints"
client client
server server
[("/foo", Normal)] (["/foo"],[],[],[])
where where
client c = do client c = do
rm1 <- clientRegisterMethod c "/foo" Normal rm1 <- clientRegisterMethodNormal c "/foo"
rm2 <- clientRegisterMethod c "/bar" Normal rm2 <- clientRegisterMethodNormal c "/bar"
clientRequest c rm1 1 "Hello" mempty >>= do clientRequest c rm1 1 "Hello" mempty >>= do
checkReqRslt $ \NormalRequestResult{..} -> do checkReqRslt $ \NormalRequestResult{..} -> do
rspBody @?= "reply test" rspBody @?= "reply test"
@ -121,11 +121,11 @@ testMixRegisteredUnregistered =
-- tweak EH behavior / async use. -- tweak EH behavior / async use.
testPayload :: TestTree testPayload :: TestTree
testPayload = testPayload =
csTest "registered normal request/response" client server [("/foo", Normal)] csTest "registered normal request/response" client server (["/foo"],[],[],[])
where where
clientMD = [("foo_key", "foo_val"), ("bar_key", "bar_val")] clientMD = [("foo_key", "foo_val"), ("bar_key", "bar_val")]
client c = do client c = do
rm <- clientRegisterMethod c "/foo" Normal rm <- clientRegisterMethodNormal c "/foo"
clientRequest c rm 10 "Hello!" clientMD >>= do clientRequest c rm 10 "Hello!" clientMD >>= do
checkReqRslt $ \NormalRequestResult{..} -> do checkReqRslt $ \NormalRequestResult{..} -> do
rspCode @?= StatusOk rspCode @?= StatusOk
@ -143,10 +143,10 @@ testPayload =
testServerCancel :: TestTree testServerCancel :: TestTree
testServerCancel = testServerCancel =
csTest "server cancel call" client server [("/foo", Normal)] csTest "server cancel call" client server (["/foo"],[],[],[])
where where
client c = do client c = do
rm <- clientRegisterMethod c "/foo" Normal rm <- clientRegisterMethodNormal c "/foo"
res <- clientRequest c rm 10 "" mempty res <- clientRequest c rm 10 "" mempty
res @?= badStatus StatusCancelled res @?= badStatus StatusCancelled
server s = do server s = do
@ -158,7 +158,7 @@ testServerCancel =
testServerStreaming :: TestTree testServerStreaming :: TestTree
testServerStreaming = testServerStreaming =
csTest "server streaming" client server [("/feed", ServerStreaming)] csTest "server streaming" client server ([],[],["/feed"],[])
where where
clientInitMD = [("client","initmd")] clientInitMD = [("client","initmd")]
serverInitMD = [("server","initmd")] serverInitMD = [("server","initmd")]
@ -166,7 +166,7 @@ testServerStreaming =
pays = ["ONE", "TWO", "THREE", "FOUR"] :: [ByteString] pays = ["ONE", "TWO", "THREE", "FOUR"] :: [ByteString]
client c = do client c = do
rm <- clientRegisterMethod c "/feed" ServerStreaming rm <- clientRegisterMethodServerStreaming c "/feed"
eea <- clientReader c rm 10 clientPay clientInitMD $ \initMD recv -> do eea <- clientReader c rm 10 clientPay clientInitMD $ \initMD recv -> do
liftIO $ checkMD "Server initial metadata mismatch" serverInitMD initMD liftIO $ checkMD "Server initial metadata mismatch" serverInitMD initMD
forM_ pays $ \p -> recv `is` Right (Just p) forM_ pays $ \p -> recv `is` Right (Just p)
@ -175,20 +175,18 @@ testServerStreaming =
server s = do server s = do
let rm = head (sstreamingMethods s) let rm = head (sstreamingMethods s)
eea <- serverWriter s rm serverInitMD $ \sc send -> do r <- serverWriter s rm serverInitMD $ \sc send -> do
liftIO $ do liftIO $ do
checkMD "Client request metadata mismatch" checkMD "Server request metadata mismatch"
clientInitMD (requestMetadataRecv sc) clientInitMD (requestMetadataRecv sc)
case optionalPayload sc of optionalPayload sc @?= clientPay
Nothing -> assertFailure "expected optional payload"
Just pay -> pay @?= clientPay
forM_ pays $ \p -> send p `is` Right () forM_ pays $ \p -> send p `is` Right ()
return (dummyMeta, StatusOk, "dtls") return (dummyMeta, StatusOk, "dtls")
eea @?= Right () r @?= Right ()
testClientStreaming :: TestTree testClientStreaming :: TestTree
testClientStreaming = testClientStreaming =
csTest "client streaming" client server [("/slurp", ClientStreaming)] csTest "client streaming" client server ([],["/slurp"],[],[])
where where
clientInitMD = [("a","b")] clientInitMD = [("a","b")]
serverInitMD = [("x","y")] serverInitMD = [("x","y")]
@ -199,7 +197,7 @@ testClientStreaming =
pays = ["P_ONE", "P_TWO", "P_THREE"] :: [ByteString] pays = ["P_ONE", "P_TWO", "P_THREE"] :: [ByteString]
client c = do client c = do
rm <- clientRegisterMethod c "/slurp" ClientStreaming rm <- clientRegisterMethodClientStreaming c "/slurp"
eea <- clientWriter c rm 10 clientInitMD $ \send -> do eea <- clientWriter c rm 10 clientInitMD $ \send -> do
-- liftIO $ checkMD "Server initial metadata mismatch" serverInitMD initMD -- liftIO $ checkMD "Server initial metadata mismatch" serverInitMD initMD
forM_ pays $ \p -> send p `is` Right () forM_ pays $ \p -> send p `is` Right ()
@ -217,19 +215,18 @@ testClientStreaming =
testBiDiStreaming :: TestTree testBiDiStreaming :: TestTree
testBiDiStreaming = testBiDiStreaming =
csTest "bidirectional streaming" client server [("/bidi", BiDiStreaming)] csTest "bidirectional streaming" client server ([],[],[],["/bidi"])
where where
clientInitMD = [("bidi-streaming","client")] clientInitMD = [("bidi-streaming","client")]
serverInitMD = [("bidi-streaming","server")] serverInitMD = [("bidi-streaming","server")]
trailMD = dummyMeta trailMD = dummyMeta
serverStatus = StatusOk serverStatus = StatusOk
serverDtls = "deets" serverDtls = "deets"
is act x = act >>= liftIO . (@?= x)
client c = do client c = do
rm <- clientRegisterMethod c "/bidi" BiDiStreaming rm <- clientRegisterMethodBiDiStreaming c "/bidi"
eea <- clientRW c rm 10 clientInitMD $ \initMD recv send -> do eea <- clientRW c rm 10 clientInitMD $ \initMD recv send -> do
liftIO $ checkMD "Server initial metadata mismatch"
serverInitMD initMD
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 ()
@ -263,13 +260,13 @@ testClientCall =
testServerCall :: TestTree testServerCall :: TestTree
testServerCall = testServerCall =
serverOnlyTest "create/destroy call" [] $ \s -> do serverOnlyTest "create/destroy call" ([],[],[],[]) $ \s -> do
r <- U.withServerCall s $ const $ return $ Right () r <- U.withServerCall s $ const $ return $ Right ()
r @?= Left GRPCIOTimeout r @?= Left GRPCIOTimeout
testPayloadUnregistered :: TestTree testPayloadUnregistered :: TestTree
testPayloadUnregistered = testPayloadUnregistered =
csTest "unregistered normal request/response" client server [] csTest "unregistered normal request/response" client server ([],[],[],[])
where where
client c = client c =
U.clientRequest c "/foo" 10 "Hello!" mempty >>= do U.clientRequest c "/foo" 10 "Hello!" mempty >>= do
@ -289,10 +286,10 @@ testGoaway =
csTest "Client handles server shutdown gracefully" csTest "Client handles server shutdown gracefully"
client client
server server
[("/foo", Normal)] (["/foo"],[],[],[])
where where
client c = do client c = do
rm <- clientRegisterMethod c "/foo" Normal rm <- clientRegisterMethodNormal c "/foo"
clientRequest c rm 10 "" mempty clientRequest c rm 10 "" mempty
clientRequest c rm 10 "" mempty clientRequest c rm 10 "" mempty
lastResult <- clientRequest c rm 1 "" mempty lastResult <- clientRequest c rm 1 "" mempty
@ -310,10 +307,10 @@ testGoaway =
testSlowServer :: TestTree testSlowServer :: TestTree
testSlowServer = testSlowServer =
csTest "Client handles slow server response" client server [("/foo", Normal)] csTest "Client handles slow server response" client server (["/foo"],[],[],[])
where where
client c = do client c = do
rm <- clientRegisterMethod c "/foo" Normal rm <- clientRegisterMethodNormal c "/foo"
result <- clientRequest c rm 1 "" mempty result <- clientRequest c rm 1 "" mempty
result @?= badStatus StatusDeadlineExceeded result @?= badStatus StatusDeadlineExceeded
server s = do server s = do
@ -325,10 +322,10 @@ testSlowServer =
testServerCallExpirationCheck :: TestTree testServerCallExpirationCheck :: TestTree
testServerCallExpirationCheck = testServerCallExpirationCheck =
csTest "Check for call expiration" client server [("/foo", Normal)] csTest "Check for call expiration" client server (["/foo"],[],[],[])
where where
client c = do client c = do
rm <- clientRegisterMethod c "/foo" Normal rm <- clientRegisterMethodNormal c "/foo"
result <- clientRequest c rm 3 "" mempty result <- clientRequest c rm 3 "" mempty
return () return ()
server s = do server s = do
@ -352,10 +349,10 @@ testCustomUserAgent =
clientArgs = [UserAgentPrefix "prefix!", UserAgentSuffix "suffix!"] clientArgs = [UserAgentPrefix "prefix!", UserAgentSuffix "suffix!"]
client = client =
TestClient (ClientConfig "localhost" 50051 clientArgs) $ TestClient (ClientConfig "localhost" 50051 clientArgs) $
\c -> do rm <- clientRegisterMethod c "/foo" Normal \c -> do rm <- clientRegisterMethodNormal c "/foo"
result <- clientRequest c rm 4 "" mempty result <- clientRequest c rm 4 "" mempty
return () return ()
server = TestServer (stdServerConf [("/foo", Normal)]) $ \s -> do server = TestServer (serverConf (["/foo"],[],[],[])) $ \s -> do
let rm = head (normalMethods s) let rm = head (normalMethods s)
serverHandleNormalCall s rm mempty $ \_ _ meta -> do serverHandleNormalCall s rm mempty $ \_ _ meta -> do
let ua = meta M.! "user-agent" let ua = meta M.! "user-agent"
@ -373,10 +370,10 @@ testClientCompression =
"localhost" "localhost"
50051 50051
[CompressionAlgArg GrpcCompressDeflate]) $ \c -> do [CompressionAlgArg GrpcCompressDeflate]) $ \c -> do
rm <- clientRegisterMethod c "/foo" Normal rm <- clientRegisterMethodNormal c "/foo"
result <- clientRequest c rm 1 "hello" mempty result <- clientRequest c rm 1 "hello" mempty
return () return ()
server = TestServer (stdServerConf [("/foo", Normal)]) $ \s -> do server = TestServer (serverConf (["/foo"],[],[],[])) $ \s -> do
let rm = head (normalMethods s) let rm = head (normalMethods s)
serverHandleNormalCall s rm mempty $ \_ body _ -> do serverHandleNormalCall s rm mempty $ \_ body _ -> do
body @?= "hello" body @?= "hello"
@ -391,7 +388,7 @@ testClientServerCompression =
50051 50051
[CompressionAlgArg GrpcCompressDeflate] [CompressionAlgArg GrpcCompressDeflate]
client = TestClient cconf $ \c -> do client = TestClient cconf $ \c -> do
rm <- clientRegisterMethod c "/foo" Normal rm <- clientRegisterMethodNormal c "/foo"
clientRequest c rm 1 "hello" mempty >>= do clientRequest c rm 1 "hello" mempty >>= do
checkReqRslt $ \NormalRequestResult{..} -> do checkReqRslt $ \NormalRequestResult{..} -> do
rspCode @?= StatusOk rspCode @?= StatusOk
@ -402,7 +399,7 @@ testClientServerCompression =
return () return ()
sconf = ServerConfig "localhost" sconf = ServerConfig "localhost"
50051 50051
[("/foo", Normal)] ["/foo"] [] [] []
[CompressionAlgArg GrpcCompressDeflate] [CompressionAlgArg GrpcCompressDeflate]
server = TestServer sconf $ \s -> do server = TestServer sconf $ \s -> do
let rm = head (normalMethods s) let rm = head (normalMethods s)
@ -423,7 +420,7 @@ dummyMeta = [("foo","bar")]
dummyResp :: (ByteString, MetadataMap, StatusCode, StatusDetails) dummyResp :: (ByteString, MetadataMap, StatusCode, StatusDetails)
dummyResp = ("", mempty, StatusOk, StatusDetails "") dummyResp = ("", mempty, StatusOk, StatusDetails "")
dummyHandler :: ServerCall -> ByteString -> MetadataMap dummyHandler :: ServerCall a -> ByteString -> MetadataMap
-> IO (ByteString, MetadataMap, StatusCode, StatusDetails) -> IO (ByteString, MetadataMap, StatusCode, StatusDetails)
dummyHandler _ _ _ = return dummyResp dummyHandler _ _ _ = return dummyResp
@ -441,11 +438,11 @@ nop :: Monad m => a -> m ()
nop = const (return ()) nop = const (return ())
serverOnlyTest :: TestName serverOnlyTest :: TestName
-> [(MethodName, GRPCMethodType)] -> ([MethodName],[MethodName],[MethodName],[MethodName])
-> (Server -> IO ()) -> (Server -> IO ())
-> TestTree -> TestTree
serverOnlyTest nm ms = serverOnlyTest nm ms =
testCase ("Server - " ++ nm) . runTestServer . stdTestServer ms testCase ("Server - " ++ nm) . runTestServer . TestServer (serverConf ms)
clientOnlyTest :: TestName -> (Client -> IO ()) -> TestTree clientOnlyTest :: TestName -> (Client -> IO ()) -> TestTree
clientOnlyTest nm = clientOnlyTest nm =
@ -454,9 +451,10 @@ clientOnlyTest nm =
csTest :: TestName csTest :: TestName
-> (Client -> IO ()) -> (Client -> IO ())
-> (Server -> IO ()) -> (Server -> IO ())
-> [(MethodName, GRPCMethodType)] -> ([MethodName],[MethodName],[MethodName],[MethodName])
-> TestTree -> TestTree
csTest nm c s ms = csTest' nm (stdTestClient c) (stdTestServer ms s) csTest nm c s ms =
csTest' nm (stdTestClient c) (TestServer (serverConf ms) s)
csTest' :: TestName -> TestClient -> TestServer -> TestTree csTest' :: TestName -> TestClient -> TestServer -> TestTree
csTest' nm tc ts = csTest' nm tc ts =
@ -505,11 +503,16 @@ runTestServer :: TestServer -> IO ()
runTestServer (TestServer conf f) = runTestServer (TestServer conf f) =
runManaged $ mgdGRPC >>= mgdServer conf >>= liftIO . f runManaged $ mgdGRPC >>= mgdServer conf >>= liftIO . f
stdTestServer :: [(MethodName, GRPCMethodType)] -> (Server -> IO ()) -> TestServer defServerConf :: ServerConfig
stdTestServer = TestServer . stdServerConf defServerConf = ServerConfig "localhost" 50051 [] [] [] [] []
stdServerConf :: [(MethodName, GRPCMethodType)] -> ServerConfig serverConf :: ([MethodName],[MethodName],[MethodName],[MethodName])
stdServerConf xs = ServerConfig "localhost" 50051 xs [] -> ServerConfig
serverConf (ns, cs, ss, bs) =
defServerConf {methodsToRegisterNormal = ns,
methodsToRegisterClientStreaming = cs,
methodsToRegisterServerStreaming = ss,
methodsToRegisterBiDiStreaming = bs}
threadDelaySecs :: Int -> IO () threadDelaySecs :: Int -> IO ()
threadDelaySecs = threadDelay . (* 10^(6::Int)) threadDelaySecs = threadDelay . (* 10^(6::Int))

View file

@ -4,9 +4,7 @@
module LowLevelTests.Op where module LowLevelTests.Op where
import Control.Concurrent (threadDelay) import Data.ByteString (ByteString, isPrefixOf)
import Data.ByteString (isPrefixOf)
import Foreign.Storable (peek)
import Test.Tasty import Test.Tasty
import Test.Tasty.HUnit as HU (testCase, (@?=), import Test.Tasty.HUnit as HU (testCase, (@?=),
assertBool) assertBool)
@ -16,7 +14,6 @@ import Network.GRPC.LowLevel.Call
import Network.GRPC.LowLevel.Client import Network.GRPC.LowLevel.Client
import Network.GRPC.LowLevel.Server import Network.GRPC.LowLevel.Server
import Network.GRPC.LowLevel.Op import Network.GRPC.LowLevel.Op
import Network.GRPC.LowLevel.CompletionQueue
lowLevelOpTests :: TestTree lowLevelOpTests :: TestTree
lowLevelOpTests = testGroup "Synchronous unit tests of low-level Op interface" lowLevelOpTests = testGroup "Synchronous unit tests of low-level Op interface"
@ -29,7 +26,7 @@ testCancelFromServer =
withClientServerUnaryCall grpc $ withClientServerUnaryCall grpc $
\(Client{..}, Server{..}, ClientCall{..}, sc@ServerCall{..}) -> do \(Client{..}, Server{..}, ClientCall{..}, sc@ServerCall{..}) -> do
serverCallCancel sc StatusPermissionDenied "TestStatus" serverCallCancel sc StatusPermissionDenied "TestStatus"
clientRes <- runOps unClientCall clientCQ clientRecvOps clientRes <- runOps unsafeCC clientCQ clientRecvOps
case clientRes of case clientRes of
Left x -> error $ "Client recv error: " ++ show x Left x -> error $ "Client recv error: " ++ show x
Right [_,_,OpRecvStatusOnClientResult _ code details] -> do Right [_,_,OpRecvStatusOnClientResult _ code details] -> do
@ -48,12 +45,13 @@ runSerialTest f =
Right () -> return () Right () -> return ()
withClientServerUnaryCall :: GRPC withClientServerUnaryCall :: GRPC
-> ((Client, Server, ClientCall, ServerCall) -> ((Client, Server, ClientCall,
ServerCall ByteString)
-> IO (Either GRPCIOError a)) -> IO (Either GRPCIOError a))
-> IO (Either GRPCIOError a) -> IO (Either GRPCIOError a)
withClientServerUnaryCall grpc f = do withClientServerUnaryCall grpc f = do
withClient grpc clientConf $ \c -> do withClient grpc clientConf $ \c -> do
crm <- clientRegisterMethod c "/foo" Normal crm <- clientRegisterMethodNormal c "/foo"
withServer grpc serverConf $ \s -> withServer grpc serverConf $ \s ->
withClientCall c crm 10 $ \cc -> do withClientCall c crm 10 $ \cc -> do
let srm = head (normalMethods s) let srm = head (normalMethods s)
@ -61,12 +59,12 @@ withClientServerUnaryCall grpc f = do
-- because registered methods try to do recv ops immediately when -- because registered methods try to do recv ops immediately when
-- created. If later we want to send payloads or metadata, we'll need -- created. If later we want to send payloads or metadata, we'll need
-- to tweak this. -- to tweak this.
_clientRes <- runOps (unClientCall cc) (clientCQ c) clientEmptySendOps _clientRes <- runOps (unsafeCC cc) (clientCQ c) clientEmptySendOps
withServerCall s srm $ \sc -> withServerCall s srm $ \sc ->
f (c, s, cc, sc) f (c, s, cc, sc)
serverConf :: ServerConfig serverConf :: ServerConfig
serverConf = ServerConfig "localhost" 50051 [("/foo", Normal)] [] serverConf = ServerConfig "localhost" 50051 [("/foo")] [] [] [] []
clientConf :: ClientConfig clientConf :: ClientConfig
clientConf = ClientConfig "localhost" 50051 [] clientConf = ClientConfig "localhost" 50051 []