packages feed

grpc-haskell-core (empty) → 0.0.0.0

raw patch · 32 files changed

+6073/−0 lines, 32 filesdep +QuickCheckdep +asyncdep +basesetup-changed

Dependencies added: QuickCheck, async, base, bytestring, clock, containers, grpc-haskell-core, managed, pipes, proto3-suite, safe, sorted-list, stm, tasty, tasty-hunit, tasty-quickcheck, text, time, transformers, turtle, unix

Files

+ LICENSE view
@@ -0,0 +1,203 @@++                                 Apache License+                           Version 2.0, January 2004+                        http://www.apache.org/licenses/++   TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++   1. Definitions.++      "License" shall mean the terms and conditions for use, reproduction,+      and distribution as defined by Sections 1 through 9 of this document.++      "Licensor" shall mean the copyright owner or entity authorized by+      the copyright owner that is granting the License.++      "Legal Entity" shall mean the union of the acting entity and all+      other entities that control, are controlled by, or are under common+      control with that entity. For the purposes of this definition,+      "control" means (i) the power, direct or indirect, to cause the+      direction or management of such entity, whether by contract or+      otherwise, or (ii) ownership of fifty percent (50%) or more of the+      outstanding shares, or (iii) beneficial ownership of such entity.++      "You" (or "Your") shall mean an individual or Legal Entity+      exercising permissions granted by this License.++      "Source" form shall mean the preferred form for making modifications,+      including but not limited to software source code, documentation+      source, and configuration files.++      "Object" form shall mean any form resulting from mechanical+      transformation or translation of a Source form, including but+      not limited to compiled object code, generated documentation,+      and conversions to other media types.++      "Work" shall mean the work of authorship, whether in Source or+      Object form, made available under the License, as indicated by a+      copyright notice that is included in or attached to the work+      (an example is provided in the Appendix below).++      "Derivative Works" shall mean any work, whether in Source or Object+      form, that is based on (or derived from) the Work and for which the+      editorial revisions, annotations, elaborations, or other modifications+      represent, as a whole, an original work of authorship. For the purposes+      of this License, Derivative Works shall not include works that remain+      separable from, or merely link (or bind by name) to the interfaces of,+      the Work and Derivative Works thereof.++      "Contribution" shall mean any work of authorship, including+      the original version of the Work and any modifications or additions+      to that Work or Derivative Works thereof, that is intentionally+      submitted to Licensor for inclusion in the Work by the copyright owner+      or by an individual or Legal Entity authorized to submit on behalf of+      the copyright owner. For the purposes of this definition, "submitted"+      means any form of electronic, verbal, or written communication sent+      to the Licensor or its representatives, including but not limited to+      communication on electronic mailing lists, source code control systems,+      and issue tracking systems that are managed by, or on behalf of, the+      Licensor for the purpose of discussing and improving the Work, but+      excluding communication that is conspicuously marked or otherwise+      designated in writing by the copyright owner as "Not a Contribution."++      "Contributor" shall mean Licensor and any individual or Legal Entity+      on behalf of whom a Contribution has been received by Licensor and+      subsequently incorporated within the Work.++   2. Grant of Copyright License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      copyright license to reproduce, prepare Derivative Works of,+      publicly display, publicly perform, sublicense, and distribute the+      Work and such Derivative Works in Source or Object form.++   3. Grant of Patent License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      (except as stated in this section) patent license to make, have made,+      use, offer to sell, sell, import, and otherwise transfer the Work,+      where such license applies only to those patent claims licensable+      by such Contributor that are necessarily infringed by their+      Contribution(s) alone or by combination of their Contribution(s)+      with the Work to which such Contribution(s) was submitted. If You+      institute patent litigation against any entity (including a+      cross-claim or counterclaim in a lawsuit) alleging that the Work+      or a Contribution incorporated within the Work constitutes direct+      or contributory patent infringement, then any patent licenses+      granted to You under this License for that Work shall terminate+      as of the date such litigation is filed.++   4. Redistribution. You may reproduce and distribute copies of the+      Work or Derivative Works thereof in any medium, with or without+      modifications, and in Source or Object form, provided that You+      meet the following conditions:++      (a) You must give any other recipients of the Work or+          Derivative Works a copy of this License; and++      (b) You must cause any modified files to carry prominent notices+          stating that You changed the files; and++      (c) You must retain, in the Source form of any Derivative Works+          that You distribute, all copyright, patent, trademark, and+          attribution notices from the Source form of the Work,+          excluding those notices that do not pertain to any part of+          the Derivative Works; and++      (d) If the Work includes a "NOTICE" text file as part of its+          distribution, then any Derivative Works that You distribute must+          include a readable copy of the attribution notices contained+          within such NOTICE file, excluding those notices that do not+          pertain to any part of the Derivative Works, in at least one+          of the following places: within a NOTICE text file distributed+          as part of the Derivative Works; within the Source form or+          documentation, if provided along with the Derivative Works; or,+          within a display generated by the Derivative Works, if and+          wherever such third-party notices normally appear. The contents+          of the NOTICE file are for informational purposes only and+          do not modify the License. You may add Your own attribution+          notices within Derivative Works that You distribute, alongside+          or as an addendum to the NOTICE text from the Work, provided+          that such additional attribution notices cannot be construed+          as modifying the License.++      You may add Your own copyright statement to Your modifications and+      may provide additional or different license terms and conditions+      for use, reproduction, or distribution of Your modifications, or+      for any such Derivative Works as a whole, provided Your use,+      reproduction, and distribution of the Work otherwise complies with+      the conditions stated in this License.++   5. Submission of Contributions. Unless You explicitly state otherwise,+      any Contribution intentionally submitted for inclusion in the Work+      by You to the Licensor shall be under the terms and conditions of+      this License, without any additional terms or conditions.+      Notwithstanding the above, nothing herein shall supersede or modify+      the terms of any separate license agreement you may have executed+      with Licensor regarding such Contributions.++   6. Trademarks. This License does not grant permission to use the trade+      names, trademarks, service marks, or product names of the Licensor,+      except as required for reasonable and customary use in describing the+      origin of the Work and reproducing the content of the NOTICE file.++   7. Disclaimer of Warranty. Unless required by applicable law or+      agreed to in writing, Licensor provides the Work (and each+      Contributor provides its Contributions) on an "AS IS" BASIS,+      WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+      implied, including, without limitation, any warranties or conditions+      of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+      PARTICULAR PURPOSE. You are solely responsible for determining the+      appropriateness of using or redistributing the Work and assume any+      risks associated with Your exercise of permissions under this License.++   8. Limitation of Liability. In no event and under no legal theory,+      whether in tort (including negligence), contract, or otherwise,+      unless required by applicable law (such as deliberate and grossly+      negligent acts) or agreed to in writing, shall any Contributor be+      liable to You for damages, including any direct, indirect, special,+      incidental, or consequential damages of any character arising as a+      result of this License or out of the use or inability to use the+      Work (including but not limited to damages for loss of goodwill,+      work stoppage, computer failure or malfunction, or any and all+      other commercial damages or losses), even if such Contributor+      has been advised of the possibility of such damages.++   9. Accepting Warranty or Additional Liability. While redistributing+      the Work or Derivative Works thereof, You may choose to offer,+      and charge a fee for, acceptance of support, warranty, indemnity,+      or other liability obligations and/or rights consistent with this+      License. However, in accepting such obligations, You may act only+      on Your own behalf and on Your sole responsibility, not on behalf+      of any other Contributor, and only if You agree to indemnify,+      defend, and hold each Contributor harmless for any liability+      incurred by, or claims asserted against, such Contributor by reason+      of your accepting any such warranty or additional liability.++   END OF TERMS AND CONDITIONS++   APPENDIX: How to apply the Apache License to your work.++      To apply the Apache License to your work, attach the following+      boilerplate notice, with the fields enclosed by brackets "[]"+      replaced with your own identifying information. (Don't include+      the brackets!)  The text should be enclosed in the appropriate+      comment syntax for the file format. We also recommend that a+      file or class name and description of purpose be included on the+      same "printed page" as the copyright notice for easier+      identification within third-party archives.++   Copyright 2016 Awake Networks+   Copyright 2015 Alois Cochard https://github.com/aloiscochard/grpc-haskell++   Licensed under the Apache License, Version 2.0 (the "License");+   you may not use this file except in compliance with the License.+   You may obtain a copy of the License at++       http://www.apache.org/licenses/LICENSE-2.0++   Unless required by applicable law or agreed to in writing, software+   distributed under the License is distributed on an "AS IS" BASIS,+   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+   See the License for the specific language governing permissions and+   limitations under the License.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cbits/grpc_haskell.c view
@@ -0,0 +1,565 @@+#include <grpc/grpc.h>+#include <grpc/byte_buffer.h>+#include <grpc/byte_buffer_reader.h>+#include <grpc/grpc_security.h>+#include <grpc/impl/codegen/grpc_types.h>+#include <grpc/impl/codegen/compression_types.h>+#include <grpc/slice.h>+#include <stdio.h>+#include <stdlib.h>+#include <string.h>+#include <grpc_haskell.h>++void grpc_haskell_free(char *debugMsg, void *ptr){+  #ifdef GRPC_HASKELL_DEBUG+  printf("C wrapper: %s: freeing ptr: %p\n", debugMsg, ptr);+  #endif+  free(ptr);+}++grpc_event *grpc_completion_queue_next_(grpc_completion_queue *cq,+                                        gpr_timespec *deadline,+                                        void *reserved) {+  grpc_event *toReturn = malloc(sizeof(grpc_event));+  *toReturn = grpc_completion_queue_next(cq, *deadline, reserved);+  return toReturn;+}++grpc_event *grpc_completion_queue_pluck_(grpc_completion_queue *cq, void *tag,+                                         gpr_timespec *deadline,+                                         void *reserved) {+  grpc_event *toReturn = malloc(sizeof(grpc_event));+  *toReturn = grpc_completion_queue_pluck(cq, tag, *deadline, reserved);+  return toReturn;+}++grpc_call *grpc_channel_create_call_(grpc_channel *channel,+                                     grpc_call *parent_call,+                                     uint32_t propagation_mask,+                                     grpc_completion_queue *completion_queue,+                                     const char *method, const char *host,+                                     gpr_timespec *deadline, void *reserved) {+  grpc_slice method_slice = grpc_slice_from_copied_string(method);+  grpc_slice host_slice = grpc_slice_from_copied_string(host);+  return grpc_channel_create_call(channel, parent_call, propagation_mask,+                                       completion_queue, method_slice,+                                       &host_slice, *deadline, reserved);+}++grpc_slice* grpc_slice_malloc_(size_t len){+  grpc_slice* retval = malloc(sizeof(grpc_slice));+  *retval = grpc_slice_malloc(len);+  return retval;+}++size_t grpc_slice_length_(grpc_slice *slice){+  return GRPC_SLICE_LENGTH(*slice);+}++uint8_t *grpc_slice_start_(grpc_slice *slice){+  return GRPC_SLICE_START_PTR(*slice);+}+++grpc_slice* grpc_slice_from_copied_string_(const char* source){+  grpc_slice* retval = malloc(sizeof(grpc_slice));+  *retval = grpc_slice_from_copied_string(source);+  return retval;+}++grpc_slice* grpc_slice_from_copied_buffer_(const char *source, size_t len){+  grpc_slice* retval = malloc(sizeof(grpc_slice));+  //note: 'grpc_slice_from_copied_string' handles allocating space for 'source'.+  *retval = grpc_slice_from_copied_buffer(source, len);+  return retval;+}++void grpc_slice_unref_(grpc_slice* slice){+  grpc_slice_unref(*slice);+}++void free_slice(grpc_slice *slice){+  grpc_slice_unref(*slice);+  grpc_haskell_free("free_slice", slice);+}++grpc_byte_buffer **create_receiving_byte_buffer(){+  grpc_byte_buffer **retval = malloc(sizeof(grpc_byte_buffer*));+  *retval = NULL;+  return retval;+}++void destroy_receiving_byte_buffer(grpc_byte_buffer **bb){+  grpc_byte_buffer_destroy(*bb);+  grpc_haskell_free("destroy_receiving_byte_buffer", bb);+}++grpc_byte_buffer_reader *byte_buffer_reader_create(grpc_byte_buffer *buffer){+  grpc_byte_buffer_reader *reader = malloc(sizeof(grpc_byte_buffer_reader));+  grpc_byte_buffer_reader_init(reader, buffer);+  return reader;+}++void byte_buffer_reader_destroy(grpc_byte_buffer_reader *reader){+  grpc_byte_buffer_reader_destroy(reader);+  grpc_haskell_free("byte_buffer_reader_destroy", reader);+}++grpc_slice *grpc_byte_buffer_reader_readall_(grpc_byte_buffer_reader *reader){+  grpc_slice *retval = malloc(sizeof(grpc_slice));+  *retval = grpc_byte_buffer_reader_readall(reader);+  return retval;+}++void timespec_destroy(gpr_timespec* t){+  grpc_haskell_free("timespec_destroy", t);+}++gpr_timespec* gpr_inf_future_(gpr_clock_type t){+  gpr_timespec *retval = malloc(sizeof(gpr_timespec));+  *retval = gpr_inf_future(t);+  return retval;+}++gpr_timespec* gpr_now_(gpr_clock_type t){+  gpr_timespec *retval = malloc(sizeof(gpr_timespec));+  *retval = gpr_now(t);+  return retval;+}++int32_t gpr_time_to_millis_(gpr_timespec* t){+  return gpr_time_to_millis(*t);+}++gpr_timespec* seconds_to_deadline(int64_t seconds){+  gpr_timespec *retval = malloc(sizeof(gpr_timespec));+  *retval = gpr_time_add(gpr_now(GPR_CLOCK_MONOTONIC),+                         gpr_time_from_millis(seconds * 1e3, GPR_TIMESPAN));+  return retval;+}++gpr_timespec* millis_to_deadline(int64_t millis){+  gpr_timespec *retval = malloc(sizeof(gpr_timespec));+  *retval = gpr_time_add(gpr_now(GPR_CLOCK_MONOTONIC),+                         gpr_time_from_micros(millis * 1e3, GPR_TIMESPAN));+  return retval;+}++gpr_timespec* infinite_deadline(){+  gpr_timespec *retval = malloc(sizeof(gpr_timespec));+  *retval = gpr_inf_future(GPR_CLOCK_MONOTONIC);+  return retval;+}++gpr_timespec* convert_clock_type(gpr_timespec *t, gpr_clock_type to){+  gpr_timespec *retval = malloc(sizeof(gpr_timespec));+  *retval = gpr_convert_clock_type(*t, to);+  return retval;+}++grpc_metadata_array** metadata_array_create(){+  grpc_metadata_array **retval = malloc(sizeof(grpc_metadata_array*));+  *retval = malloc(sizeof(grpc_metadata_array));+  grpc_metadata_array_init(*retval);+  #ifdef GRPC_HASKELL_DEBUG+  printf("C wrapper: metadata_array_create debug: %p %p %p\n", retval, *retval,+         (*retval)->metadata);+  #endif+  return retval;+}++void metadata_array_destroy(grpc_metadata_array **arr){+  grpc_metadata_array_destroy(*arr);+  grpc_haskell_free("metadata_array_destroy1", *arr);+  grpc_haskell_free("metadata_array_destroy1", arr);+}++grpc_metadata* metadata_alloc(size_t n){+  grpc_metadata *retval = calloc(n,sizeof(grpc_metadata));+  return retval;+}++void metadata_free(grpc_metadata* m){+  grpc_haskell_free("metadata_free", m);+}++void set_metadata_key_val(char *key, char *val, size_t val_len,+                          grpc_metadata *arr, size_t i){+  grpc_metadata *p = arr + i;+  p->key = grpc_slice_from_copied_string(key);+  p->value = grpc_slice_from_copied_buffer(val,val_len);+}++grpc_slice* get_metadata_key(grpc_metadata *arr, size_t i){+  grpc_metadata *p = arr + i;+  return &p->key;+}++grpc_slice* get_metadata_val(grpc_metadata *arr, size_t i){+  grpc_metadata *p = arr + i;+  return &(p->value);+}++grpc_op* op_array_create(size_t n){+  grpc_op* ops = malloc(n*sizeof(grpc_op));+  memset(ops, 0, n*sizeof(grpc_op));+  return ops;+}++void op_array_destroy(grpc_op* op_array, size_t n){+  #ifdef GRPC_HASKELL_DEBUG+  printf("C wrapper: entered op_array_destroy\n");+  #endif+  for(int i = 0; i < n; i++){+    grpc_op* op = op_array + i;+    switch (op->op) {+      case GRPC_OP_SEND_INITIAL_METADATA:+      metadata_free(op->data.send_initial_metadata.metadata);+      break;+      case GRPC_OP_SEND_MESSAGE:+      grpc_byte_buffer_destroy(op->data.send_message.send_message);+      break;+      case GRPC_OP_SEND_CLOSE_FROM_CLIENT:+      break;+      case GRPC_OP_SEND_STATUS_FROM_SERVER:+      grpc_haskell_free("op_array_destroy: GRPC_OP_SEND_STATUS_FROM_SERVER",+                        op->data.send_status_from_server.trailing_metadata);+      grpc_haskell_free("op_array_destroy: GRPC_OP_SEND_STATUS_FROM_SERVER",+                      (char*)(op->data.send_status_from_server.status_details));+      break;+      case GRPC_OP_RECV_INITIAL_METADATA:+      break;+      case GRPC_OP_RECV_MESSAGE:+      break;+      case GRPC_OP_RECV_STATUS_ON_CLIENT:+      break;+      case GRPC_OP_RECV_CLOSE_ON_SERVER:+      break;+    }+  }+  grpc_haskell_free("op_array_destroy", op_array);+}++void op_send_initial_metadata(grpc_op *op_array, size_t i,+                              grpc_metadata *arr, size_t n_metadata){+  grpc_op *op = op_array + i;+  op->op = GRPC_OP_SEND_INITIAL_METADATA;+  op->data.send_initial_metadata.count = n_metadata;+  op->data.send_initial_metadata.metadata+    = malloc(n_metadata*sizeof(grpc_metadata));+  memcpy(op->data.send_initial_metadata.metadata, arr,+         n_metadata*sizeof(grpc_metadata));+  op->flags = 0;+  op->reserved = NULL;+}++void op_send_initial_metadata_empty(grpc_op *op_array, size_t i){+  grpc_op *op = op_array + i;+  op->op = GRPC_OP_SEND_INITIAL_METADATA;+  op->data.send_initial_metadata.count = 0;+  op->data.send_initial_metadata.metadata = malloc(0*sizeof(grpc_metadata));+  op->flags = 0;+  op->reserved = NULL;+}++void op_send_message(grpc_op *op_array, size_t i,+                         grpc_byte_buffer *payload){+  grpc_op *op = op_array + i;+  op->op = GRPC_OP_SEND_MESSAGE;+  op->data.send_message.send_message = grpc_byte_buffer_copy(payload);+  op->flags = 0;+  op->reserved = NULL;+}++void op_send_close_client(grpc_op *op_array, size_t i){+  grpc_op *op = op_array + i;+  op->op = GRPC_OP_SEND_CLOSE_FROM_CLIENT;+  op->flags = 0;+  op->reserved = NULL;+}++void op_recv_initial_metadata(grpc_op *op_array, size_t i,+                              grpc_metadata_array** arr){+  grpc_op *op = op_array + i;+  op->op = GRPC_OP_RECV_INITIAL_METADATA;+  op->data.recv_initial_metadata.recv_initial_metadata = *arr;+  op->flags = 0;+  op->reserved = NULL;+}++void op_recv_message(grpc_op *op_array, size_t i,+                     grpc_byte_buffer **payload_recv){+  grpc_op *op = op_array + i;+  op->op = GRPC_OP_RECV_MESSAGE;+  op->data.recv_message.recv_message = payload_recv;+  op->flags = 0;+  op->reserved = NULL;+}++void op_recv_status_client(grpc_op *op_array, size_t i,+                           grpc_metadata_array** arr,+                           grpc_status_code* status,+                           grpc_slice* details){+  grpc_op *op = op_array + i;+  op->op = GRPC_OP_RECV_STATUS_ON_CLIENT;+  op->data.recv_status_on_client.trailing_metadata = *arr;+  op->data.recv_status_on_client.status = status;+  op->data.recv_status_on_client.status_details = details;+  op->flags = 0;+  op->reserved = NULL;+}++void op_recv_close_server(grpc_op *op_array, size_t i, int *was_cancelled){+  grpc_op *op = op_array + i;+  op->op = GRPC_OP_RECV_CLOSE_ON_SERVER;+  op->data.recv_close_on_server.cancelled = was_cancelled;+  op->flags = 0;+  op->reserved = NULL;+}++void op_send_status_server(grpc_op *op_array, size_t i,+                           size_t metadata_count, grpc_metadata* m,+                           grpc_status_code status, grpc_slice *details){+  grpc_op *op = op_array + i;+  op->op = GRPC_OP_SEND_STATUS_FROM_SERVER;+  op->data.send_status_from_server.trailing_metadata_count = metadata_count;+  op->data.send_status_from_server.trailing_metadata+    = malloc(sizeof(grpc_metadata)*metadata_count);+  memcpy(op->data.send_status_from_server.trailing_metadata, m,+         metadata_count*sizeof(grpc_metadata));+  op->data.send_status_from_server.status = status;+  op->data.send_status_from_server.status_details = details;+  op->flags = 0;+  op->reserved = NULL;+}++grpc_status_code* create_status_code_ptr(){+  grpc_status_code* retval = malloc(sizeof(grpc_status_code));+  #ifdef GRPC_HASKELL_DEBUG+  printf("C wrapper: create_status_code_ptr debug: %p\n", retval);+  #endif+  return retval;+}++grpc_status_code deref_status_code_ptr(grpc_status_code* p){+  return *p;+}++void destroy_status_code_ptr(grpc_status_code* p){+  grpc_haskell_free("destroy_status_code_ptr", p);+}++grpc_call_details* create_call_details(){+  grpc_call_details* retval = malloc(sizeof(grpc_call_details));+  grpc_call_details_init(retval);+  return retval;+}++void destroy_call_details(grpc_call_details* cd){+  grpc_call_details_destroy(cd);+  grpc_haskell_free("destroy_call_details", cd);+}++void grpc_channel_watch_connectivity_state_(grpc_channel *channel,+                                            grpc_connectivity_state+                                            last_observed_state,+                                            gpr_timespec* deadline,+                                            grpc_completion_queue *cq,+                                            void *tag){+  grpc_channel_watch_connectivity_state(channel, last_observed_state, *deadline,+                                        cq, tag);+}++grpc_metadata* metadata_array_get_metadata(grpc_metadata_array* arr){+  return arr->metadata;+}++void metadata_array_set_metadata(grpc_metadata_array* arr, grpc_metadata* meta){+  arr->metadata = meta;+  //NOTE: we assume count == capacity because that's how the 'createMetadata'+  //Haskell function works. It isn't safe to call this function if the+  //metadata was created in some other way.+  size_t n = sizeof(meta);+  arr->count = n;+  arr->capacity = n;+}++size_t metadata_array_get_count(grpc_metadata_array* arr){+  return arr->count;+}++size_t metadata_array_get_capacity(grpc_metadata_array* arr){+  return arr->capacity;+}++grpc_call* grpc_channel_create_registered_call_(+  grpc_channel *channel, grpc_call *parent_call, uint32_t propagation_mask,+  grpc_completion_queue *completion_queue, void *registered_call_handle,+  gpr_timespec *deadline, void *reserved){+    #ifdef GRPC_HASKELL_DEBUG+    printf("calling grpc_channel_create_registered_call with deadline %p\n",+           deadline);+    #endif+    return grpc_channel_create_registered_call(channel, parent_call,+             propagation_mask, completion_queue, registered_call_handle,+             *deadline, reserved);+}++grpc_slice* call_details_get_method(grpc_call_details* details){+  return &details->method;+}++grpc_slice* call_details_get_host(grpc_call_details* details){+  return &details->host;+}++gpr_timespec* call_details_get_deadline(grpc_call_details* details){+  return &(details->deadline);+}++void* grpc_server_register_method_(+  grpc_server* server, const char* method,+  const char* host, grpc_server_register_method_payload_handling payload_handling ){+  return grpc_server_register_method(server, method, host, payload_handling, 0);+}++grpc_arg* create_arg_array(size_t n){+  return malloc(sizeof(grpc_arg)*n);+}++//Converts our enum into real GRPC #defines. c2hs workaround.+char* translate_arg_key(enum supported_arg_key key){+  switch (key) {+    case compression_algorithm_key:+      return GRPC_COMPRESSION_CHANNEL_DEFAULT_ALGORITHM;+    case compression_level_key:+      return GRPC_COMPRESSION_CHANNEL_DEFAULT_LEVEL;+    case user_agent_prefix_key:+      return GRPC_ARG_PRIMARY_USER_AGENT_STRING;+    case user_agent_suffix_key:+      return GRPC_ARG_SECONDARY_USER_AGENT_STRING;+    case max_receive_message_length_key:+      return GRPC_ARG_MAX_RECEIVE_MESSAGE_LENGTH;+    case max_metadata_size_key:+      return GRPC_ARG_MAX_METADATA_SIZE;+    default:+      return "unknown_arg_key";+  }+}++void create_string_arg(grpc_arg* args, size_t i,+                       enum supported_arg_key key, char* value){+  grpc_arg* arg = args+i;+  arg->type = GRPC_ARG_STRING;+  arg->key = translate_arg_key(key);+  char* storeValue = malloc(sizeof(char)*strlen(value));+  arg->value.string = strcpy(storeValue, value);+}++void create_int_arg(grpc_arg* args, size_t i,+                    enum supported_arg_key key, int value){+  grpc_arg* arg = args+i;+  arg->type = GRPC_ARG_INTEGER;+  arg->key = translate_arg_key(key);+  arg->value.integer = value;+}++//Destroys an arg array of the given length. NOTE: the args in the arg array+//MUST have been created by the create_*_arg functions above!+void destroy_arg_array(grpc_arg* args, size_t n){+  for(int i = 0; i < n; i++){+    grpc_arg* arg = args+i;+    if(arg->type == GRPC_ARG_STRING){+      free(arg->value.string);+    }+  }+  free(args);+}++grpc_auth_property_iterator* grpc_auth_context_property_iterator_(+  const grpc_auth_context* ctx){++  grpc_auth_property_iterator* i = malloc(sizeof(grpc_auth_property_iterator));+  *i = grpc_auth_context_property_iterator(ctx);+  return i;+}++grpc_server_credentials* ssl_server_credentials_create_internal(+  const char* pem_root_certs, const char* pem_key, const char* pem_cert,+  grpc_ssl_client_certificate_request_type force_client_auth){++  grpc_ssl_pem_key_cert_pair pair = {pem_key, pem_cert};+  grpc_server_credentials* creds = grpc_ssl_server_credentials_create_ex(+    pem_root_certs, &pair, 1, force_client_auth, NULL);+  return creds;+}++grpc_channel_credentials* grpc_ssl_credentials_create_internal(+  const char* pem_root_certs, const char* pem_key, const char* pem_cert){++  grpc_channel_credentials* creds;+  if(pem_key && pem_cert){+    grpc_ssl_pem_key_cert_pair pair = {pem_key, pem_cert};+    creds = grpc_ssl_credentials_create(pem_root_certs, &pair, NULL, NULL);+  }+  else{+    creds = grpc_ssl_credentials_create(pem_root_certs, NULL, NULL, NULL);+  }+  return creds;+}++void grpc_server_credentials_set_auth_metadata_processor_(+  grpc_server_credentials* creds, grpc_auth_metadata_processor* p){++  grpc_server_credentials_set_auth_metadata_processor(creds, *p);+}++grpc_auth_metadata_processor* mk_auth_metadata_processor(+  void (*process)(void *state, grpc_auth_context *context,+                  const grpc_metadata *md, size_t num_md,+                  grpc_process_auth_metadata_done_cb cb, void *user_data)){++  //TODO: figure out when to free this.+  grpc_auth_metadata_processor* p = malloc(sizeof(grpc_auth_metadata_processor));+  p->process = process;+  p->destroy = NULL;+  p->state = NULL;+  return p;+}++grpc_call_credentials* grpc_metadata_credentials_create_from_plugin_(+  grpc_metadata_credentials_plugin* plugin){++  return grpc_metadata_credentials_create_from_plugin(*plugin, NULL);+}++//This is a hack to work around GHC being unable to deal with raw struct params.+//This callback is registered as the get_metadata callback for the call, and its+//only job is to cast the void* state pointer to the correct function pointer+//type and call the Haskell function with it.+int metadata_dispatcher(void *state,+ grpc_auth_metadata_context context,+ grpc_credentials_plugin_metadata_cb cb,+ void *user_data,+ grpc_metadata creds_md[GRPC_METADATA_CREDENTIALS_PLUGIN_SYNC_MAX],+ size_t *num_creds_md,+ grpc_status_code *status,+ const char ** error_details) {+  ((haskell_get_metadata*)state)(&context, cb, user_data);+  return 0;+}++grpc_metadata_credentials_plugin* mk_metadata_client_plugin(+  haskell_get_metadata* f){++  //TODO: figure out when to free this.+  grpc_metadata_credentials_plugin* p =+    malloc(sizeof(grpc_metadata_credentials_plugin));++  p->get_metadata = metadata_dispatcher;+  p->destroy = NULL;+  p->state = f;+  p->type = "grpc-haskell custom credentials";++  return p;+}
+ grpc-haskell-core.cabal view
@@ -0,0 +1,113 @@+name:                grpc-haskell-core+version:             0.0.0.0+synopsis:            Haskell implementation of gRPC layered on shared C library.+homepage:            https://github.com/awakenetworks/gRPC-haskell+license:             Apache-2.0+license-file:        LICENSE+author:              Awake Networks+maintainer:          opensource@awakenetworks.com+copyright:           Copyright 2016 Awake Networks+category:            Network+build-type:          Simple+cabal-version:       >=1.10+extra-source-files:  include/grpc_haskell.h+                     tests/ssl/localhost.crt+                     tests/ssl/localhost.key++Flag Debug+  Description: Adds debug logging.+  Manual:      True+  Default:     False++library+  build-depends:+      base >=4.8 && <5.0+    , clock >=0.6.0 && <0.8.0+    , bytestring ==0.10.*+    , stm >=2.4 && <2.6+    , containers >=0.5 && <0.7+    , managed >= 1.0.0 && < 1.1+    , transformers+    , sorted-list >=0.1.6.1 && <=0.3++  c-sources:+    cbits/grpc_haskell.c+  exposed-modules:+  -- NOTE: the order of these matters to c2hs.+    Network.GRPC.Unsafe.Constants+    Network.GRPC.Unsafe.Time+    Network.GRPC.Unsafe.Slice+    Network.GRPC.Unsafe.ChannelArgs+    Network.GRPC.Unsafe.ByteBuffer+    Network.GRPC.Unsafe.Metadata+    Network.GRPC.Unsafe.Op+    Network.GRPC.Unsafe+    Network.GRPC.Unsafe.Security+    Network.GRPC.LowLevel+    Network.GRPC.LowLevel.Server.Unregistered+    Network.GRPC.LowLevel.Client.Unregistered+    Network.GRPC.LowLevel.CompletionQueue+    Network.GRPC.LowLevel.CompletionQueue.Internal+    Network.GRPC.LowLevel.CompletionQueue.Unregistered+    Network.GRPC.LowLevel.GRPC+    Network.GRPC.LowLevel.Op+    Network.GRPC.LowLevel.Server+    Network.GRPC.LowLevel.Call+    Network.GRPC.LowLevel.Call.Unregistered+    Network.GRPC.LowLevel.Client+  extra-libraries:+      grpc+    , gpr+  includes:+      include/grpc_haskell.h+    , grpc/grpc.h+    , grpc/status.h+    , grpc/support/time.h+    , grpc/impl/codegen/compression_types.h+    , grpc/slice_buffer.h+    , grpc/slice.h+  build-tools:          c2hs+  default-language:     Haskell2010+  ghc-options:          -Wall -fwarn-incomplete-patterns -fno-warn-unused-do-bind+  include-dirs:         include+  hs-source-dirs:       src+  default-extensions:   CPP+  CC-Options: -std=c99+  if flag(debug)+    CPP-Options: -DDEBUG+    CC-Options:  -DGRPC_HASKELL_DEBUG -std=c99++test-suite tests+  build-depends:+      base >=4.8 && <5.0+    , grpc-haskell-core+    , bytestring ==0.10.*+    , unix+    , time+    , async >=2.1 && <2.3+    , tasty >= 0.11+    , tasty-hunit >= 0.9+    , tasty-quickcheck >= 0.8.4+    , containers >=0.5 && <0.7+    , managed >= 1.0.0 && < 1.1+    , pipes >=4.1 && <=4.4+    , proto3-suite+    , transformers+    , safe+    , clock >=0.6.0 && <0.8.0+    , turtle >= 1.2.0+    , text+    , QuickCheck >=2.8 && <3.0+  other-modules:+    LowLevelTests,+    LowLevelTests.Op,+    UnsafeTests+  default-language:     Haskell2010+  ghc-options:          -Wall -fwarn-incomplete-patterns -fno-warn-unused-do-bind -g -threaded -rtsopts+  hs-source-dirs:       tests+  main-is:              Properties.hs+  type:                 exitcode-stdio-1.0+  default-extensions:   CPP+  if flag(debug)+    CPP-Options: -DDEBUG+    CC-Options:  -DGRPC_HASKELL_DEBUG
+ include/grpc_haskell.h view
@@ -0,0 +1,208 @@+#ifndef GRPC_HASKELL+#define GRPC_HASKELL++#include <grpc/grpc.h>+#include <grpc/grpc_security.h>+#include <grpc/impl/codegen/slice.h>+#include <grpc/support/time.h>+#include <grpc/byte_buffer.h>+#include <grpc/byte_buffer_reader.h>++grpc_event *grpc_completion_queue_next_(grpc_completion_queue *cq,+                                       gpr_timespec *deadline,+                                       void *reserved);++grpc_event *grpc_completion_queue_pluck_(grpc_completion_queue *cq, void *tag,+                                        gpr_timespec *deadline,+                                        void *reserved);++grpc_call *grpc_channel_create_call_(grpc_channel *channel,+                                     grpc_call *parent_call,+                                     uint32_t propagation_mask,+                                     grpc_completion_queue *completion_queue,+                                     const char *method, const char *host,+                                     gpr_timespec *deadline, void *reserved);++grpc_slice* grpc_slice_malloc_(size_t len);++size_t grpc_slice_length_(grpc_slice *slice);++uint8_t *grpc_slice_start_(grpc_slice *slice);++grpc_slice* grpc_slice_from_copied_string_(const char* source);++grpc_slice* grpc_slice_from_copied_buffer_(const char *source, size_t len);++void free_slice(grpc_slice *slice);++grpc_byte_buffer **create_receiving_byte_buffer();++void destroy_receiving_byte_buffer(grpc_byte_buffer **bb);++grpc_byte_buffer_reader *byte_buffer_reader_create(grpc_byte_buffer *buffer);++void byte_buffer_reader_destroy(grpc_byte_buffer_reader *reader);++grpc_slice* grpc_byte_buffer_reader_readall_(grpc_byte_buffer_reader *reader);++void timespec_destroy(gpr_timespec* t);++gpr_timespec* gpr_inf_future_(gpr_clock_type t);++gpr_timespec* gpr_now_(gpr_clock_type t);++int32_t gpr_time_to_millis_(gpr_timespec* t);++gpr_timespec* seconds_to_deadline(int64_t seconds);++gpr_timespec* millis_to_deadline(int64_t millis);++gpr_timespec* infinite_deadline();++gpr_timespec* convert_clock_type(gpr_timespec *t, gpr_clock_type to);++grpc_metadata_array** metadata_array_create();++void metadata_array_destroy(grpc_metadata_array **arr);++grpc_metadata* metadata_alloc(size_t n);++void metadata_free(grpc_metadata* m);++void set_metadata_key_val(char *key, char *val, size_t val_len,+                          grpc_metadata *arr, size_t i);++grpc_slice* get_metadata_key(grpc_metadata *arr, size_t i);++grpc_slice* get_metadata_val(grpc_metadata *arr, size_t i);++grpc_op* op_array_create(size_t n);++void op_array_destroy(grpc_op* op_array, size_t n);++void op_send_initial_metadata(grpc_op *op_array, size_t i,+                              grpc_metadata *arr, size_t n_metadata);++void op_send_initial_metadata_empty(grpc_op *op_array, size_t i);++void op_send_message(grpc_op *op_array, size_t i,+                     grpc_byte_buffer *payload);++void op_send_close_client(grpc_op *op_array, size_t i);++void op_recv_initial_metadata(grpc_op *op_array, size_t i,+                              grpc_metadata_array** arr);++void op_recv_message(grpc_op *op_array, size_t i,+                     grpc_byte_buffer **payload_recv);++void op_recv_status_client(grpc_op *op_array, size_t i,+                          grpc_metadata_array** arr,+                          grpc_status_code* status,+                          grpc_slice* details);++void op_recv_close_server(grpc_op *op_array, size_t i, int *was_cancelled);++void op_send_status_server(grpc_op *op_array, size_t i,+                           size_t metadata_count, grpc_metadata* m,+                           grpc_status_code status, grpc_slice *details);++grpc_status_code* create_status_code_ptr();++grpc_status_code deref_status_code_ptr(grpc_status_code* p);++void destroy_status_code_ptr(grpc_status_code* p);++grpc_call_details* create_call_details();++void destroy_call_details(grpc_call_details* cd);++void grpc_channel_watch_connectivity_state_(grpc_channel *channel,+                                            grpc_connectivity_state+                                            last_observed_state,+                                            gpr_timespec* deadline,+                                            grpc_completion_queue *cq,+                                            void *tag);++grpc_metadata* metadata_array_get_metadata(grpc_metadata_array* arr);++void metadata_array_set_metadata(grpc_metadata_array* arr, grpc_metadata* meta);++size_t metadata_array_get_count(grpc_metadata_array* arr);++size_t metadata_array_get_capacity(grpc_metadata_array* arr);++grpc_call* grpc_channel_create_registered_call_(+  grpc_channel *channel, grpc_call *parent_call, uint32_t propagation_mask,+  grpc_completion_queue *completion_queue, void *registered_call_handle,+  gpr_timespec *deadline, void *reserved);++grpc_slice* call_details_get_method(grpc_call_details* details);++grpc_slice* call_details_get_host(grpc_call_details* details);++gpr_timespec* call_details_get_deadline(grpc_call_details* details);++void* grpc_server_register_method_(+  grpc_server* server, const char* method, const char* host,+  grpc_server_register_method_payload_handling payload_handling);++//c2hs doesn't support #const pragmas referring to #define'd strings, so we use+//this enum as a workaround. These are converted into actual GRPC #defines in+// translate_arg_key in grpc_haskell.c.+enum supported_arg_key {+  compression_algorithm_key = 0,+  compression_level_key,+  user_agent_prefix_key,+  user_agent_suffix_key,+  max_receive_message_length_key,+  max_metadata_size_key,+};++grpc_arg* create_arg_array(size_t n);++void create_string_arg(grpc_arg* args, size_t i,+                       enum supported_arg_key key, char* value);++void create_int_arg(grpc_arg* args, size_t i,+                    enum supported_arg_key key, int value);++void destroy_arg_array(grpc_arg* args, size_t n);++grpc_auth_property_iterator* grpc_auth_context_property_iterator_(+  const grpc_auth_context* ctx);++grpc_server_credentials* ssl_server_credentials_create_internal(+  const char* pem_root_certs, const char* pem_key, const char* pem_cert,+  grpc_ssl_client_certificate_request_type force_client_auth);++grpc_channel_credentials* grpc_ssl_credentials_create_internal(+  const char* pem_root_certs, const char* pem_key, const char* pem_cert);++void grpc_server_credentials_set_auth_metadata_processor_(+  grpc_server_credentials* creds, grpc_auth_metadata_processor* p);++//packs a Haskell server-side auth processor function pointer into the+//appropriate struct expected by gRPC.+grpc_auth_metadata_processor* mk_auth_metadata_processor(+  void (*process)(void *state, grpc_auth_context *context,+                  const grpc_metadata *md, size_t num_md,+                  grpc_process_auth_metadata_done_cb cb, void *user_data));++grpc_call_credentials* grpc_metadata_credentials_create_from_plugin_(+  grpc_metadata_credentials_plugin* plugin);++//type of the callback used to create auth metadata on the client+typedef void (*get_metadata)+       (void *state, grpc_auth_metadata_context context,+        grpc_credentials_plugin_metadata_cb cb, void *user_data);++//type of the Haskell callback that we use to create auth metadata on the client+typedef void haskell_get_metadata(grpc_auth_metadata_context*,+                                  grpc_credentials_plugin_metadata_cb,+                                  void*);++grpc_metadata_credentials_plugin* mk_metadata_client_plugin(+  haskell_get_metadata* f);++#endif //GRPC_HASKELL
+ src/Network/GRPC/LowLevel.hs view
@@ -0,0 +1,124 @@+-- | Low-level safe interface to gRPC. By "safe", we mean:+-- 1. all gRPC objects are guaranteed to be cleaned up correctly.+-- 2. all functions are thread-safe.+-- 3. all functions leave gRPC in a consistent, safe state.+-- These guarantees only apply to the functions exported by this module,+-- and not to helper functions in submodules that aren't exported here.++{-# LANGUAGE RecordWildCards #-}++module Network.GRPC.LowLevel (+-- * Important types+GRPC+, withGRPC+, GRPCIOError(..)+, StatusCode(..)++-- * Completion queue utilities+, CompletionQueue+, withCompletionQueue++-- * Calls+, GRPCMethodType(..)+, RegisteredMethod+, MethodPayload+, NormalRequestResult(..)+, MetadataMap(..)+, MethodName(..)+, StatusDetails(..)++-- * Configuration options+, Arg(..)+, CompressionAlgorithm(..)+, CompressionLevel(..)+, Host(..)+, Port(..)++-- * Server+, ServerConfig(..)+, Server(normalMethods, sstreamingMethods, cstreamingMethods,+         bidiStreamingMethods)+, ServerCall(payload, metadata)+, withServer+, serverHandleNormalCall+, ServerHandlerLL+, withServerCall+, serverCallCancel+, serverCallIsExpired+, serverReader -- for client streaming+, ServerReaderHandlerLL+, serverWriter -- for server streaming+, ServerWriterHandlerLL+, serverRW     -- for bidirectional streaming+, ServerRWHandlerLL++-- * Client and Server Auth+, AuthContext+, AuthProperty(..)+, getAuthProperties+, addAuthProperty++-- * Server Auth+, ServerSSLConfig(..)+, ProcessMeta+, AuthProcessorResult(..)+, SslClientCertificateRequestType(..)++-- * Client Auth+, ClientSSLConfig(..)+, ClientSSLKeyCertPair(..)+, ClientMetadataCreate+, ClientMetadataCreateResult(..)+, AuthMetadataContext(..)++-- * Client+, ClientConfig(..)+, Client+, ClientCall+, ConnectivityState(..)+, clientConnectivity+, withClient+, clientRegisterMethodNormal+, clientRegisterMethodClientStreaming+, clientRegisterMethodServerStreaming+, clientRegisterMethodBiDiStreaming+, clientRequest+, clientRequestParent+, clientReader -- for server streaming+, clientWriter -- for client streaming+, clientRW     -- for bidirectional streaming+, withClientCall+, withClientCallParent+, clientCallCancel++-- * Ops+, Op(..)+, OpRecvResult(..)++-- * Streaming utilities+, StreamSend+, StreamRecv++) where++import           Network.GRPC.LowLevel.Call+import           Network.GRPC.LowLevel.Client+import           Network.GRPC.LowLevel.CompletionQueue+import           Network.GRPC.LowLevel.GRPC+import           Network.GRPC.LowLevel.Op+import           Network.GRPC.LowLevel.Server++import           Network.GRPC.Unsafe                   (ConnectivityState (..))+import           Network.GRPC.Unsafe.ChannelArgs       (Arg (..), CompressionAlgorithm (..),+                                                        CompressionLevel (..))+import           Network.GRPC.Unsafe.Op                (StatusCode (..))+import           Network.GRPC.Unsafe.Security          (AuthContext,+                                                        AuthMetadataContext (..),+                                                        AuthProcessorResult (..),+                                                        AuthProperty (..),+                                                        ClientMetadataCreate,+                                                        ClientMetadataCreateResult (..),+                                                        ProcessMeta,+                                                        SslClientCertificateRequestType (..),+                                                        addAuthProperty,+                                                        getAuthProperties)
+ src/Network/GRPC/LowLevel/Call.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures             #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TypeFamilies               #-}++-- | This module defines data structures and operations pertaining to registered+-- calls; for unregistered call support, see+-- `Network.GRPC.LowLevel.Call.Unregistered`.+module Network.GRPC.LowLevel.Call where++import           Control.Monad.Managed                          (Managed, managed)+import           Control.Exception                              (bracket)+import           Data.ByteString                                (ByteString)+import           Data.ByteString.Char8                          (pack)+import           Data.List                                      (intersperse)+import           Data.String                                    (IsString)+import           Foreign.Marshal.Alloc                          (free, malloc)+import           Foreign.Ptr                                    (Ptr, nullPtr)+import           Foreign.Storable                               (Storable, peek)+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.ByteBuffer                 as C+import qualified Network.GRPC.Unsafe.Op                         as C+import qualified Network.GRPC.Unsafe.Time                       as C+import           System.Clock++-- | Models the four types of RPC call supported by gRPC (and correspond to+-- DataKinds phantom types on RegisteredMethods).+data GRPCMethodType+  = Normal+  | ClientStreaming+  | ServerStreaming+  | BiDiStreaming+  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.++extractPayload :: RegisteredMethod mt+                  -> Ptr C.ByteBuffer+                  -> IO (MethodPayload mt)+extractPayload (RegisteredMethodNormal _ _ _) p =+  peek p >>= C.copyByteBufferToByteString+extractPayload (RegisteredMethodClientStreaming _ _ _) _ = return ()+extractPayload (RegisteredMethodServerStreaming _ _ _) p =+  peek p >>= C.copyByteBufferToByteString+extractPayload (RegisteredMethodBiDiStreaming _ _ _) _ = return ()++newtype MethodName = MethodName {unMethodName :: ByteString}+  deriving (Show, Eq, IsString)++newtype Host = Host {unHost :: ByteString}+  deriving (Show, Eq, IsString)++newtype Port = Port {unPort :: Int}+  deriving (Eq, Num, Show)++newtype Endpoint = Endpoint {unEndpoint :: ByteString}+  deriving (Show, Eq, IsString)++-- | Given a hostname and port, produces a "host:port" string+endpoint :: Host -> Port -> Endpoint+endpoint (Host h) (Port p) = Endpoint (h <> ":" <> pack (show p))++-- | Represents a registered method. Methods can optionally be registered in+-- order to make the C-level request/response code simpler.  Before making or+-- awaiting a registered call, the method must be registered with the client+-- (see 'clientRegisterMethod') and the server (see 'serverRegisterMethod').+-- 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+-- different kinds of registered methods.+data RegisteredMethod (mt :: GRPCMethodType) where+  RegisteredMethodNormal :: MethodName+                            -> Endpoint+                            -> 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.+-- This is used to associate send/receive 'Op's with a request.+data ClientCall = ClientCall { unsafeCC :: C.Call }++clientCallCancel :: ClientCall -> IO ()+clientCallCancel cc = C.grpcCallCancel (unsafeCC cc) C.reserved++-- | Represents one registered GRPC call on the server. Contains pointers to all+-- the C state needed to respond to a registered call.+data ServerCall a = ServerCall+  { unsafeSC            :: C.Call+  , callCQ              :: CompletionQueue+  , metadata            :: MetadataMap+  , payload             :: a+  , callDeadline        :: TimeSpec+  } deriving (Functor, Show)++serverCallCancel :: ServerCall a -> C.StatusCode -> String -> IO ()+serverCallCancel sc code reason =+  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+-- decide the server payload handling method.+payloadHandling :: GRPCMethodType -> C.ServerRegisterMethodPayloadHandling+payloadHandling Normal          = C.SrmPayloadReadInitialByteBuffer+payloadHandling ClientStreaming = C.SrmPayloadNone+payloadHandling ServerStreaming = C.SrmPayloadReadInitialByteBuffer+payloadHandling BiDiStreaming   = C.SrmPayloadNone++-- | 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+  C.CTimeSpec currTime <- bracket (C.gprNow C.GprClockMonotonic) C.timespecDestroy peek+  return $ currTime > (callDeadline sc)++debugClientCall :: ClientCall -> IO ()+{-# INLINE debugClientCall #-}+#ifdef DEBUG+debugClientCall (ClientCall (C.Call ptr)) =+  grpcDebug $ "debugCall: client call: " ++ (show ptr)+#else+debugClientCall = const $ return ()+#endif++debugServerCall :: ServerCall a -> IO ()+#ifdef DEBUG+debugServerCall sc@(ServerCall (C.Call ptr) _ _ _ _) = do+  let dbug = grpcDebug . ("debugServerCall(R): " ++)+  dbug $ "server call: "  ++ show ptr+  dbug $ "callCQ: "       ++ show (callCQ sc)+  dbug $ "metadata: " ++ show (metadata sc)+  dbug $ "deadline ptr: " ++ show (callDeadline sc)+#else+{-# INLINE debugServerCall #-}+debugServerCall = const $ return ()+#endif++destroyClientCall :: ClientCall -> IO ()+destroyClientCall cc = do+  grpcDebug "Destroying client-side call object."+  C.grpcCallUnref (unsafeCC cc)++destroyServerCall :: ServerCall a -> IO ()+destroyServerCall sc@ServerCall{ unsafeSC = c, .. } = do+  grpcDebug "destroyServerCall(R): entered."+  debugServerCall sc+  grpcDebug $ "Destroying server-side call object: " ++ show c+  C.grpcCallUnref c
+ src/Network/GRPC/LowLevel/Call/Unregistered.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE RecordWildCards #-}++module Network.GRPC.LowLevel.Call.Unregistered where++import qualified Network.GRPC.LowLevel.Call                     as Reg+import           Network.GRPC.LowLevel.CompletionQueue+import           Network.GRPC.LowLevel.GRPC                     (MetadataMap,+                                                                 grpcDebug)+import qualified Network.GRPC.Unsafe                            as C+import qualified Network.GRPC.Unsafe.Op                         as C+import           System.Clock                                   (TimeSpec)++-- | Represents one unregistered GRPC call on the server.  Contains pointers to+-- all the C state needed to respond to an unregistered call.+data ServerCall = ServerCall+  { unsafeSC            :: C.Call+  , callCQ              :: CompletionQueue+  , metadata            :: MetadataMap+  , callDeadline        :: TimeSpec+  , callMethod          :: Reg.MethodName+  , callHost            :: Reg.Host+  }++convertCall :: ServerCall -> Reg.ServerCall ()+convertCall ServerCall{..} =+  Reg.ServerCall unsafeSC callCQ metadata () callDeadline++serverCallCancel :: ServerCall -> C.StatusCode -> String -> IO ()+serverCallCancel sc code reason =+  C.grpcCallCancelWithStatus (unsafeSC sc) code reason C.reserved++debugServerCall :: ServerCall -> IO ()+#ifdef DEBUG+debugServerCall ServerCall{..} = do+  let C.Call ptr = unsafeSC+      dbug = grpcDebug . ("debugServerCall(U): " ++)++  dbug $ "server call: " ++ show ptr+  dbug $ "metadata: "    ++ show metadata++  dbug $ "deadline: " ++ show callDeadline+  dbug $ "method: "   ++ show callMethod+  dbug $ "host: "     ++ show callHost+#else+{-# INLINE debugServerCall #-}+debugServerCall = const $ return ()+#endif++destroyServerCall :: ServerCall -> IO ()+destroyServerCall call@ServerCall{..} = do+  grpcDebug "destroyServerCall(U): entered."+  debugServerCall call+  grpcDebug $ "Destroying server-side call object: " ++ show unsafeSC+  C.grpcCallUnref unsafeSC
+ src/Network/GRPC/LowLevel/Client.hs view
@@ -0,0 +1,479 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms   #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TupleSections     #-}+{-# LANGUAGE ViewPatterns      #-}++-- | This module defines data structures and operations pertaining to registered+-- clients using registered calls; for unregistered support, see+-- `Network.GRPC.LowLevel.Client.Unregistered`.+module Network.GRPC.LowLevel.Client where++import           Control.Exception                     (bracket)+import           Control.Concurrent.MVar+import           Control.Monad+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Except+import qualified Data.ByteString                       as B+import           Data.ByteString                       (ByteString)+import           Data.Maybe+import           Network.GRPC.LowLevel.Call+import           Network.GRPC.LowLevel.CompletionQueue+import           Network.GRPC.LowLevel.GRPC+import           Network.GRPC.LowLevel.Op+import qualified Network.GRPC.Unsafe                   as C+import qualified Network.GRPC.Unsafe.ChannelArgs       as C+import qualified Network.GRPC.Unsafe.Constants         as C+import qualified Network.GRPC.Unsafe.Op                as C+import qualified Network.GRPC.Unsafe.Security          as C+import qualified Network.GRPC.Unsafe.Time              as C++-- | Represents the context needed to perform client-side gRPC operations.+data Client = Client {clientChannel :: C.Channel,+                      clientCQ      :: CompletionQueue,+                      clientConfig  :: ClientConfig+                     }++data ClientSSLKeyCertPair = ClientSSLKeyCertPair+  { clientPrivateKey :: FilePath,+    clientCert       :: FilePath+  } deriving Show++-- | SSL configuration for the client. It's perfectly acceptable for both fields+-- to be 'Nothing', in which case default fallbacks will be used for the server+-- root cert.+data ClientSSLConfig = ClientSSLConfig+  {serverRootCert :: Maybe FilePath,+   -- ^ Path to the server root certificate. If 'Nothing', gRPC will attempt to+   -- fall back to a default.+   clientSSLKeyCertPair :: Maybe ClientSSLKeyCertPair,+   -- ^ The client's private key and cert, if available.+   clientMetadataPlugin :: Maybe C.ClientMetadataCreate+   -- ^ Optional plugin for attaching additional metadata to each call.+  }++-- | Configuration necessary to set up a client.++data ClientConfig = ClientConfig {clientServerHost :: Host,+                                  clientServerPort :: Port,+                                  clientArgs :: [C.Arg],+                                  -- ^ Optional arguments for setting up the+                                  -- channel on the client. Supplying an empty+                                  -- list will cause the channel to use gRPC's+                                  -- default options.+                                  clientSSLConfig :: Maybe ClientSSLConfig,+                                  -- ^ If 'Nothing', the client will use an+                                  -- insecure connection to the server.+                                  -- Otherwise, will use the supplied config to+                                  -- connect using SSL.+                                  clientAuthority :: Maybe ByteString+                                  -- ^ If 'Nothing', the :authority pseudo-header will+                                  -- be the endpoint host. Otherwise, the :authority+                                  -- pseudo-header will be set to the supplied value.+                                 }++clientEndpoint :: ClientConfig -> Endpoint+clientEndpoint ClientConfig{..} = endpoint clientServerHost clientServerPort++addMetadataCreds :: C.ChannelCredentials+                    -> Maybe C.ClientMetadataCreate+                    -> IO C.ChannelCredentials+addMetadataCreds c Nothing = return c+addMetadataCreds c (Just create) = do+  callCreds <- C.createCustomCallCredentials create+  C.compositeChannelCredentialsCreate c callCreds C.reserved++createChannel :: ClientConfig -> C.GrpcChannelArgs -> IO C.Channel+createChannel conf@ClientConfig{..} chanargs =+  case clientSSLConfig of+    Nothing -> C.grpcInsecureChannelCreate e chanargs C.reserved+    Just (ClientSSLConfig rootCertPath Nothing plugin) ->+      do rootCert <- mapM B.readFile rootCertPath+         C.withChannelCredentials rootCert Nothing Nothing $ \creds -> do+           creds' <- addMetadataCreds creds plugin+           C.secureChannelCreate creds' e chanargs C.reserved+    Just (ClientSSLConfig x (Just (ClientSSLKeyCertPair y z)) plugin) ->+      do rootCert <- mapM B.readFile x+         privKey <- Just <$> B.readFile y+         clientCert <- Just <$> B.readFile z+         C.withChannelCredentials rootCert privKey clientCert $ \creds -> do+           creds' <- addMetadataCreds creds plugin+           C.secureChannelCreate creds' e chanargs C.reserved+  where (Endpoint e) = clientEndpoint conf++createClient :: GRPC -> ClientConfig -> IO Client+createClient grpc clientConfig =+  C.withChannelArgs (clientArgs clientConfig) $ \chanargs -> do+    clientChannel <- createChannel clientConfig chanargs+    clientCQ <- createCompletionQueue grpc+    return Client{..}++destroyClient :: Client -> IO ()+destroyClient Client{..} = do+  grpcDebug "destroyClient: calling grpc_channel_destroy()"+  C.grpcChannelDestroy clientChannel+  grpcDebug "destroyClient: shutting down CQ."+  shutdownResult <- shutdownCompletionQueue clientCQ+  case shutdownResult of+    Left x -> do putStrLn $ "Failed to stop client CQ: " ++ show x+                 putStrLn $ "Trying to shut down anyway."+    Right _ -> return ()++withClient :: GRPC -> ClientConfig -> (Client -> IO a) -> IO a+withClient grpc config = bracket (createClient grpc config)+                                 (\c -> grpcDebug "withClient: destroying."+                                        >> destroyClient c)++clientConnectivity :: Client -> IO C.ConnectivityState+clientConnectivity Client{..} =+  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+-- 'clientRequest'.+clientRegisterMethod :: Client+                     -> MethodName+                     -> IO (C.CallHandle)+clientRegisterMethod Client{..} meth = do+  let host = fromMaybe (unEndpoint (clientEndpoint clientConfig)) (clientAuthority clientConfig)+  C.grpcChannelRegisterCall clientChannel+                            (unMethodName meth)+                            host+                            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.+-- Returns 'Left' if the CQ is shutting down or if the job to create a call+-- timed out.+clientCreateCall :: Client+                 -> RegisteredMethod mt+                 -> TimeoutSeconds+                 -> IO (Either GRPCIOError ClientCall)+clientCreateCall c rm ts = clientCreateCallParent c rm ts Nothing++-- | For servers that act as clients to other gRPC servers, this version creates+-- a client call with an optional parent server call. This allows for cascading+-- call cancellation from the `ServerCall` to the `ClientCall`.+clientCreateCallParent :: Client+                           -> RegisteredMethod mt+                           -> TimeoutSeconds+                           -> Maybe (ServerCall a)+                           -- ^ Optional parent call for cascading cancellation.+                           -> IO (Either GRPCIOError ClientCall)+clientCreateCallParent Client{..} rm timeout parent = do+  C.withDeadlineSeconds timeout $ \deadline -> do+    channelCreateCall clientChannel parent C.propagateDefaults+      clientCQ (methodHandle rm) deadline++-- | Handles safe creation and cleanup of a client call+withClientCall :: Client+               -> RegisteredMethod mt+               -> TimeoutSeconds+               -> (ClientCall -> IO (Either GRPCIOError a))+               -> IO (Either GRPCIOError a)+withClientCall cl rm tm = withClientCallParent cl rm tm Nothing++-- | Handles safe creation and cleanup of a client call, with an optional parent+-- call parameter. This allows for cancellation to cascade from the parent+-- `ServerCall` to the created `ClientCall`. Obviously, this is only useful if+-- the given gRPC client is also a server.+withClientCallParent :: Client+                     -> RegisteredMethod mt+                     -> TimeoutSeconds+                     -> Maybe (ServerCall b)+                        -- ^ Optional parent call for cascading cancellation+                     -> (ClientCall -> IO (Either GRPCIOError a))+                     -> IO (Either GRPCIOError a)+withClientCallParent cl rm tm parent f =+  bracket (clientCreateCallParent cl rm tm parent) cleanup $ \case+    Left e  -> return (Left e)+    Right c -> f c+  where+    cleanup (Left _) = pure ()+    cleanup (Right c) = do+      debugClientCall c+      grpcDebug "withClientCall(R): destroying."+      destroyClientCall c++data NormalRequestResult = NormalRequestResult+  { rspBody :: ByteString+  , initMD  :: MetadataMap -- ^ initial metadata+  , trailMD :: MetadataMap -- ^ trailing metadata+  , rspCode :: C.StatusCode+  , details :: StatusDetails+  }+  deriving (Show, Eq)++-- | Function for assembling call result when the 'MethodType' is 'Normal'.+compileNormalRequestResults :: [OpRecvResult]+                               -> Either GRPCIOError NormalRequestResult+compileNormalRequestResults+  [OpRecvInitialMetadataResult m,+   OpRecvMessageResult (Just body),+   OpRecvStatusOnClientResult m2 status details]+    = Right $ NormalRequestResult body m m2 status (StatusDetails details)+compileNormalRequestResults x =+  case extractStatusInfo x of+    Nothing -> Left GRPCIOUnknownError+    Just (_meta, status, details) ->+      Left (GRPCIOBadStatusCode status (StatusDetails details))++--------------------------------------------------------------------------------+-- clientReader (client side of server streaming mode)++-- | First parameter is initial server metadata.+type ClientReaderHandler = ClientCall -> MetadataMap -> StreamRecv ByteString -> IO ()+type ClientReaderResult  = (MetadataMap, C.StatusCode, StatusDetails)++clientReader :: Client+             -> RegisteredMethod 'ServerStreaming+             -> TimeoutSeconds+             -> ByteString -- ^ The body of the request+             -> MetadataMap -- ^ Metadata to send with the request+             -> ClientReaderHandler+             -> IO (Either GRPCIOError ClientReaderResult)+clientReader cl@Client{ clientCQ = cq } rm tm body initMeta f =+  withClientCall cl rm tm go+  where+    go cc@(unsafeCC -> c) = runExceptT $ do+      void $ runOps' c cq [ OpSendInitialMetadata initMeta+                          , OpSendMessage body+                          , OpSendCloseFromClient+                          ]+      srvMD <- recvInitialMetadata c cq+      liftIO $ f cc srvMD (streamRecvPrim c cq)+      recvStatusOnClient c cq++--------------------------------------------------------------------------------+-- clientWriter (client side of client streaming mode)++type ClientWriterHandler = StreamSend ByteString -> IO ()+type ClientWriterResult  = (Maybe ByteString, MetadataMap, MetadataMap,+                              C.StatusCode, StatusDetails)++clientWriter :: Client+             -> RegisteredMethod 'ClientStreaming+             -> TimeoutSeconds+             -> MetadataMap -- ^ Initial client metadata+             -> ClientWriterHandler+             -> IO (Either GRPCIOError ClientWriterResult)+clientWriter cl rm tm initMeta =+  withClientCall cl rm tm . clientWriterCmn cl initMeta++clientWriterCmn :: Client -- ^ The active client+                -> MetadataMap -- ^ Initial client metadata+                -> ClientWriterHandler+                -> ClientCall -- ^ The active client call+                -> IO (Either GRPCIOError ClientWriterResult)+clientWriterCmn (clientCQ -> cq) initMeta f (unsafeCC -> c) =+  runExceptT $ do+    sendInitialMetadata c cq initMeta+    liftIO $ f (streamSendPrim c cq)+    sendSingle c cq OpSendCloseFromClient+    let ops = [OpRecvInitialMetadata, OpRecvMessage, OpRecvStatusOnClient]+    runOps' c cq ops >>= \case+      CWRFinal mmsg initMD trailMD st ds+        -> return (mmsg, initMD, trailMD, st, ds)+      _ -> throwE (GRPCIOInternalUnexpectedRecv "clientWriter")++pattern CWRFinal :: Maybe ByteString+                 -> MetadataMap+                 -> MetadataMap+                 -> C.StatusCode+                 -> StatusDetails+                 -> [OpRecvResult]+pattern CWRFinal mmsg initMD trailMD st ds+  <- [ OpRecvInitialMetadataResult initMD+     , OpRecvMessageResult mmsg+     , OpRecvStatusOnClientResult trailMD st (StatusDetails -> ds)+     ]++--------------------------------------------------------------------------------+-- clientRW (client side of bidirectional streaming mode)++type ClientRWHandler+  =  ClientCall+  -> IO (Either GRPCIOError MetadataMap)+  -> StreamRecv ByteString+  -> StreamSend ByteString+  -> WritesDone+  -> IO ()+type ClientRWResult = (MetadataMap, C.StatusCode, StatusDetails)++clientRW :: Client+         -> RegisteredMethod 'BiDiStreaming+         -> TimeoutSeconds+         -> MetadataMap+         -> ClientRWHandler+         -> IO (Either GRPCIOError ClientRWResult)+clientRW cl rm tm initMeta f =+  withClientCall cl rm tm (\cc -> clientRW' cl cc initMeta f)++-- | The most generic version of clientRW. It does not assume anything about+-- threading model; caller must invoke the WritesDone operation, exactly once,+-- for the half-close, after all threads have completed writing. TODO: It'd be+-- nice to find a way to type-enforce this usage pattern rather than accomplish+-- it via usage convention and documentation.+clientRW' :: Client+          -> ClientCall+          -> MetadataMap+          -> ClientRWHandler+          -> IO (Either GRPCIOError ClientRWResult)+clientRW' (clientCQ -> cq) cc@(unsafeCC -> c) initMeta f = runExceptT $ do+  sendInitialMetadata c cq initMeta++  -- 'mdmv' is used to synchronize between callers of 'getMD' and 'recv'+  -- below. The behavior of these two operations is different based on their+  -- call order w.r.t. each other, and by whether or not metadata has already+  -- been received.+  --+  -- Regardless of call order, metadata reception is done exactly once. The+  -- result of doing so is cached for subsequent calls to 'getMD'.+  --+  -- 'getMD' will always return the received metadata (or an error if it+  -- occurred), regardless of call order.+  --+  -- When 'getMD' is invoked before 'recv' (and no metadata has been obtained),+  -- metadata is received via a singleton batch, returned, and cached for later+  -- access via 'getMD'. This scenario is analagous to preceding the first read+  -- with WaitForInitialMetadata() in the C++ API.+  --+  -- When 'recv' is invoked before 'getMD' (and no metadata has been obtained),+  -- metadata is received alongside the first payload via an aggregate batch,+  -- and cached for later access via 'getMD'. This scenario is analagous to just+  -- issuing Read() in the C++ API, and having the metadata available via+  -- ClientContext afterwards.+  --+  -- TODO: This is not the whole story about metadata exchange ordering, but+  -- allows us to at least have parity on the client side with the C++ API+  -- w.r.t. when/how metadata is exchanged. We may need to revisit this a bit as+  -- we experiment with other bindings, new GRPC releases come out, and so+  -- forth, but at least this provides us with basic functionality, albeit with+  -- a great deal more caveat programmer than desirable :(++  mdmv <- liftIO (newMVar Nothing)+  let+    getMD = modifyMVar mdmv $ \case+      Just emd -> return (Just emd, emd)+      Nothing  -> do -- getMD invoked before recv+        emd <- runExceptT (recvInitialMetadata c cq)+        return (Just emd, emd)++    recv = modifyMVar mdmv $ \case+      Just emd -> (Just emd,) <$> streamRecvPrim c cq+      Nothing  -> -- recv invoked before getMD+        runExceptT (recvInitialMsgMD c cq) >>= \case+          Left e          -> return (Just (Left e), Left e)+          Right (mbs, md) -> return (Just (Right md), Right mbs)++    send = streamSendPrim c cq++    -- TODO: Regarding usage of writesDone so that there isn't such a burden on+    -- the end user programmer (i.e. must invoke it, and only once): we can just+    -- document this general-purpose function well, and then create slightly+    -- simpler versions of the bidi interface which support (a) monothreaded+    -- send/recv interleaving, with an implicit half-close and (b) separate+    -- send/recv threads, with an implicit half-close after the writer thread+    -- terminates. These simpler versions model the most common use cases+    -- without having to expose the half-close semantics to the end user+    -- programmer.+    writesDone = writesDonePrim c cq++  liftIO (f cc getMD recv send writesDone)+  recvStatusOnClient c cq -- Finish()++--------------------------------------------------------------------------------+-- clientRequest (client side of normal request/response)++-- | Make a request of the given method with the given body. Returns the+-- server's response.+clientRequest+  :: Client+  -> RegisteredMethod 'Normal+  -> TimeoutSeconds+  -> ByteString+  -- ^ The body of the request+  -> MetadataMap+  -- ^ Metadata to send with the request+  -> IO (Either GRPCIOError NormalRequestResult)+clientRequest c = clientRequestParent c Nothing++-- | Like 'clientRequest', but allows the user to supply an optional parent+-- call, so that call cancellation can be propagated from the parent to the+-- child. This is intended for servers that call other servers.+clientRequestParent+  :: Client+  -> Maybe (ServerCall a)+  -- ^ optional parent call+  -> RegisteredMethod 'Normal+  -> TimeoutSeconds+  -> ByteString+  -- ^ The body of the request+  -> MetadataMap+  -- ^ Metadata to send with the request+  -> IO (Either GRPCIOError NormalRequestResult)+clientRequestParent cl@(clientCQ -> cq) p rm tm body initMeta =+  withClientCallParent cl rm tm p (fmap join . go)+  where+    go (unsafeCC -> c) =+      -- NB: the send and receive operations below *must* be in separate+      -- batches, or the client hangs when the server can't be reached.+      runOps c cq+        [ OpSendInitialMetadata initMeta+        , OpSendMessage body+        , OpSendCloseFromClient+        ]+        >>= \case+          Left x -> do+            grpcDebug "clientRequest(R) : batch error sending."+            return $ Left x+          Right rs ->+            runOps c cq+              [ OpRecvInitialMetadata+              , OpRecvMessage+              , OpRecvStatusOnClient+              ]+              >>= \case+                Left x -> do+                  grpcDebug "clientRequest(R): batch error receiving.."+                  return $ Left x+                Right rs' -> do+                  grpcDebug $ "clientRequest(R): got " ++ show rs'+                  return $ Right $ compileNormalRequestResults (rs ++ rs')
+ src/Network/GRPC/LowLevel/Client/Unregistered.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE LambdaCase      #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns    #-}++module Network.GRPC.LowLevel.Client.Unregistered where++import           Control.Arrow+import           Control.Exception                                  (bracket)+import           Control.Monad                                      (join)+import           Data.ByteString                                    (ByteString)+import           Foreign.Ptr                                        (nullPtr)+import qualified Network.GRPC.Unsafe                                as C+import qualified Network.GRPC.Unsafe.Constants                      as C+import qualified Network.GRPC.Unsafe.Time                           as C++import           Network.GRPC.LowLevel.Call+import           Network.GRPC.LowLevel.Client                       (Client (..),+                                                                     NormalRequestResult (..),+                                                                     clientEndpoint,+                                                                     compileNormalRequestResults)+import           Network.GRPC.LowLevel.CompletionQueue              (TimeoutSeconds)+import qualified Network.GRPC.LowLevel.CompletionQueue.Unregistered as U+import           Network.GRPC.LowLevel.GRPC+import           Network.GRPC.LowLevel.Op++-- | Create a call on the client for an endpoint without using the+-- method registration machinery. In practice, we'll probably only use the+-- registered method version, but we include this for completeness and testing.+clientCreateCall :: Client+                 -> MethodName+                 -> TimeoutSeconds+                 -> IO (Either GRPCIOError ClientCall)+clientCreateCall Client{..} meth timeout = do+  let parentCall = C.Call nullPtr+  C.withDeadlineSeconds timeout $ \deadline -> do+    U.channelCreateCall clientChannel parentCall C.propagateDefaults+      clientCQ meth (clientEndpoint clientConfig) deadline++withClientCall :: Client+               -> MethodName+               -> TimeoutSeconds+               -> (ClientCall -> IO (Either GRPCIOError a))+               -> IO (Either GRPCIOError a)+withClientCall client method timeout f =+  bracket (clientCreateCall client method timeout) cleanup $ \case+    Left x -> return $ Left x+    Right call -> f call+  where+    cleanup (Left _) = pure ()+    cleanup (Right call) = do+      grpcDebug "withClientCall(U): destroying."+      destroyClientCall call++-- | Makes a normal (non-streaming) request without needing to register a method+-- first. Probably only useful for testing.+clientRequest :: Client+              -> MethodName+              -- ^ Method name, e.g. "/foo"+              -> TimeoutSeconds+              -- ^ "Number of seconds until request times out"+              -> ByteString+              -- ^ Request body.+              -> MetadataMap+              -- ^ Request metadata.+              -> IO (Either GRPCIOError NormalRequestResult)+clientRequest cl@(clientCQ -> cq) meth tm body initMeta =+  join <$> withClientCall cl meth tm go+  where+    go (unsafeCC -> c) = do+      results <- runOps c cq+                   [ OpSendInitialMetadata initMeta+                   , OpSendMessage body+                   , OpSendCloseFromClient+                   , OpRecvInitialMetadata+                   , OpRecvMessage+                   , OpRecvStatusOnClient+                   ]+      grpcDebug "clientRequest(U): ops ran."+      return $ right compileNormalRequestResults results
+ src/Network/GRPC/LowLevel/CompletionQueue.hs view
@@ -0,0 +1,152 @@+-- | Unlike most of the other internal low-level modules, we don't export+-- everything here. There are several things in here that, if accessed, could+-- cause race conditions, so we only expose functions that are thread safe.+-- However, some of the functions we export here can cause memory leaks if used+-- improperly.+--+-- When definition operations which pertain to calls, this module only provides+-- definitions for registered calls; for unregistered variants, see+-- `Network.GRPC.LowLevel.CompletionQueue.Unregistered`. Type definitions and+-- implementation details to both are kept in+-- `Network.GRPC.LowLevel.CompletionQueue.Internal`.++{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE MultiWayIf          #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}+{-# LANGUAGE ViewPatterns        #-}++module Network.GRPC.LowLevel.CompletionQueue+  ( CompletionQueue+  , withCompletionQueue+  , createCompletionQueue+  , shutdownCompletionQueue+  , pluck+  , startBatch+  , channelCreateCall+  , TimeoutSeconds+  , isEventSuccessful+  , serverRegisterCompletionQueue+  , serverShutdownAndNotify+  , serverRequestCall+  , newTag+  )+where++import           Control.Concurrent.STM.TVar                    (newTVarIO)+import           Control.Exception                              (bracket)+import           Control.Monad.Managed+import           Control.Monad.Trans.Class                      (MonadTrans (lift))+import           Control.Monad.Trans.Except+import           Data.IORef                                     (newIORef)+import           Data.List                                      (intersperse)+import           Foreign.Ptr                                    (nullPtr)+import           Foreign.Storable                               (peek)+import           Network.GRPC.LowLevel.Call+import           Network.GRPC.LowLevel.CompletionQueue.Internal+import           Network.GRPC.LowLevel.GRPC+import qualified Network.GRPC.Unsafe                            as C+import qualified Network.GRPC.Unsafe.Constants                  as C+import qualified Network.GRPC.Unsafe.Metadata                   as C+import qualified Network.GRPC.Unsafe.Op                         as C+import qualified Network.GRPC.Unsafe.Time                       as C++withCompletionQueue :: GRPC -> (CompletionQueue -> IO a) -> IO a+withCompletionQueue grpc = bracket (createCompletionQueue grpc)+                                   shutdownCompletionQueue++createCompletionQueue :: GRPC -> IO CompletionQueue+createCompletionQueue _ = do+  unsafeCQ <- C.grpcCompletionQueueCreateForPluck C.reserved+  currentPluckers <- newTVarIO 0+  currentPushers <- newTVarIO 0+  shuttingDown <- newTVarIO False+  nextTag <- newIORef minBound+  return CompletionQueue{..}++-- | Very simple wrapper around 'grpcCallStartBatch'. Throws 'GRPCIOShutdown'+-- without calling 'grpcCallStartBatch' if the queue is shutting down.+-- Throws 'CallError' if 'grpcCallStartBatch' returns a non-OK code.+startBatch :: CompletionQueue -> C.Call -> C.OpArray -> Int -> C.Tag+              -> IO (Either GRPCIOError ())+startBatch cq@CompletionQueue{..} call opArray opArraySize tag =+    withPermission Push cq $ fmap throwIfCallError $ do+      grpcDebug $ "startBatch: calling grpc_call_start_batch with pointers: "+                  ++ show call ++ " " ++ show opArray+      res <- C.grpcCallStartBatch call opArray opArraySize tag C.reserved+      grpcDebug "startBatch: grpc_call_start_batch call returned."+      return res++channelCreateCall :: C.Channel+                  -> Maybe (ServerCall a)+                  -> C.PropagationMask+                  -> CompletionQueue+                  -> C.CallHandle+                  -> C.CTimeSpecPtr+                  -> IO (Either GRPCIOError ClientCall)+channelCreateCall+  chan parent mask cq@CompletionQueue{..} handle deadline =+  withPermission Push cq $ do+    let parentPtr = maybe (C.Call nullPtr) unsafeSC parent+    grpcDebug $ "channelCreateCall: call with "+                ++ concat (intersperse " " [show chan, show parentPtr,+                                            show mask,+                                            show unsafeCQ, show handle,+                                            show deadline])+    call <- C.grpcChannelCreateRegisteredCall chan parentPtr mask unsafeCQ+                                              handle deadline C.reserved+    return $ Right $ ClientCall call++-- | Create the call object to handle a registered call.+serverRequestCall :: RegisteredMethod mt+                  -> C.Server+                  -> CompletionQueue -- ^ server CQ+                  -> CompletionQueue -- ^ call CQ+                  -> IO (Either GRPCIOError (ServerCall (MethodPayload mt)))+serverRequestCall rm s scq ccq =+  -- 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+  -- payload when it is not present.+  withPermission Push scq . with allocs $ \(dead, call, pay, meta) ->+    withPermission Pluck scq $ do+      md  <- peek meta+      tag <- newTag scq+      dbug $ "got pluck permission, registering call for tag=" ++ show tag+      ce <- C.grpcServerRequestRegisteredCall s (methodHandle rm) call dead md+              pay (unsafeCQ ccq) (unsafeCQ scq) tag+      runExceptT $ case ce of+        C.CallOk -> do+          ExceptT $ do+            r <- pluck' scq tag Nothing+            dbug $ "pluck' finished:" ++ show r+            return r+          lift $+            ServerCall+            <$> peek call+            <*> return ccq+            <*> C.getAllMetadataArray md+            <*> extractPayload rm pay+            <*> convertDeadline dead+        _ -> do+          lift $ dbug $ "Throwing callError: " ++ show ce+          throwE (GRPCIOCallError ce)+  where+    allocs = (,,,)+      <$> mgdPtr+      <*> mgdPtr+      <*> mgdPayload (methodType rm)+      <*> managed C.withMetadataArrayPtr+    dbug = grpcDebug . ("serverRequestCall(R): " ++)+    convertDeadline timeSpecPtr = C.timeSpec <$> peek timeSpecPtr++-- | Register the server's completion queue. Must be done before the server is+-- started.+serverRegisterCompletionQueue :: C.Server -> CompletionQueue -> IO ()+serverRegisterCompletionQueue server CompletionQueue{..} =+  C.grpcServerRegisterCompletionQueue server unsafeCQ C.reserved++serverShutdownAndNotify :: C.Server -> CompletionQueue -> C.Tag -> IO ()+serverShutdownAndNotify server CompletionQueue{..} tag =+  C.grpcServerShutdownAndNotify server unsafeCQ tag
+ src/Network/GRPC/LowLevel/CompletionQueue/Internal.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE RecordWildCards #-}++module Network.GRPC.LowLevel.CompletionQueue.Internal where++import           Control.Concurrent.STM        (atomically, retry, check)+import           Control.Concurrent.STM.TVar   (TVar, modifyTVar', readTVar,+                                                writeTVar)+import           Control.Exception             (bracket)+import           Control.Monad+import           Data.IORef                    (IORef, atomicModifyIORef')+import           Foreign.Ptr                   (nullPtr, plusPtr)+import           Network.GRPC.LowLevel.GRPC+import qualified Network.GRPC.Unsafe           as C+import qualified Network.GRPC.Unsafe.Constants as C+import qualified Network.GRPC.Unsafe.Time      as C+import           System.Timeout                                 (timeout)++-- NOTE: the concurrency requirements for a CompletionQueue are a little+-- complicated. There are two read operations: next and pluck. We can either+-- call next on a CQ or call pluck up to 'maxCompletionQueuePluckers' times+-- concurrently, but we can't mix next and pluck calls. Fortunately, we only+-- need to use next when we are shutting down the queue. Thus, we do two things+-- to shut down:+-- 1. Set the shuttingDown 'TVar' to 'True'. When this is set, no new pluck+--    calls will be allowed to start.+-- 2. Wait until no threads are plucking, as counted by 'currentPluckers'.+-- This logic can be seen in 'pluck' and 'shutdownCompletionQueue'.++-- NOTE: There is one more possible race condition: pushing work onto the queue+-- after we begin to shut down.+-- Solution: another counter, which must reach zero before the shutdown+-- can start.++-- TODO: 'currentPushers' currently imposes an arbitrary limit on the number of+-- concurrent pushers to the CQ, but I don't know what the limit should be set+-- to. I haven't found any documentation that suggests there is a limit imposed+-- by the gRPC library, but there might be. Need to investigate further.++-- | Wraps the state necessary to use a gRPC completion queue. Completion queues+-- are used to wait for batches gRPC operations ('Op's) to finish running, as+-- well as wait for various other operations, such as server shutdown, pinging,+-- checking to see if we've been disconnected, and so forth.+data CompletionQueue = CompletionQueue {unsafeCQ        :: C.CompletionQueue,+                                        -- ^ All access to this field must be+                                        -- guarded by a check of 'shuttingDown'.+                                        currentPluckers :: TVar Int,+                                        -- ^ Used to limit the number of+                                        -- concurrent calls to pluck on this+                                        -- queue.+                                        -- The max value is set by gRPC in+                                        -- 'C.maxCompletionQueuePluckers'+                                        currentPushers  :: TVar Int,+                                        -- ^ Used to prevent new work from+                                        -- being pushed onto the queue when+                                        -- the queue begins to shut down.+                                        shuttingDown    :: TVar Bool,+                                        -- ^ Used to prevent new pluck calls on+                                        -- the queue when the queue begins to+                                        -- shut down.+                                        nextTag         :: IORef Int+                                        -- ^ Used to supply unique tags for work+                                        -- items pushed onto the queue.+                                       }++instance Show CompletionQueue where show = show . unsafeCQ++type TimeoutSeconds = Int++data CQOpType = Push | Pluck deriving (Show, Eq, Enum)++-- | Create a new 'C.Tag' for identifying work items on the 'CompletionQueue'.+-- This will eventually wrap around after reaching @maxBound :: Int@, but from a+-- practical perspective, that should be safe.+newTag :: CompletionQueue -> IO C.Tag+newTag CompletionQueue{..} = do+  i <- atomicModifyIORef' nextTag (\i -> (i+1,i))+  return $ C.Tag $ plusPtr nullPtr i++-- | Safely brackets an operation that pushes work onto or plucks results from+-- the given 'CompletionQueue'.+withPermission :: CQOpType+               -> CompletionQueue+               -> IO (Either GRPCIOError a)+               -> IO (Either GRPCIOError a)+withPermission op cq act = bracket acquire release $ \gotResource ->+  if gotResource then act else return (Left GRPCIOShutdown)+  where+    acquire = atomically $ do+      isShuttingDown <- readTVar (shuttingDown cq)+      unless isShuttingDown $ do+        currCount <- readTVar (getCount op cq)+        if currCount < getLimit op+          then writeTVar (getCount op cq) (currCount + 1)+          else retry+      return (not isShuttingDown)+    release gotResource = when gotResource $+      atomically $ modifyTVar' (getCount op cq) (subtract 1)++-- | Waits for the given number of seconds for the given tag to appear on the+-- completion queue. Throws 'GRPCIOShutdown' if the completion queue is shutting+-- down and cannot handle new requests. Note that the timeout is optional. When+-- doing client ops, provide @Nothing@ and the pluck will automatically fail if+-- the deadline associated with the 'ClientCall' expires. If plucking+-- 'serverRequestCall', this will block forever unless a timeout is given.+pluck :: CompletionQueue -> C.Tag -> Maybe TimeoutSeconds+         -> IO (Either GRPCIOError ())+pluck cq@CompletionQueue{..} tag mwait = do+  grpcDebug $ "pluck: called with tag=" ++ show tag ++ ",mwait=" ++ show mwait+  withPermission Pluck cq $ pluck' cq tag mwait++-- Variant of pluck' which assumes pluck permission has been granted.+pluck' :: CompletionQueue+       -> C.Tag+       -> Maybe TimeoutSeconds+       -> IO (Either GRPCIOError ())+pluck' CompletionQueue{..} tag mwait =+  maybe C.withInfiniteDeadline C.withDeadlineSeconds mwait $ \dead -> do+    grpcDebug $ "pluck: blocking on grpc_completion_queue_pluck for tag=" ++ show tag+    ev <- C.grpcCompletionQueuePluck unsafeCQ tag dead C.reserved+    grpcDebug $ "pluck finished: " ++ show ev+    return $ if isEventSuccessful ev then Right () else eventToError ev++-- | Translate 'C.Event' to an error. The caller is responsible for ensuring+-- that the event actually corresponds to an error condition; a successful event+-- will be translated to a 'GRPCIOUnknownError'.+eventToError :: C.Event -> (Either GRPCIOError a)+eventToError (C.Event C.QueueShutdown _ _) = Left GRPCIOShutdown+eventToError (C.Event C.QueueTimeout _ _) = Left GRPCIOTimeout+eventToError (C.Event C.OpComplete False _) = Left GRPCIOTimeout+eventToError _ = Left GRPCIOUnknownError++-- | Returns true iff the given grpc_event was a success.+isEventSuccessful :: C.Event -> Bool+isEventSuccessful (C.Event C.OpComplete True _) = True+isEventSuccessful _ = False++maxWorkPushers :: Int+maxWorkPushers = 100 --TODO: figure out what this should be.++getCount :: CQOpType -> CompletionQueue -> TVar Int+getCount Push  = currentPushers+getCount Pluck = currentPluckers++getLimit :: CQOpType -> Int+getLimit Push  = maxWorkPushers+getLimit Pluck = C.maxCompletionQueuePluckers++-- | Shuts down the completion queue. See the comment above 'CompletionQueue'+-- for the strategy we use to ensure that no one tries to use the+-- queue after we begin the shutdown process. Errors with+-- 'GRPCIOShutdownFailure' if the queue can't be shut down within 5 seconds.+shutdownCompletionQueue :: CompletionQueue -> IO (Either GRPCIOError ())+shutdownCompletionQueue CompletionQueue{..} = do+  atomically $ writeTVar shuttingDown True+  atomically $ do+    readTVar currentPushers  >>= check . (==0)+    readTVar currentPluckers >>= check . (==0)+  --drain the queue+  C.grpcCompletionQueueShutdown unsafeCQ+  loopRes <- timeout (5*10^(6::Int)) drainLoop+  grpcDebug $ "Got CQ loop shutdown result of: " ++ show loopRes+  case loopRes of+    Nothing -> return $ Left GRPCIOShutdownFailure+    Just () -> C.grpcCompletionQueueDestroy unsafeCQ >> return (Right ())++  where drainLoop :: IO ()+        drainLoop = do+          grpcDebug "drainLoop: before next() call"+          ev <- C.withDeadlineSeconds 1 $ \deadline ->+                  C.grpcCompletionQueuePluck unsafeCQ C.noTag deadline C.reserved+          grpcDebug $ "drainLoop: next() call got " ++ show ev+          case C.eventCompletionType ev of+            C.QueueShutdown -> return ()+            C.QueueTimeout -> drainLoop+            C.OpComplete -> drainLoop
+ src/Network/GRPC/LowLevel/CompletionQueue/Unregistered.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE MultiWayIf          #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}+{-# LANGUAGE ViewPatterns        #-}++module Network.GRPC.LowLevel.CompletionQueue.Unregistered where++import           Control.Monad.Managed+import           Control.Monad.Trans.Class                      (MonadTrans (lift))+import           Control.Monad.Trans.Except+import           Foreign.Storable                               (peek)+import           Network.GRPC.LowLevel.Call+import qualified Network.GRPC.LowLevel.Call.Unregistered        as U+import           Network.GRPC.LowLevel.CompletionQueue.Internal+import           Network.GRPC.LowLevel.GRPC+import qualified Network.GRPC.Unsafe                            as C+import qualified Network.GRPC.Unsafe.Constants                  as C+import qualified Network.GRPC.Unsafe.Metadata                   as C+import qualified Network.GRPC.Unsafe.Time                       as C++channelCreateCall :: C.Channel+                  -> C.Call+                  -> C.PropagationMask+                  -> CompletionQueue+                  -> MethodName+                  -> Endpoint+                  -> C.CTimeSpecPtr+                  -> IO (Either GRPCIOError ClientCall)+channelCreateCall chan parent mask cq@CompletionQueue{..} meth endpt deadline =+  withPermission Push cq $ do+    call <- C.grpcChannelCreateCall chan parent mask unsafeCQ+              (unMethodName meth) (unEndpoint endpt) deadline C.reserved+    return $ Right $ ClientCall call+++serverRequestCall :: C.Server+                  -> CompletionQueue -- ^ server CQ / notification CQ+                  -> CompletionQueue -- ^ call CQ+                  -> IO (Either GRPCIOError U.ServerCall)+serverRequestCall s scq ccq =+  withPermission Push scq . with allocs $ \(call, meta, cd) ->+    withPermission Pluck scq $ do+      md  <- peek meta+      tag <- newTag scq+      dbug $ "got pluck permission, registering call for tag=" ++ show tag+      ce  <- C.grpcServerRequestCall s call cd md (unsafeCQ ccq) (unsafeCQ scq) tag+      runExceptT $ case ce of+        C.CallOk -> do+          ExceptT $ do+            let+              rec = do+                -- yield every second, for interruptibility+                r <- pluck' scq tag (Just 1)+                case r of+                  Left GRPCIOTimeout -> rec+                  _ -> return r+            r <- rec+            dbug $ "pluck' finished: " ++ show r+            return r+          lift $+            U.ServerCall+              <$> peek call+              <*> return ccq+              <*> C.getAllMetadataArray md+              <*> (C.timeSpec <$> C.callDetailsGetDeadline cd)+              <*> (MethodName <$> C.callDetailsGetMethod   cd)+              <*> (Host       <$> C.callDetailsGetHost     cd)+        _ -> do+          lift $ dbug $ "Throwing callError: " ++ show ce+          throwE $ GRPCIOCallError ce+  where+    allocs = (,,)+      <$> mgdPtr+      <*> managed C.withMetadataArrayPtr+      <*> managed C.withCallDetails+    dbug = grpcDebug . ("serverRequestCall(U): " ++)
+ src/Network/GRPC/LowLevel/GRPC.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE StandaloneDeriving         #-}++module Network.GRPC.LowLevel.GRPC(+GRPC+, withGRPC+, GRPCIOError(..)+, throwIfCallError+, grpcDebug+, grpcDebug'+, threadDelaySecs+, C.MetadataMap(..)+, C.StatusDetails(..)+) where++import           Control.Concurrent     (threadDelay, myThreadId)+import           Control.Exception+import           Data.Typeable+import qualified Network.GRPC.Unsafe    as C+import qualified Network.GRPC.Unsafe.Op as C+import qualified Network.GRPC.Unsafe.Metadata as C++-- | Functions as a proof that the gRPC core has been started. The gRPC core+-- must be initialized to create any gRPC state, so this is a requirement for+-- the server and client create/start functions.+data GRPC = GRPC++withGRPC :: (GRPC -> IO a) -> IO a+withGRPC = bracket (C.grpcInit >> return GRPC)+                   (\_ -> grpcDebug "withGRPC: shutting down" >> C.grpcShutdown)++-- | Describes all errors that can occur while running a GRPC-related IO+-- action.+data GRPCIOError = GRPCIOCallError C.CallError+                   -- ^ Errors that can occur while the call is in flight. These+                   -- errors come from the core gRPC library directly.+                   | GRPCIOTimeout+                   -- ^ Indicates that we timed out while waiting for an+                   -- operation to complete on the 'CompletionQueue'.+                   | GRPCIOShutdown+                   -- ^ Indicates that the 'CompletionQueue' is shutting down+                   -- and no more work can be processed. This can happen if the+                   -- client or server is shutting down.+                   | GRPCIOShutdownFailure+                   -- ^ Thrown if a 'CompletionQueue' fails to shut down in a+                   -- reasonable amount of time.+                   | GRPCIOUnknownError+                   | GRPCIOBadStatusCode C.StatusCode C.StatusDetails++                   | GRPCIODecodeError String+                   | GRPCIOInternalUnexpectedRecv String -- debugging description+                   | GRPCIOHandlerException String+  deriving (Eq, Show, Typeable)+instance Exception GRPCIOError++throwIfCallError :: C.CallError -> Either GRPCIOError ()+throwIfCallError C.CallOk = Right ()+throwIfCallError x = Left $ GRPCIOCallError x++grpcDebug :: String -> IO ()+{-# INLINE grpcDebug #-}+#ifdef DEBUG+grpcDebug = grpcDebug'+#else+grpcDebug _ = return ()+#endif++grpcDebug' :: String -> IO ()+{-# INLINE grpcDebug' #-}+grpcDebug' str = do+  tid <- myThreadId+  putStrLn $ "[" ++ show tid ++ "]: " ++ str++threadDelaySecs :: Int -> IO ()+threadDelaySecs = threadDelay . (* 10^(6::Int))
+ src/Network/GRPC/LowLevel/Op.hs view
@@ -0,0 +1,327 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE PatternSynonyms            #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE ViewPatterns               #-}++module Network.GRPC.LowLevel.Op where++import           Control.Exception+import           Control.Monad+import           Control.Monad.Trans.Except+import           Data.ByteString                       (ByteString)+import qualified Data.ByteString                       as B+import           Data.Maybe                            (catMaybes)+import           Foreign.C.Types                       (CInt)+import           Foreign.Marshal.Alloc                 (free, malloc)+import           Foreign.Ptr                           (Ptr, nullPtr)+import           Foreign.Storable                      (peek)+import           Network.GRPC.LowLevel.CompletionQueue+import           Network.GRPC.LowLevel.GRPC+import qualified Network.GRPC.Unsafe                   as C (Call)+import qualified Network.GRPC.Unsafe.ByteBuffer        as C+import qualified Network.GRPC.Unsafe.Metadata          as C+import qualified Network.GRPC.Unsafe.Op                as C+import qualified Network.GRPC.Unsafe.Slice             as C+import           Network.GRPC.Unsafe.Slice             (Slice)++-- | Sum describing all possible send and receive operations that can be batched+-- and executed by gRPC. Usually these are processed in a handful of+-- combinations depending on the 'MethodType' of the call being run.+data Op = OpSendInitialMetadata MetadataMap+          | OpSendMessage B.ByteString+          | OpSendCloseFromClient+          | OpSendStatusFromServer MetadataMap C.StatusCode StatusDetails+          | OpRecvInitialMetadata+          | OpRecvMessage+          | OpRecvStatusOnClient+          | OpRecvCloseOnServer+          deriving (Show)++-- | Container holding the pointers to the C and gRPC data needed to execute the+-- corresponding 'Op'. These are obviously unsafe, and should only be used with+-- 'withOpContexts'.+data OpContext =+  OpSendInitialMetadataContext C.MetadataKeyValPtr Int+  | OpSendMessageContext (C.ByteBuffer, C.Slice)+  | OpSendCloseFromClientContext+  | OpSendStatusFromServerContext C.MetadataKeyValPtr Int C.StatusCode Slice+  | OpRecvInitialMetadataContext (Ptr C.MetadataArray)+  | OpRecvMessageContext (Ptr C.ByteBuffer)+  | OpRecvStatusOnClientContext (Ptr C.MetadataArray) (Ptr C.StatusCode) Slice+  | OpRecvCloseOnServerContext (Ptr CInt)+  deriving Show++-- | Length we pass to gRPC for receiving status details+-- when processing 'OpRecvStatusOnClient'. It appears that gRPC actually ignores+-- this length and reallocates a longer string if necessary.+defaultStatusStringLen :: Int+defaultStatusStringLen = 128++-- | Allocates and initializes the 'Opcontext' corresponding to the given 'Op'.+createOpContext :: Op -> IO OpContext+createOpContext (OpSendInitialMetadata m) =+  uncurry OpSendInitialMetadataContext <$> C.createMetadata m+createOpContext (OpSendMessage bs) =+  fmap OpSendMessageContext (C.createByteBuffer bs)+createOpContext (OpSendCloseFromClient) = return OpSendCloseFromClientContext+createOpContext (OpSendStatusFromServer m code (StatusDetails str)) =+  uncurry OpSendStatusFromServerContext+  <$> C.createMetadata m+  <*> return code+  <*> C.byteStringToSlice str+createOpContext OpRecvInitialMetadata =+  fmap OpRecvInitialMetadataContext C.metadataArrayCreate+createOpContext OpRecvMessage =+  fmap OpRecvMessageContext C.createReceivingByteBuffer+createOpContext OpRecvStatusOnClient = do+  pmetadata <- C.metadataArrayCreate+  pstatus <- C.createStatusCodePtr+  slice <- C.grpcSliceMalloc defaultStatusStringLen+  return $ OpRecvStatusOnClientContext pmetadata pstatus slice+createOpContext OpRecvCloseOnServer =+  fmap OpRecvCloseOnServerContext $ malloc++-- | Mutates the given raw array of ops at the given index according to the+-- given 'OpContext'.+setOpArray :: C.OpArray -> Int -> OpContext -> IO ()+setOpArray arr i (OpSendInitialMetadataContext kvs l) =+  C.opSendInitialMetadata arr i kvs l+setOpArray arr i (OpSendMessageContext (bb,_)) =+  C.opSendMessage arr i bb+setOpArray arr i OpSendCloseFromClientContext =+  C.opSendCloseClient arr i+setOpArray arr i (OpSendStatusFromServerContext kvs l code details) =+    C.opSendStatusServer arr i l kvs code details+setOpArray arr i (OpRecvInitialMetadataContext pmetadata) =+  C.opRecvInitialMetadata arr i pmetadata+setOpArray arr i (OpRecvMessageContext pbb) =+  C.opRecvMessage arr i pbb+setOpArray arr i (OpRecvStatusOnClientContext pmetadata pstatus slice) =+  C.opRecvStatusClient arr i pmetadata pstatus slice+setOpArray arr i (OpRecvCloseOnServerContext pcancelled) = do+  C.opRecvCloseServer arr i pcancelled++-- | Cleans up an 'OpContext'.+freeOpContext :: OpContext -> IO ()+freeOpContext (OpSendInitialMetadataContext m _) = C.metadataFree m+freeOpContext (OpSendMessageContext (bb, s)) =+  C.grpcByteBufferDestroy bb >> C.freeSlice s+freeOpContext OpSendCloseFromClientContext = return ()+freeOpContext (OpSendStatusFromServerContext metadata _ _ s) =+  C.metadataFree metadata >> C.freeSlice s+freeOpContext (OpRecvInitialMetadataContext metadata) =+  C.metadataArrayDestroy metadata+freeOpContext (OpRecvMessageContext pbb) =+  C.destroyReceivingByteBuffer pbb+freeOpContext (OpRecvStatusOnClientContext metadata pcode slice) = do+  C.metadataArrayDestroy metadata+  C.destroyStatusCodePtr pcode+  C.freeSlice slice+freeOpContext (OpRecvCloseOnServerContext pcancelled) =+  grpcDebug ("freeOpContext: freeing pcancelled: " ++ show pcancelled)+  >> free pcancelled++-- | Allocates an `OpArray` and a list of `OpContext`s from the given list of+-- `Op`s.+withOpArrayAndCtxts :: [Op] -> ((C.OpArray, [OpContext]) -> IO a) -> IO a+withOpArrayAndCtxts ops = bracket setup teardown+  where setup = do ctxts <- mapM createOpContext ops+                   let l = length ops+                   arr <- C.opArrayCreate l+                   sequence_ $ zipWith (setOpArray arr) [0..l-1] ctxts+                   return (arr, ctxts)+        teardown (arr, ctxts) = do C.opArrayDestroy arr (length ctxts)+                                   mapM_ freeOpContext ctxts++-- | Container holding GC-managed results for 'Op's which receive data.+data OpRecvResult =+  OpRecvInitialMetadataResult MetadataMap+  | OpRecvMessageResult (Maybe B.ByteString)+    -- ^ If a streaming call is in progress and the stream terminates normally,+    -- or If the client or server dies, we might not receive a response body, in+    -- which case this will be 'Nothing'.+  | OpRecvStatusOnClientResult MetadataMap C.StatusCode B.ByteString+  | OpRecvCloseOnServerResult Bool -- ^ True if call was cancelled.+  deriving (Show)++-- | For the given 'OpContext', if the 'Op' receives data, copies the data out+-- of the 'OpContext' and into GC-managed Haskell types. After this, it is safe+-- to destroy the 'OpContext'.+resultFromOpContext :: OpContext -> IO (Maybe OpRecvResult)+resultFromOpContext (OpRecvInitialMetadataContext pmetadata) = do+  grpcDebug "resultFromOpContext: OpRecvInitialMetadataContext"+  metadata <- peek pmetadata+  metadataMap <- C.getAllMetadataArray metadata+  return $ Just $ OpRecvInitialMetadataResult metadataMap+resultFromOpContext (OpRecvMessageContext pbb) = do+  grpcDebug "resultFromOpContext: OpRecvMessageContext"+  bb@(C.ByteBuffer bbptr) <- peek pbb+  if bbptr == nullPtr+     then do grpcDebug "resultFromOpContext: WARNING: got empty message."+             return $ Just $ OpRecvMessageResult Nothing+     else do bs <- C.copyByteBufferToByteString bb+             grpcDebug $ "resultFromOpContext: bb copied: " ++ show bs+             return $ Just $ OpRecvMessageResult (Just bs)+resultFromOpContext (OpRecvStatusOnClientContext pmetadata pcode pstr) = do+  grpcDebug "resultFromOpContext: OpRecvStatusOnClientContext"+  metadata <- peek pmetadata+  metadataMap <- C.getAllMetadataArray metadata+  code <- C.derefStatusCodePtr pcode+  statusInfo <- C.sliceToByteString pstr+  return $ Just $ OpRecvStatusOnClientResult metadataMap code statusInfo+resultFromOpContext (OpRecvCloseOnServerContext pcancelled) = do+  grpcDebug "resultFromOpContext: OpRecvCloseOnServerContext"+  cancelled <- fmap (\x -> if x > 0 then True else False)+                    (peek pcancelled)+  return $ Just $ OpRecvCloseOnServerResult cancelled+resultFromOpContext _ = do+  grpcDebug "resultFromOpContext: saw non-result op type."+  return Nothing++-- | For a given call, run the given 'Op's on the given completion queue with+-- the given tag. Blocks until the ops are complete or the deadline on the+-- associated call has been reached.+-- TODO: now that we distinguish between different types+-- of calls at the type level, we could try to limit the input 'Op's more+-- appropriately. E.g., we don't use an 'OpRecvInitialMetadata' when receiving a+-- registered call, because gRPC handles that for us.++-- TODO: the list of 'Op's type is less specific than it could be. There are+-- only a few different sequences of 'Op's we will see in practice. Once we+-- figure out what those are, we should create a more specific sum+-- type. However, since ops can fail, the list of 'OpRecvResult' returned by+-- 'runOps' can vary in their contents and are perhaps less amenable to+-- simplification.  In the meantime, from looking at the core tests, it looks+-- like it is safe to say that we always get a+-- GRPC_CALL_ERROR_TOO_MANY_OPERATIONS error if we use the same 'Op' twice in+-- the same batch, so we might want to change the list to a set. I don't think+-- order matters within a batch. Need to check.+runOps :: C.Call+          -- ^ 'Call' that this batch is associated with. One call can be+          -- associated with many batches.+       -> CompletionQueue+          -- ^ Queue on which our tag will be placed once our ops are done+          -- running.+       -> [Op]+          -- ^ The list of 'Op's to execute.+       -> IO (Either GRPCIOError [OpRecvResult])+runOps call cq ops =+  let l = length ops in+    -- It is crucial to mask exceptions here. If we don’t do this, we can+    -- run into the following situation:+    --+    -- 1. We allocate an OpContext, e.g., OpRecvMessageContext and the corresponding ByteBuffer.+    -- 2. We pass the buffer to gRPC in startBatch.+    -- 3. If we now get an exception we will free the ByteBuffer.+    -- 4. gRPC can now end up writing to the freed ByteBuffer and we get a heap corruption.+    withOpArrayAndCtxts ops $ \(opArray, contexts) -> mask_ $ do+      grpcDebug $ "runOps: allocated op contexts: " ++ show contexts+      tag <- newTag cq+      grpcDebug $ "runOps: tag: " ++ show tag+      callError <- startBatch cq call opArray l tag+      grpcDebug $ "runOps: called start_batch. callError: "+                   ++ (show callError)+      case callError of+        Left x -> return $ Left x+        Right () -> do+          ev <- pluck cq tag Nothing+          grpcDebug $ "runOps: pluck returned " ++ show ev+          case ev of+            Right () -> do+              grpcDebug "runOps: got good op; starting."+              fmap (Right . catMaybes) $ mapM resultFromOpContext contexts+            Left err -> return $ Left err++runOps' :: C.Call+        -> CompletionQueue+        -> [Op]+        -> ExceptT GRPCIOError IO [OpRecvResult]+runOps' c cq = ExceptT . runOps c cq++-- | If response status info is present in the given 'OpRecvResult's, returns+-- a tuple of trailing metadata, status code, and status details.+extractStatusInfo :: [OpRecvResult]+                     -> Maybe (MetadataMap, C.StatusCode, B.ByteString)+extractStatusInfo [] = Nothing+extractStatusInfo (OpRecvStatusOnClientResult meta code details:_) =+  Just (meta, code, details)+extractStatusInfo (_:xs) = extractStatusInfo xs++--------------------------------------------------------------------------------+-- Types and helpers for common ops batches++type SendSingle a+  =  C.Call+  -> CompletionQueue+  -> a+  -> ExceptT GRPCIOError IO ()++type RecvSingle a+  =  C.Call+  -> CompletionQueue+  -> ExceptT GRPCIOError IO a++pattern RecvMsgRslt :: Maybe ByteString -> Either a [OpRecvResult]+pattern RecvMsgRslt mmsg <- Right [OpRecvMessageResult mmsg]++sendSingle :: SendSingle Op+sendSingle c cq op = void (runOps' c cq [op])++sendInitialMetadata :: SendSingle MetadataMap+sendInitialMetadata c cq = sendSingle c cq . OpSendInitialMetadata++sendStatusFromServer :: SendSingle (MetadataMap, C.StatusCode, StatusDetails)+sendStatusFromServer c cq (md, st, ds) =+  sendSingle c cq (OpSendStatusFromServer md st ds)++recvInitialMessage :: RecvSingle ByteString+recvInitialMessage c cq = ExceptT (streamRecvPrim c cq ) >>= \case+  Nothing -> throwE (GRPCIOInternalUnexpectedRecv "recvInitialMessage: no message.")+  Just bs -> return bs++recvInitialMetadata :: RecvSingle MetadataMap+recvInitialMetadata c cq = runOps' c cq [OpRecvInitialMetadata] >>= \case+  [OpRecvInitialMetadataResult md]+    -> return md+  _ -> throwE (GRPCIOInternalUnexpectedRecv "recvInitialMetadata")++recvInitialMsgMD :: RecvSingle (Maybe ByteString, MetadataMap)+recvInitialMsgMD c cq = runOps' c cq [OpRecvInitialMetadata, OpRecvMessage] >>= \case+  [ OpRecvInitialMetadataResult md, OpRecvMessageResult mmsg]+    -> return (mmsg, md)+  _ -> throwE (GRPCIOInternalUnexpectedRecv "recvInitialMsgMD")++recvStatusOnClient :: RecvSingle (MetadataMap, C.StatusCode, StatusDetails)+recvStatusOnClient c cq = runOps' c cq [OpRecvStatusOnClient] >>= \case+  [OpRecvStatusOnClientResult md st ds]+    -> return (md, st, StatusDetails ds)+  _ -> throwE (GRPCIOInternalUnexpectedRecv "recvStatusOnClient")+++--------------------------------------------------------------------------------+-- Streaming types and helpers++type StreamRecv a = IO (Either GRPCIOError (Maybe a))+streamRecvPrim :: C.Call -> CompletionQueue -> StreamRecv ByteString+streamRecvPrim c cq = f <$> runOps c cq [OpRecvMessage]+  where+    f (RecvMsgRslt mmsg) = Right mmsg+    f Right{}            = Left (GRPCIOInternalUnexpectedRecv "streamRecvPrim")+    f (Left e)           = Left e++type StreamSend a = a -> IO (Either GRPCIOError ())+streamSendPrim :: C.Call -> CompletionQueue -> StreamSend ByteString+streamSendPrim c cq bs = f <$> runOps c cq [OpSendMessage bs]+  where+    f (Right []) = Right ()+    f Right{}    = Left (GRPCIOInternalUnexpectedRecv "streamSendPrim")+    f (Left e)   = Left e++type WritesDone = IO (Either GRPCIOError ())+writesDonePrim :: C.Call -> CompletionQueue -> WritesDone+writesDonePrim c cq = f <$> runOps c cq [OpSendCloseFromClient]+  where+    f (Right []) = Right ()+    f Right{}    = Left (GRPCIOInternalUnexpectedRecv "writesDonePrim")+    f (Left e)   = Left e
+ src/Network/GRPC/LowLevel/Server.hs view
@@ -0,0 +1,471 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE TupleSections       #-}+{-# LANGUAGE ViewPatterns        #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | This module defines data structures and operations pertaining to registered+-- servers using registered calls; for unregistered support, see+-- `Network.GRPC.LowLevel.Server.Unregistered`.+module Network.GRPC.LowLevel.Server where++import           Control.Concurrent                    (ThreadId+                                                        , forkFinally+                                                        , myThreadId+                                                        , killThread)+import           Control.Concurrent.STM                (atomically+                                                        , check)+import           Control.Concurrent.STM.TVar           (TVar+                                                        , modifyTVar'+                                                        , readTVar+                                                        , writeTVar+                                                        , readTVarIO+                                                        , newTVarIO)+import           Control.Exception                     (bracket)+import           Control.Monad+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Except+import           Data.ByteString                       (ByteString)+import qualified Data.ByteString                       as B+import qualified Data.Set as S+import           Network.GRPC.LowLevel.Call+import           Network.GRPC.LowLevel.CompletionQueue (CompletionQueue,+                                                        createCompletionQueue,+                                                        pluck,+                                                        serverRegisterCompletionQueue,+                                                        serverRequestCall,+                                                        serverShutdownAndNotify,+                                                        shutdownCompletionQueue)+import           Network.GRPC.LowLevel.GRPC+import           Network.GRPC.LowLevel.Op+import qualified Network.GRPC.Unsafe                   as C+import qualified Network.GRPC.Unsafe.ChannelArgs       as C+import qualified Network.GRPC.Unsafe.Op                as C+import qualified Network.GRPC.Unsafe.Security          as C++-- | Wraps various gRPC state needed to run a server.+data Server = Server+  { serverGRPC           :: GRPC+  , unsafeServer         :: C.Server+  , listeningPort        :: Port+  , serverCQ             :: CompletionQueue+  -- ^ CQ used for receiving new calls.+  , serverCallCQ               :: CompletionQueue+  -- ^ CQ for running ops on calls. Not used to receive new calls.+  , normalMethods        :: [RegisteredMethod 'Normal]+  , sstreamingMethods    :: [RegisteredMethod 'ServerStreaming]+  , cstreamingMethods    :: [RegisteredMethod 'ClientStreaming]+  , bidiStreamingMethods :: [RegisteredMethod 'BiDiStreaming]+  , serverConfig         :: ServerConfig+  , outstandingForks     :: TVar (S.Set ThreadId)+  , serverShuttingDown   :: TVar Bool+  }++-- TODO: should we make a forkGRPC function instead? I am not sure if it would+-- be safe to let the call handlers threads keep running after the server stops,+-- so I'm taking the more conservative route of ensuring the server will+-- stay alive. Experiment more when time permits.+-- | Fork a thread from the server (presumably for a handler) with the guarantee+-- that the server won't shut down while the thread is alive.+-- Returns true if the fork happens successfully, and false if the server is+-- already shutting down (in which case the function to fork is never executed).+-- If the thread stays alive too long while the server is trying to shut down,+-- the thread will be killed with 'killThread'.+-- The purpose of this is to prevent memory access+-- errors at the C level of the library, not to ensure that application layer+-- operations in user code complete successfully.+forkServer :: Server -> IO () -> IO Bool+forkServer Server{..} f = do+  shutdown <- readTVarIO serverShuttingDown+  case shutdown of+    True  -> return False+    False -> do+      -- NB: The spawned thread waits on 'ready' before running 'f' to ensure+      -- that its ThreadId is inserted into outstandingForks before the cleanup+      -- function deletes it from there. Not doing this can lead to stale thread+      -- ids in the set when handlers cleanup ahead of the insertion, and a+      -- subsequent deadlock in stopServer. We can use a dead-list instead if we+      -- need something more performant.+      ready <- newTVarIO False+      tid   <- let act = do atomically (check =<< readTVar ready)+                            f+               in forkFinally act cleanup+      atomically $ do+        modifyTVar' outstandingForks (S.insert tid)+        modifyTVar' ready (const True)+#ifdef DEBUG+      tids <- readTVarIO outstandingForks+      grpcDebug $ "after fork and bookkeeping: outstandingForks=" ++ show tids+#endif+      return True+      where cleanup _ = do+              tid <- myThreadId+              atomically $ modifyTVar' outstandingForks (S.delete tid)++-- | Configuration for SSL.+data ServerSSLConfig = ServerSSLConfig+  {clientRootCert :: Maybe FilePath,+   serverPrivateKey :: FilePath,+   serverCert :: FilePath,+   clientCertRequest :: C.SslClientCertificateRequestType,+   -- ^ Whether to request a certificate from the client, and what to do with it+   -- if received.+   customMetadataProcessor :: Maybe C.ProcessMeta}++-- | Configuration needed to start a server.+data ServerConfig = ServerConfig+  { host              :: Host+    -- ^ Name of the host the server is running on. Not sure how this is+    -- used. Setting to "localhost" works fine in tests.+  , port              :: Port+    -- ^ Port on which to listen for requests.+  , methodsToRegisterNormal :: [MethodName]+    -- ^ List of normal (non-streaming) methods to register.+  , methodsToRegisterClientStreaming :: [MethodName]+  , methodsToRegisterServerStreaming :: [MethodName]+  , methodsToRegisterBiDiStreaming :: [MethodName]+  , serverArgs        :: [C.Arg]+  -- ^ Optional arguments for setting up the channel on the server. Supplying an+  -- empty list will cause the channel to use gRPC's default options.+  , sslConfig :: Maybe ServerSSLConfig+  -- ^ Server-side SSL configuration. If 'Nothing', the server will use an+  -- insecure connection.+  }++serverEndpoint :: ServerConfig -> Endpoint+serverEndpoint ServerConfig{..} = endpoint host port++addPort :: C.Server -> ServerConfig -> IO Int+addPort server conf@ServerConfig{..} =+  case sslConfig of+    Nothing -> C.grpcServerAddInsecureHttp2Port server e+    Just ServerSSLConfig{..} ->+      do crc <- mapM B.readFile clientRootCert+         spk <- B.readFile serverPrivateKey+         sc <- B.readFile serverCert+         C.withServerCredentials crc spk sc clientCertRequest $ \creds -> do+           case customMetadataProcessor of+             Just p -> C.setMetadataProcessor creds p+             Nothing -> return ()+           C.serverAddSecureHttp2Port server e creds+  where e = unEndpoint $ serverEndpoint conf++startServer :: GRPC -> ServerConfig -> IO Server+startServer grpc conf@ServerConfig{..} =+  C.withChannelArgs serverArgs $ \args -> do+    let e = serverEndpoint conf+    server <- C.grpcServerCreate args C.reserved+    actualPort <- addPort server conf+    when (unPort port > 0 && actualPort /= unPort port) $+      error $ "Unable to bind port: " ++ show port+    cq <- createCompletionQueue grpc+    grpcDebug $ "startServer: server CQ: " ++ show cq+    serverRegisterCompletionQueue server cq++    -- Register methods according to their GRPCMethodType kind. It's a bit ugly+    -- to partition them this way, but we get very convenient phantom typing+    -- elsewhere by doing so.+    -- TODO: change order of args so we can eta reduce.+    ns <- mapM (\nm -> serverRegisterMethodNormal server nm e)+               methodsToRegisterNormal+    ss <- mapM (\nm -> serverRegisterMethodServerStreaming server nm e)+               methodsToRegisterServerStreaming+    cs <- mapM (\nm -> serverRegisterMethodClientStreaming server nm e)+               methodsToRegisterClientStreaming+    bs <- mapM (\nm -> serverRegisterMethodBiDiStreaming server nm e)+               methodsToRegisterBiDiStreaming+    C.grpcServerStart server+    forks <- newTVarIO S.empty+    shutdown <- newTVarIO False+    ccq <- createCompletionQueue grpc+    return $ Server grpc server (Port actualPort) cq ccq ns ss cs bs conf forks+      shutdown++++stopServer :: Server -> IO ()+-- TODO: Do method handles need to be freed?+stopServer Server{ unsafeServer = s, .. } = do+  grpcDebug "stopServer: calling shutdownNotify."+  shutdownNotify serverCQ+  grpcDebug "stopServer: cancelling all calls."+  C.grpcServerCancelAllCalls s+  cleanupForks+  grpcDebug "stopServer: call grpc_server_destroy."+  C.grpcServerDestroy s+  grpcDebug "stopServer: shutting down CQ."+  shutdownCQ serverCQ+  shutdownCQ serverCallCQ++  where shutdownCQ scq = do+          shutdownResult <- shutdownCompletionQueue scq+          case shutdownResult of+            Left _ -> do putStrLn "Warning: completion queue didn't shut down."+                         putStrLn "Trying to stop server anyway."+            Right _ -> return ()+        shutdownNotify scq = do+          let shutdownTag = C.tag 0+          serverShutdownAndNotify s scq shutdownTag+          grpcDebug "called serverShutdownAndNotify; plucking."+          shutdownEvent <- pluck scq shutdownTag (Just 30)+          grpcDebug $ "shutdownNotify: got shutdown event" ++ show shutdownEvent+          case shutdownEvent of+            -- This case occurs when we pluck but the queue is already in the+            -- 'shuttingDown' state, implying we already tried to shut down.+            Left GRPCIOShutdown -> error "Called stopServer twice!"+            Left _              -> error "Failed to stop server."+            Right _             -> return ()+        cleanupForks = do+          atomically $ writeTVar serverShuttingDown True+          liveForks <- readTVarIO outstandingForks+          grpcDebug $ "Server shutdown: killing threads: " ++ show liveForks+          mapM_ killThread liveForks+          -- wait for threads to shut down+          grpcDebug "Server shutdown: waiting until all threads are dead."+          atomically $ check . (==0) . S.size =<< readTVar outstandingForks+          grpcDebug "Server shutdown: All forks cleaned up."++-- Uses 'bracket' to safely start and stop a server, even if exceptions occur.+withServer :: GRPC -> ServerConfig -> (Server -> IO a) -> IO a+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+-- 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+-- 'ServerConfig'.+serverRegisterMethodNormal :: 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 'Normal)+serverRegisterMethodNormal internalServer meth e = do+  h <- serverRegisterMethod internalServer meth e Normal+  return $ RegisteredMethodNormal meth e h++serverRegisterMethodClientStreaming+  :: 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 '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+-- method.+serverCreateCall :: Server+                 -> RegisteredMethod mt+                 -> IO (Either GRPCIOError (ServerCall (MethodPayload mt)))+serverCreateCall Server{..} rm =+  serverRequestCall rm unsafeServer serverCQ serverCallCQ++withServerCall :: Server+               -> RegisteredMethod mt+               -> (ServerCall (MethodPayload mt) -> IO (Either GRPCIOError a))+               -> IO (Either GRPCIOError a)+withServerCall s rm f =+  bracket (serverCreateCall s rm) cleanup $ \case+    Left e  -> return (Left e)+    Right c -> do+      debugServerCall c+      f c+  where+    cleanup (Left _) = pure ()+    cleanup (Right c) = do+      grpcDebug "withServerCall(R): destroying."+      destroyServerCall c++--------------------------------------------------------------------------------+-- serverReader (server side of client streaming mode)++type ServerReaderHandlerLL+  =  ServerCall (MethodPayload 'ClientStreaming)+  -> StreamRecv ByteString+  -> IO (Maybe ByteString, MetadataMap, C.StatusCode, StatusDetails)++serverReader :: Server+             -> RegisteredMethod 'ClientStreaming+             -> MetadataMap -- ^ Initial server metadata+             -> ServerReaderHandlerLL+             -> IO (Either GRPCIOError ())+serverReader s rm initMeta f =+  withServerCall s rm (\sc -> serverReader' s sc initMeta f)++serverReader' :: Server+              -> ServerCall (MethodPayload 'ClientStreaming)+              -> MetadataMap -- ^ Initial server metadata+              -> ServerReaderHandlerLL+              -> IO (Either GRPCIOError ())+serverReader' _ sc@ServerCall{ unsafeSC = c, callCQ = ccq } initMeta f =+  runExceptT $ do+    (mmsg, trailMeta, st, ds) <- liftIO $ f sc (streamRecvPrim c ccq)+    void $ runOps' c ccq ( OpSendInitialMetadata initMeta+                         : OpSendStatusFromServer trailMeta st ds+                         : maybe [] ((:[]) . OpSendMessage) mmsg+                         )++--------------------------------------------------------------------------------+-- serverWriter (server side of server streaming mode)++type ServerWriterHandlerLL+  =  ServerCall (MethodPayload 'ServerStreaming)+  -> StreamSend ByteString+  -> IO (MetadataMap, C.StatusCode, StatusDetails)++-- | Wait for and then handle a registered, server-streaming call.+serverWriter :: Server+             -> RegisteredMethod 'ServerStreaming+             -> MetadataMap -- ^ Initial server metadata+             -> ServerWriterHandlerLL+             -> IO (Either GRPCIOError ())+serverWriter s rm initMeta f =+  withServerCall s rm (\sc -> serverWriter' s sc initMeta f)++serverWriter' :: Server+              -> ServerCall (MethodPayload 'ServerStreaming)+              -> MetadataMap+              -> ServerWriterHandlerLL+              -> IO (Either GRPCIOError ())+serverWriter' _ sc@ServerCall{ unsafeSC = c, callCQ = ccq } initMeta f =+  runExceptT $ do+    sendInitialMetadata c ccq initMeta+    st <- liftIO $ f sc (streamSendPrim c ccq)+    sendStatusFromServer c ccq st++--------------------------------------------------------------------------------+-- serverRW (bidirectional streaming mode)++type ServerRWHandlerLL+  =  ServerCall (MethodPayload 'BiDiStreaming)+  -> StreamRecv ByteString+  -> StreamSend ByteString+  -> IO (MetadataMap, C.StatusCode, StatusDetails)++serverRW :: Server+         -> RegisteredMethod 'BiDiStreaming+         -> MetadataMap -- ^ initial server metadata+         -> ServerRWHandlerLL+         -> IO (Either GRPCIOError ())+serverRW s rm initMeta f =+  withServerCall s rm (\sc -> serverRW' s sc initMeta f)++serverRW' :: Server+          -> ServerCall (MethodPayload 'BiDiStreaming)+          -> MetadataMap+          -> ServerRWHandlerLL+          -> IO (Either GRPCIOError ())+serverRW' _ sc@ServerCall{ unsafeSC = c, callCQ = ccq } initMeta f =+  runExceptT $ do+    sendInitialMetadata c ccq initMeta+    st <- liftIO $ f sc (streamRecvPrim c ccq) (streamSendPrim c ccq)+    sendStatusFromServer c ccq st++--------------------------------------------------------------------------------+-- serverHandleNormalCall (server side of normal request/response)++-- | A handler for a registered server call; bytestring parameter is request+-- body, with the bytestring response body in the result tuple. The first+-- metadata parameter refers to the request metadata, with the two metadata+-- values in the result tuple being the initial and trailing metadata+-- respectively. We pass in the 'ServerCall' so that the server can call+-- 'serverCallCancel' on it if needed.+type ServerHandlerLL+  =  ServerCall (MethodPayload 'Normal)+  -> IO (ByteString, MetadataMap, C.StatusCode, StatusDetails)++-- | Wait for and then handle a normal (non-streaming) call.+serverHandleNormalCall :: Server+                       -> RegisteredMethod 'Normal+                       -> MetadataMap+                       -- ^ Initial server metadata+                       -> ServerHandlerLL+                       -> IO (Either GRPCIOError ())+serverHandleNormalCall s rm initMeta f =+  withServerCall s rm go+  where+    go sc@ServerCall{ unsafeSC = c, callCQ = ccq } = do+      (rsp, trailMeta, st, ds) <- f sc+      void <$> runOps c ccq [ OpSendInitialMetadata initMeta+                            , OpRecvCloseOnServer+                            , OpSendMessage rsp+                            , OpSendStatusFromServer trailMeta st ds+                            ]
+ src/Network/GRPC/LowLevel/Server/Unregistered.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE LambdaCase      #-}+{-# LANGUAGE RecordWildCards #-}++module Network.GRPC.LowLevel.Server.Unregistered where++import           Control.Exception                                  (bracket, finally, mask)+import           Control.Monad+import           Control.Monad.Trans.Except+import           Data.ByteString                                    (ByteString)+import           Network.GRPC.LowLevel.Call.Unregistered+import           Network.GRPC.LowLevel.CompletionQueue.Unregistered (serverRequestCall)+import           Network.GRPC.LowLevel.GRPC+import           Network.GRPC.LowLevel.Op+import           Network.GRPC.LowLevel.Server                       (Server (..),+                                                                     ServerRWHandlerLL,+                                                                     ServerReaderHandlerLL,+                                                                     ServerWriterHandlerLL,+                                                                     forkServer,+                                                                     serverReader',+                                                                     serverWriter',+                                                                     serverRW')+import qualified Network.GRPC.Unsafe.Op                             as C++serverCreateCall :: Server+                 -> IO (Either GRPCIOError ServerCall)+serverCreateCall Server{..} =+  serverRequestCall unsafeServer serverCQ serverCallCQ++withServerCall :: Server+               -> (ServerCall -> IO (Either GRPCIOError a))+               -> IO (Either GRPCIOError a)+withServerCall s f =+  bracket (serverCreateCall s) cleanup $ \case+    Left e -> return (Left e)+    Right c -> f c+  where+    cleanup (Left _) = pure ()+    cleanup (Right c) = do+      grpcDebug "withServerCall: destroying."+      destroyServerCall c++-- | Gets a call and then forks the given function on a new thread, with the+-- new call as input. Blocks until a call is received, then returns immediately.+-- Handles cleaning up the call safely.+-- Because this function doesn't wait for the handler to return, it cannot+-- return errors.+withServerCallAsync :: Server+                    -> (ServerCall -> IO ())+                    -> IO ()+withServerCallAsync s f = mask $ \unmask ->+  serverCreateCall s >>= \case+    Left e -> do grpcDebug $ "withServerCallAsync: call error: " ++ show e+                 return ()+    Right c -> do wasForkSuccess <- forkServer s handler+                  unless wasForkSuccess destroy+                where handler = unmask (f c) `finally` destroy+                      -- TODO: We sometimes never finish cleanup if the server+                      -- is shutting down and calls killThread. This causes gRPC+                      -- core to complain about leaks.  I think the cause of+                      -- this is that killThread gets called after we are+                      -- already in destroyServerCall, and wrapping+                      -- uninterruptibleMask doesn't seem to help.  Doesn't+                      -- crash, but does emit annoying log messages.+                      destroy = do+                        grpcDebug "withServerCallAsync: destroying."+                        destroyServerCall c+                        grpcDebug "withServerCallAsync: cleanup finished."++-- | A handler for an unregistered server call; bytestring arguments are the+-- request body and response body respectively.+type ServerHandler+  =  ServerCall+  -> ByteString+  -> IO (ByteString, MetadataMap, C.StatusCode, StatusDetails)++-- | Handle one unregistered call.+serverHandleNormalCall :: Server+                       -> MetadataMap -- ^ Initial server metadata.+                       -> ServerHandler+                       -> IO (Either GRPCIOError ())+serverHandleNormalCall s initMeta f =+  withServerCall s $ \c -> serverHandleNormalCall' s c initMeta f++serverHandleNormalCall' :: Server+                        -> ServerCall+                        -> MetadataMap -- ^ Initial server metadata.+                        -> ServerHandler+                        -> IO (Either GRPCIOError ())+serverHandleNormalCall'+  _ sc@ServerCall{ unsafeSC = c, callCQ = cq, .. } initMeta f = do+      grpcDebug "serverHandleNormalCall(U): starting batch."+      runOps c cq+        [ OpSendInitialMetadata initMeta+        , OpRecvMessage+        ]+        >>= \case+          Left x -> do+            grpcDebug "serverHandleNormalCall(U): ops failed; aborting"+            return $ Left x+          Right [OpRecvMessageResult (Just body)] -> do+            grpcDebug $ "got client metadata: " ++ show metadata+            grpcDebug $ "call_details host is: " ++ show callHost+            (rsp, trailMeta, st, ds) <- f sc body+            -- TODO: We have to put 'OpRecvCloseOnServer' in the response ops,+            -- or else the client times out. Given this, I have no idea how to+            -- check for cancellation on the server.+            runOps c cq+              [ OpRecvCloseOnServer+              , OpSendMessage rsp,+                OpSendStatusFromServer trailMeta st ds+              ]+              >>= \case+                Left x -> do+                  grpcDebug "serverHandleNormalCall(U): resp failed."+                  return $ Left x+                Right _ -> do+                  grpcDebug "serverHandleNormalCall(U): ops done."+                  return $ Right ()+          x -> error $ "impossible pattern match: " ++ show x++serverReader :: Server+             -> ServerCall+             -> MetadataMap -- ^ Initial server metadata+             -> ServerReaderHandlerLL+             -> IO (Either GRPCIOError ())+serverReader s = serverReader' s . convertCall++serverWriter :: Server+             -> ServerCall+             -> MetadataMap -- ^ Initial server metadata+             -> ServerWriterHandlerLL+             -> IO (Either GRPCIOError ())+serverWriter s sc@ServerCall{ unsafeSC = c, callCQ = ccq } initMeta f =+  runExceptT $ do+    bs <- recvInitialMessage c ccq+    ExceptT (serverWriter' s (const bs <$> convertCall sc) initMeta f)++serverRW :: Server+         -> ServerCall+         -> MetadataMap -- ^ Initial server metadata+         -> ServerRWHandlerLL+         -> IO (Either GRPCIOError ())+serverRW s = serverRW' s . convertCall
+ src/Network/GRPC/Unsafe.chs view
@@ -0,0 +1,307 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving         #-}++module Network.GRPC.Unsafe where++import Control.Exception (bracket)+import Control.Monad++import Data.ByteString (ByteString, useAsCString)+import Data.Semigroup (Semigroup)++import Foreign.C.String (CString, peekCString)+import Foreign.Marshal.Alloc (free)+import Foreign.Ptr+import Foreign.Storable+import GHC.Exts (IsString(..))++{#import Network.GRPC.Unsafe.Time#}+import Network.GRPC.Unsafe.Constants+{#import Network.GRPC.Unsafe.ByteBuffer#}+{#import Network.GRPC.Unsafe.Op#}+{#import Network.GRPC.Unsafe.Metadata#}+{#import Network.GRPC.Unsafe.ChannelArgs#}+{#import Network.GRPC.Unsafe.Slice#}++#include <grpc/grpc.h>+#include <grpc/status.h>+#include <grpc/support/alloc.h>+#include <grpc_haskell.h>++{#context prefix = "grpc" #}++newtype StatusDetails = StatusDetails {unStatusDetails :: ByteString}+  deriving (Eq, IsString, Monoid, Semigroup, Show)++{#pointer *grpc_completion_queue as CompletionQueue newtype #}++deriving instance Show CompletionQueue++-- | Represents a connection to a server. Created on the client side.+{#pointer *grpc_channel as Channel newtype #}++deriving instance Show Channel++-- | Represents a server. Created on the server side.+{#pointer *grpc_server as Server newtype #}++-- | Represents a pointer to a call. To users of the gRPC core library, this+-- type is abstract; we have no access to its fields.+{#pointer *grpc_call as Call newtype #}++deriving instance Show Call++{#pointer *grpc_call_details as CallDetails newtype #}++deriving instance Show CallDetails++{#fun unsafe create_call_details as ^ {} -> `CallDetails'#}+{#fun unsafe destroy_call_details as ^ {`CallDetails'} -> `()'#}++withCallDetails :: (CallDetails -> IO a) -> IO a+withCallDetails = bracket createCallDetails destroyCallDetails++-- instance def adapted from+-- https://mail.haskell.org/pipermail/c2hs/2007-June/000800.html+instance Storable Call where+  sizeOf (Call r) = sizeOf r+  alignment (Call r) = alignment r+  peek p = fmap Call (peek (castPtr p))+  poke p (Call r) = poke (castPtr p) r++{#enum grpc_server_register_method_payload_handling as ServerRegisterMethodPayloadHandling {underscoreToCase} deriving (Eq, Show)#}++-- | A 'Tag' is an identifier that is used with a 'CompletionQueue' to signal+-- that the corresponding operation has completed.+newtype Tag = Tag {unTag :: Ptr ()} deriving (Show, Eq)++tag :: Int -> Tag+tag = Tag . plusPtr nullPtr++noTag :: Tag+noTag = Tag nullPtr++instance Storable Tag where+  sizeOf (Tag p) = sizeOf p+  alignment (Tag p) = alignment p+  peek p = fmap Tag (peek (castPtr p))+  poke p (Tag r) = poke (castPtr p) r++-- | A 'CallHandle' is an identifier used to refer to a registered call. Create+-- one on the client with 'grpcChannelRegisterCall', and on the server with+-- 'grpcServerRegisterMethod'.+newtype CallHandle = CallHandle {unCallHandle :: Ptr ()} deriving (Show, Eq)++-- | 'Reserved' is an as-yet unused void pointer param to several gRPC+-- functions. Create one with 'reserved'.+newtype Reserved = Reserved {unReserved :: Ptr ()}++reserved :: Reserved+reserved = Reserved nullPtr++{#enum grpc_call_error as CallError {underscoreToCase} deriving (Show, Eq)#}++-- | Represents the type of a completion event on a 'CompletionQueue'.+-- 'QueueShutdown' only occurs if the queue is shutting down (e.g., when the+-- server is stopping). 'QueueTimeout' occurs when we reached the deadline+-- before receiving an 'OpComplete'.+{#enum grpc_completion_type as CompletionType {underscoreToCase}+  deriving (Show, Eq)#}++-- | Represents one event received over a 'CompletionQueue'.+data Event = Event {eventCompletionType :: CompletionType,+                    eventSuccess :: Bool,+                    eventTag :: Tag}+                    deriving (Show, Eq)++instance Storable Event where+  sizeOf _ = {#sizeof grpc_event#}+  alignment _ = {#alignof grpc_event#}+  peek p = Event <$> liftM (toEnum . fromIntegral) ({#get grpc_event->type#} p)+                 <*> liftM (> 0) ({#get grpc_event->success#} p)+                 <*> liftM Tag ({#get grpc_event->tag#} p)+  poke p (Event c s t) = do+    {#set grpc_event.type#} p $ fromIntegral $ fromEnum c+    {#set grpc_event.success#} p $ if s then 1 else 0+    {#set grpc_event.tag#} p (unTag t)++-- | Used to unwrap structs from pointers. This is all part of a workaround+-- because the C FFI can't return raw structs directly. So we wrap the C+-- function, mallocing a temporary pointer. This function peeks the struct+-- within the pointer, then frees it.+castPeek :: Storable b => Ptr a -> IO b+castPeek p = do+  val <- peek (castPtr p)+  free p+  return val++{#enum grpc_connectivity_state as ConnectivityState {underscoreToCase}+  deriving (Show, Eq)#}++{#fun grpc_init as ^ {} -> `()'#}++{#fun grpc_shutdown as ^ {} -> `()'#}++{#fun grpc_shutdown_blocking as ^ {} -> `()'#}++{#fun grpc_version_string as ^ {} -> `String' #}++-- | Create a new 'CompletionQueue' for GRPC_CQ_NEXT. See the docs for+-- 'grpcCompletionQueueShutdown' for instructions on how to clean up afterwards.+{#fun grpc_completion_queue_create_for_next as ^+  {unReserved `Reserved'} -> `CompletionQueue'#}++-- | Create a new 'CompletionQueue' for GRPC_CQ_PLUCK. See the docs for+-- 'grpcCompletionQueueShutdown' for instructions on how to clean up afterwards.+{#fun grpc_completion_queue_create_for_pluck as ^+  {unReserved `Reserved'} -> `CompletionQueue'#}++-- | Block until we get the next event off the given 'CompletionQueue',+-- using the given 'CTimeSpecPtr' as a deadline specifying the max amount of+-- time to block.+{#fun grpc_completion_queue_next_ as ^+  {`CompletionQueue', `CTimeSpecPtr',unReserved `Reserved'}+  -> `Event' castPeek*#}++-- | Block until we get the next event with the given 'Tag' off the given+-- 'CompletionQueue'. NOTE: No more than 'maxCompletionQueuePluckers' can call+-- this function concurrently!+{#fun grpc_completion_queue_pluck_ as ^+  {`CompletionQueue',unTag `Tag', `CTimeSpecPtr',unReserved `Reserved'}+  -> `Event' castPeek*#}++-- | Stops a completion queue. After all events are drained,+-- 'grpcCompletionQueueNext' will yield 'QueueShutdown' and then it is safe to+-- call 'grpcCompletionQueueDestroy'. After calling this, we must ensure no+-- new work is pushed to the queue.+{#fun grpc_completion_queue_shutdown as ^ {`CompletionQueue'} -> `()'#}++-- | Destroys a 'CompletionQueue'. See 'grpcCompletionQueueShutdown' for how to+-- use safely. Caller must ensure no threads are calling+-- 'grpcCompletionQueueNext'.+{#fun grpc_completion_queue_destroy as ^ {`CompletionQueue'} -> `()'#}++-- | Sets up a call on the client. The first string is the endpoint name (e.g.+-- @"/foo"@) and the second is the host name. In my tests so far, the host name+-- here doesn't seem to be used... it looks like the host and port specified in+-- 'grpcInsecureChannelCreate' is the one that is actually used.+{#fun grpc_channel_create_call_ as ^+  {`Channel', `Call', fromIntegral `PropagationMask', `CompletionQueue',+   useAsCString* `ByteString', useAsCString* `ByteString', `CTimeSpecPtr',unReserved `Reserved'}+  -> `Call'#}++-- | Create a channel (on the client) to the server. The first argument is+-- host and port, e.g. @"localhost:50051"@. The gRPC docs say that most clients+-- are expected to pass a 'nullPtr' for the 'ChannelArgsPtr'. We currently don't+-- expose any functions for creating channel args, since they are entirely+-- undocumented.+{#fun grpc_insecure_channel_create as ^+  {useAsCString* `ByteString', `GrpcChannelArgs', unReserved `Reserved'} -> `Channel'#}++{#fun grpc_channel_register_call as ^+  {`Channel', useAsCString* `ByteString',useAsCString* `ByteString',unReserved `Reserved'}+  -> `CallHandle' CallHandle#}++{#fun grpc_channel_create_registered_call_ as ^+  {`Channel', `Call', fromIntegral `PropagationMask', `CompletionQueue',+   unCallHandle `CallHandle', `CTimeSpecPtr', unReserved `Reserved'} -> `Call'#}++-- | get the current connectivity state of the given channel. The 'Bool' is+-- True if we should try to connect the channel.+{#fun grpc_channel_check_connectivity_state as ^+  {`Channel', `Bool'} -> `ConnectivityState'#}++-- | When the current connectivity state changes from the given+-- 'ConnectivityState', enqueues a success=1 tag on the given 'CompletionQueue'.+-- If the deadline is reached, enqueues a tag with success=0.+{#fun grpc_channel_watch_connectivity_state_ as ^+  {`Channel', `ConnectivityState', `CTimeSpecPtr', `CompletionQueue',+    unTag `Tag'}+  -> `()'#}++{#fun grpc_channel_ping as ^+  {`Channel', `CompletionQueue', unTag `Tag',unReserved `Reserved'} -> `()' #}++{#fun grpc_channel_destroy as ^ {`Channel'} -> `()'#}++-- | Starts executing a batch of ops in the given 'OpArray'. Does not block.+-- When complete, an event identified by the given 'Tag'+-- will be pushed onto the 'CompletionQueue' that was associated with the given+-- 'Call' when the 'Call' was created.+{#fun unsafe grpc_call_start_batch as ^+  {`Call', `OpArray', `Int', unTag `Tag',unReserved `Reserved'} -> `CallError'#}++{#fun grpc_call_cancel as ^ {`Call',unReserved `Reserved'} -> `()'#}++{#fun grpc_call_cancel_with_status as ^+  {`Call', `StatusCode', `String',unReserved `Reserved'} -> `()'#}++{#fun grpc_call_ref as ^ {`Call'} -> `()'#}++{#fun grpc_call_unref as ^ {`Call'} -> `()'#}++-- | Gets the peer of the current call as a string.+{#fun grpc_call_get_peer as ^ {`Call'} -> `String' getPeerPeek* #}++{#fun gpr_free as ^ {`Ptr ()'} -> `()'#}++getPeerPeek :: CString -> IO String+getPeerPeek cstr = do+  haskellStr <- peekCString cstr+  gprFree (castPtr cstr)+  return haskellStr++-- Server stuff++{#fun grpc_server_create as ^+  {`GrpcChannelArgs',unReserved `Reserved'} -> `Server'#}++{#fun grpc_server_register_method_ as ^+  {`Server',useAsCString* `ByteString',useAsCString* `ByteString', `ServerRegisterMethodPayloadHandling'} -> `CallHandle' CallHandle#}++{#fun grpc_server_register_completion_queue as ^+  {`Server', `CompletionQueue', unReserved `Reserved'} -> `()'#}++{#fun grpc_server_add_insecure_http2_port as ^+  {`Server', useAsCString* `ByteString'} -> `Int'#}++-- | Starts a server. To shut down the server, call these in order:+-- 'grpcServerShutdownAndNotify', 'grpcServerCancelAllCalls',+-- 'grpcServerDestroy'. After these are done, shut down and destroy the server's+-- completion queue with 'grpcCompletionQueueShutdown' followed by+-- 'grpcCompletionQueueDestroy'.+{#fun grpc_server_start as ^ {`Server'} -> `()'#}++{#fun grpc_server_shutdown_and_notify as ^+  {`Server', `CompletionQueue',unTag `Tag'} -> `()'#}++{#fun grpc_server_cancel_all_calls as ^+  {`Server'} -> `()'#}++-- | Destroy the server. See 'grpcServerStart' for complete shutdown+-- instructions.+{#fun grpc_server_destroy as ^ {`Server'} -> `()'#}++-- | Request a call.+-- NOTE: You need to call 'grpcCompletionQueueNext' or+-- 'grpcCompletionQueuePluck' on the completion queue with the given+-- 'Tag' before using the 'Call' pointer again.+{#fun grpc_server_request_call as ^+  {`Server',id `Ptr Call', `CallDetails', `MetadataArray',+   `CompletionQueue', `CompletionQueue',unTag `Tag'}+  -> `CallError'#}++-- | Request a registered call for the given registered method described by a+-- 'CallHandle'. The call, deadline, metadata array, and byte buffer are all+-- out parameters.+{#fun grpc_server_request_registered_call as ^+  {`Server',unCallHandle `CallHandle',id `Ptr Call', `CTimeSpecPtr',+   `MetadataArray', id `Ptr ByteBuffer', `CompletionQueue',+   `CompletionQueue',unTag `Tag'}+  -> `CallError'#}++{#fun unsafe call_details_get_method as ^ {`CallDetails'} -> `ByteString' sliceToByteString* #}++{#fun unsafe call_details_get_host as ^ {`CallDetails'} -> `ByteString' sliceToByteString* #}++{#fun call_details_get_deadline as ^ {`CallDetails'} -> `CTimeSpec' peek* #}
+ src/Network/GRPC/Unsafe/ByteBuffer.chs view
@@ -0,0 +1,97 @@+{-# LANGUAGE StandaloneDeriving #-}++module Network.GRPC.Unsafe.ByteBuffer where++#include <grpc/grpc.h>+#include <grpc/slice.h>+#include <grpc/impl/codegen/compression_types.h>+#include <grpc/slice_buffer.h>++#include <grpc_haskell.h>++{#import Network.GRPC.Unsafe.Slice#}+{#import Network.GRPC.Unsafe.ChannelArgs#}+import Control.Exception (bracket)+import qualified Data.ByteString as B+import Foreign.Ptr+import Foreign.C.Types+import Foreign.Storable++-- | Represents a pointer to a gRPC byte buffer containing 1 or more 'Slice's.+-- Must be destroyed manually with 'grpcByteBufferDestroy'.+{#pointer *grpc_byte_buffer as ByteBuffer newtype #}++deriving instance Show ByteBuffer++--Trivial Storable instance because 'ByteBuffer' type is a pointer.+instance Storable ByteBuffer where+  sizeOf (ByteBuffer r) = sizeOf r+  alignment (ByteBuffer r) = alignment r+  peek p = fmap ByteBuffer (peek (castPtr p))+  poke p (ByteBuffer r) = poke (castPtr p) r++--TODO: When I switched this to a ForeignPtr with a finalizer, I got errors+--about freeing un-malloced memory. Calling the same destroy function by hand+--works fine in the same code, though. Until I find a workaround, going to free+--everything by hand.++-- | Represents a pointer to a ByteBufferReader. Must be destroyed manually with+-- 'byteBufferReaderDestroy'.+{#pointer *grpc_byte_buffer_reader as ByteBufferReader newtype #}++-- | Creates a pointer to a 'ByteBuffer'. This is used to receive data when+-- creating a GRPC_OP_RECV_MESSAGE op.+{#fun unsafe create_receiving_byte_buffer as ^ {} -> `Ptr ByteBuffer' id#}++{#fun unsafe destroy_receiving_byte_buffer as ^ {id `Ptr ByteBuffer'} -> `()'#}++withByteBufferPtr :: (Ptr ByteBuffer -> IO a) -> IO a+withByteBufferPtr+  = bracket createReceivingByteBuffer destroyReceivingByteBuffer++-- | Takes an array of slices and the length of the array and returns a+-- 'ByteBuffer'.+{#fun grpc_raw_byte_buffer_create as ^ {`Slice', `CULong'} -> `ByteBuffer'#}++{#fun grpc_raw_compressed_byte_buffer_create as ^+  {`Slice', `CULong', `CompressionAlgorithm'} -> `ByteBuffer'#}++{#fun unsafe grpc_byte_buffer_copy as ^ {`ByteBuffer'} -> `ByteBuffer'#}++{#fun unsafe grpc_byte_buffer_length as ^ {`ByteBuffer'} -> `CULong'#}++{#fun unsafe grpc_byte_buffer_destroy as ^ {`ByteBuffer'} -> `()'#}++{#fun unsafe byte_buffer_reader_create as ^ {`ByteBuffer'} -> `ByteBufferReader'#}++{#fun unsafe byte_buffer_reader_destroy as ^ {`ByteBufferReader'} -> `()'#}++{#fun grpc_byte_buffer_reader_next as ^+  {`ByteBufferReader', `Slice'} -> `CInt'#}++-- | Returns a 'Slice' containing the entire contents of the 'ByteBuffer' being+-- read by the given 'ByteBufferReader'.+{#fun unsafe grpc_byte_buffer_reader_readall_ as ^ {`ByteBufferReader'} -> `Slice'#}++{#fun unsafe grpc_raw_byte_buffer_from_reader as ^+  {`ByteBufferReader'} -> `ByteBuffer'#}++withByteStringAsByteBuffer :: B.ByteString -> (ByteBuffer -> IO a) -> IO a+withByteStringAsByteBuffer bs f = do+  bracket (byteStringToSlice bs) freeSlice $ \slice -> do+    bracket (grpcRawByteBufferCreate slice 1) grpcByteBufferDestroy f++-- Creates a 'ByteBuffer'. We also return the slice we needed to allocate to+-- create it. It is the caller's responsibility to free both when finished using+-- the byte buffer. In most cases, one should prefer to use+-- 'withByteStringAsByteBuffer' if possible.+createByteBuffer :: B.ByteString -> IO (ByteBuffer, Slice)+createByteBuffer bs = do+  slice <- byteStringToSlice bs+  bb <- grpcRawByteBufferCreate slice 1+  return (bb, slice)++copyByteBufferToByteString :: ByteBuffer -> IO B.ByteString+copyByteBufferToByteString bb = do+  bracket (byteBufferReaderCreate bb) byteBufferReaderDestroy $ \bbr -> do+    bracket (grpcByteBufferReaderReadall bbr) freeSlice sliceToByteString
+ src/Network/GRPC/Unsafe/ChannelArgs.chs view
@@ -0,0 +1,96 @@+{-# LANGUAGE RecordWildCards #-}++module Network.GRPC.Unsafe.ChannelArgs where++import           Control.Exception+import           Control.Monad+import           Foreign.Marshal.Alloc (malloc, free)+import           Foreign.Storable+import           Numeric.Natural++#include <grpc/grpc.h>+#include <grpc/status.h>+#include <grpc/support/alloc.h>+#include <grpc/impl/codegen/compression_types.h>+#include <grpc_haskell.h>++{#enum supported_arg_key as ArgKey {underscoreToCase} deriving (Show, Eq)#}++{#enum grpc_compression_algorithm+  as CompressionAlgorithm {underscoreToCase} deriving (Show, Eq)#}++{#enum grpc_compression_level+  as CompressionLevel {underscoreToCase} deriving (Show, Eq)#}++{#pointer *grpc_arg as ^#}++data ChannelArgs = ChannelArgs {channelArgsN :: Int,+                                channelArgsArray :: GrpcArg}+  deriving (Show, Eq)++{#pointer *grpc_channel_args as ^ -> ChannelArgs#}++instance Storable ChannelArgs where+  sizeOf _ = {#sizeof grpc_channel_args#}+  alignment _ = {#alignof grpc_channel_args#}+  peek p = ChannelArgs <$> fmap fromIntegral+                                ({#get grpc_channel_args->num_args#} p)+                       <*> ({#get grpc_channel_args->args#} p)+  poke p ChannelArgs{..} = do+    {#set grpc_channel_args.num_args#} p $ fromIntegral channelArgsN+    {#set grpc_channel_args.args#} p channelArgsArray++{#fun create_arg_array as ^ {`Int'} -> `GrpcArg'#}++data ArgValue = StringArg String | IntArg Int+  deriving (Show, Eq)++-- | Supported arguments for a channel. More cases will be added as we figure+-- out what they are.+data Arg = CompressionAlgArg CompressionAlgorithm+         | CompressionLevelArg CompressionLevel+         | UserAgentPrefix String+         | UserAgentSuffix String+         | MaxReceiveMessageLength Natural+         | MaxMetadataSize Natural+  deriving (Show, Eq)++{#fun create_string_arg as ^ {`GrpcArg', `Int', `ArgKey', `String'} -> `()'#}++{#fun create_int_arg as ^ {`GrpcArg', `Int', `ArgKey', `Int'} -> `()'#}++{#fun destroy_arg_array as ^ {`GrpcArg', `Int'} -> `()'#}++createArg :: GrpcArg -> Arg -> Int -> IO ()+createArg array (CompressionAlgArg alg) i =+  createIntArg array i CompressionAlgorithmKey (fromEnum alg)+createArg array (CompressionLevelArg lvl) i =+  createIntArg array i CompressionLevelKey (fromEnum lvl)+createArg array (UserAgentPrefix prefix) i =+  createStringArg array i UserAgentPrefixKey prefix+createArg array (UserAgentSuffix suffix) i =+  createStringArg array i UserAgentSuffixKey suffix+createArg array (MaxReceiveMessageLength n) i =+  createIntArg array i MaxReceiveMessageLengthKey $+    fromIntegral (min n (fromIntegral (maxBound :: Int)))+createArg array (MaxMetadataSize n) i =+  createIntArg array i MaxMetadataSizeKey $+    fromIntegral (min n (fromIntegral (maxBound :: Int)))++createChannelArgs :: [Arg] -> IO GrpcChannelArgs+createChannelArgs args = do+  let l = length args+  array <- createArgArray l+  forM_ (zip [0..l] args) $ \(i, arg) -> createArg array arg i+  ptr <- malloc+  poke ptr $ ChannelArgs l array+  return ptr++destroyChannelArgs :: GrpcChannelArgs -> IO ()+destroyChannelArgs ptr =+  do ChannelArgs{..} <- peek ptr+     destroyArgArray channelArgsArray channelArgsN+     free ptr++withChannelArgs :: [Arg] -> (GrpcChannelArgs -> IO a) -> IO a+withChannelArgs args f = bracket (createChannelArgs args) destroyChannelArgs f
+ src/Network/GRPC/Unsafe/Constants.hsc view
@@ -0,0 +1,46 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Network.GRPC.Unsafe.Constants where++#include "grpc/grpc.h"+#include "grpc/impl/codegen/propagation_bits.h"+#include "grpc/impl/codegen/compression_types.h"++argEnableCensus :: Int+argEnableCensus = #const GRPC_ARG_ENABLE_CENSUS++argMaxConcurrentStreams :: Int+argMaxConcurrentStreams = #const GRPC_ARG_MAX_CONCURRENT_STREAMS++argMaxMessageLength :: Int+argMaxMessageLength = #const GRPC_ARG_MAX_MESSAGE_LENGTH++writeBufferHint :: Int+writeBufferHint = #const GRPC_WRITE_BUFFER_HINT++writeNoCompress :: Int+writeNoCompress = #const GRPC_WRITE_NO_COMPRESS++maxCompletionQueuePluckers :: Int+maxCompletionQueuePluckers = #const GRPC_MAX_COMPLETION_QUEUE_PLUCKERS++newtype PropagationMask = PropagationMask {unPropagationMask :: Int}+  deriving (Show, Eq, Ord, Integral, Enum, Real, Num)++propagateDeadline :: PropagationMask+propagateDeadline = PropagationMask $ #const GRPC_PROPAGATE_DEADLINE++propagateCensusStatsContext :: PropagationMask+propagateCensusStatsContext =+  PropagationMask $ #const GRPC_PROPAGATE_CENSUS_STATS_CONTEXT++propagateCensusTracingContext :: PropagationMask+propagateCensusTracingContext =+  PropagationMask $ #const GRPC_PROPAGATE_CENSUS_TRACING_CONTEXT++propagateCancellation :: PropagationMask+propagateCancellation =+  PropagationMask $ #const GRPC_PROPAGATE_CANCELLATION++propagateDefaults :: PropagationMask+propagateDefaults = PropagationMask $ #const GRPC_PROPAGATE_DEFAULTS
+ src/Network/GRPC/Unsafe/Metadata.chs view
@@ -0,0 +1,162 @@+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections      #-}+{-# LANGUAGE TypeFamilies       #-}++module Network.GRPC.Unsafe.Metadata where++{#import Network.GRPC.Unsafe.Slice#}++import Control.Exception+import Control.Monad+import Data.Function (on)+import Data.ByteString (ByteString, useAsCString,+                        useAsCStringLen)+import Data.List (sortBy, groupBy)+import Data.Semigroup (Semigroup((<>)))+import qualified Data.SortedList as SL+import qualified Data.Map.Strict as M+import Data.Ord (comparing)+import Foreign.C.String+import Foreign.Ptr+import Foreign.Storable+import GHC.Exts++#include <grpc/grpc.h>+#include <grpc/status.h>+#include <grpc/impl/codegen/grpc_types.h>+#include <grpc_haskell.h>++-- | Represents metadata for a given RPC, consisting of key-value pairs. Keys+-- are allowed to be repeated. Since repeated keys are unlikely in practice,+-- the 'IsList' instance uses key-value pairs as items. For example,+-- @fromList [("key1","val1"),("key2","val2"),("key1","val3")]@.+newtype MetadataMap = MetadataMap {unMap :: M.Map ByteString (SL.SortedList ByteString)}+  deriving Eq++instance Show MetadataMap where+  show m = "fromList " ++ show (M.toList (unMap m))++instance Semigroup MetadataMap where+  (MetadataMap m1) <> (MetadataMap m2) =+    MetadataMap $ M.unionWith mappend m1 m2++instance Monoid MetadataMap where+  mempty = MetadataMap $ M.empty+  mappend = (<>)++instance IsList MetadataMap where+  type Item MetadataMap = (ByteString, ByteString)+  fromList = MetadataMap+             . M.fromList+             . map (\xs -> ((fst . head) xs, fromList $ map snd xs))+             . groupBy ((==) `on` fst)+             . sortBy (comparing fst)+  toList = concatMap (\(k,vs) -> map (k,) vs)+           . map (fmap toList)+           . M.toList+           . unMap++-- | Represents a pointer to one or more metadata key/value pairs. This type+-- is intended to be used when sending metadata.+{#pointer *grpc_metadata as MetadataKeyValPtr newtype#}++deriving instance Show MetadataKeyValPtr++-- | Represents a pointer to a grpc_metadata_array. Must be destroyed with+-- 'metadataArrayDestroy'. This type is intended for receiving metadata.+-- This can be populated by passing it to e.g. 'grpcServerRequestCall'.+{#pointer *grpc_metadata_array as MetadataArray newtype#}++deriving instance Show MetadataArray++{#fun unsafe metadata_array_get_metadata as ^+  {`MetadataArray'} -> `MetadataKeyValPtr'#}++-- | Overwrites the metadata in the given 'MetadataArray'. The given+-- 'MetadataKeyValPtr' *must* have been created with 'createMetadata' in this+-- module.+{#fun unsafe metadata_array_set_metadata as ^+  {`MetadataArray', `MetadataKeyValPtr'} -> `()'#}++{#fun unsafe metadata_array_get_count as ^ {`MetadataArray'} -> `Int'#}++{#fun unsafe metadata_array_get_capacity as ^ {`MetadataArray'} -> `Int'#}++instance Storable MetadataArray where+  sizeOf (MetadataArray r) = sizeOf r+  alignment (MetadataArray r) = alignment r+  peek p = fmap MetadataArray (peek (castPtr p))+  poke p (MetadataArray r) = poke (castPtr p) r++-- | Create an empty 'MetadataArray'. Returns a pointer to it so that we can+-- pass it to the appropriate op creation functions.+{#fun unsafe metadata_array_create as ^ {} -> `Ptr MetadataArray' id#}++{#fun unsafe metadata_array_destroy as ^ {id `Ptr MetadataArray'} -> `()'#}++-- Note: I'm pretty sure we must call out to C to allocate these+-- because they are nested structs.+-- | Allocates space for exactly n metadata key/value pairs.+{#fun unsafe metadata_alloc as ^ {`Int'} -> `MetadataKeyValPtr'#}++{#fun unsafe metadata_free as ^ {`MetadataKeyValPtr'} -> `()'#}++-- | Sets a metadata key/value pair at the given index in the+-- 'MetadataKeyValPtr'. No error checking is performed to ensure the index is+-- in bounds!+{#fun unsafe set_metadata_key_val as setMetadataKeyVal'+  {useAsCString* `ByteString', `CString', `Int',+   `MetadataKeyValPtr', `Int'} -> `()'#}++setMetadataKeyVal :: ByteString+                     -> ByteString+                     -> MetadataKeyValPtr+                     -> Int+                     -> IO ()+setMetadataKeyVal k v m i =+  useAsCStringLen v $ \(vStr, vLen) -> setMetadataKeyVal' k vStr vLen m i++{#fun unsafe get_metadata_key as getMetadataKey'+  {`MetadataKeyValPtr', `Int'} -> `Slice'#}++{#fun unsafe get_metadata_val as getMetadataVal'+  {`MetadataKeyValPtr', `Int'} -> `Slice'#}++withMetadataArrayPtr :: (Ptr MetadataArray -> IO a) -> IO a+withMetadataArrayPtr = bracket metadataArrayCreate metadataArrayDestroy++withMetadataKeyValPtr :: Int -> (MetadataKeyValPtr -> IO a) -> IO a+withMetadataKeyValPtr i f = bracket (metadataAlloc i) metadataFree f++getMetadataKey :: MetadataKeyValPtr -> Int -> IO ByteString+getMetadataKey m = getMetadataKey' m >=> sliceToByteString++getMetadataVal :: MetadataKeyValPtr -> Int -> IO ByteString+getMetadataVal m i = do vStr <- getMetadataVal' m i+                        sliceToByteString vStr++createMetadata :: MetadataMap -> IO (MetadataKeyValPtr, Int)+createMetadata m = do+  let indexedKeyVals = zip [0..] $ toList m+      l = length indexedKeyVals+  metadata <- metadataAlloc l+  forM_ indexedKeyVals $ \(i,(k,v)) -> setMetadataKeyVal k v metadata i+  return (metadata, l)++withPopulatedMetadataKeyValPtr :: MetadataMap+                                  -> ((MetadataKeyValPtr, Int) -> IO a)+                                  -> IO a+withPopulatedMetadataKeyValPtr m = bracket (createMetadata m)+                                           (metadataFree . fst)++getAllMetadataArray :: MetadataArray -> IO MetadataMap+getAllMetadataArray m = do+  kvs <- metadataArrayGetMetadata m+  l <- metadataArrayGetCount m+  getAllMetadata kvs l++getAllMetadata :: MetadataKeyValPtr -> Int -> IO MetadataMap+getAllMetadata m count = do+  let indices = [0..count-1]+  fmap fromList $ forM indices $+    \i -> liftM2 (,) (getMetadataKey m i) (getMetadataVal m i)
+ src/Network/GRPC/Unsafe/Op.chs view
@@ -0,0 +1,109 @@+{-# LANGUAGE StandaloneDeriving #-}++module Network.GRPC.Unsafe.Op where++{#import Network.GRPC.Unsafe.Slice#}++import Control.Exception+import Foreign.C.Types+import Foreign.Ptr+{#import Network.GRPC.Unsafe.ByteBuffer#}+{#import Network.GRPC.Unsafe.Metadata#}++#include <grpc/grpc.h>+#include <grpc/status.h>+#include <grpc/impl/codegen/grpc_types.h>+#include <grpc_haskell.h>++{#context prefix = "grpc" #}++{#enum grpc_op_type as OpType {underscoreToCase} deriving (Eq, Show)#}+{#enum grpc_status_code as StatusCode {underscoreToCase} deriving (Eq, Read, Show)#}++-- NOTE: We don't alloc the space for the enum in Haskell because enum size is+-- implementation-dependent. See:+-- http://stackoverflow.com/questions/1113855/is-the-sizeofenum-sizeofint-always+-- | Allocates space for a 'StatusCode' and returns a pointer to it. Used to+-- receive a status code from the server with 'opRecvStatusClient'.+{#fun unsafe create_status_code_ptr as ^ {} -> `Ptr StatusCode' castPtr#}++{#fun unsafe deref_status_code_ptr as ^ {castPtr `Ptr StatusCode'} -> `StatusCode'#}++{#fun unsafe destroy_status_code_ptr as ^ {castPtr `Ptr StatusCode'} -> `()' #}++-- | Represents an array of ops to be passed to 'grpcCallStartBatch'.+-- Create an array with 'opArrayCreate', then create individual ops in the array+-- using the op* functions. For these functions, the first two arguments are+-- always the OpArray to mutate and the index in the array at which to create+-- the new op. After processing the batch and getting out any results, call+-- 'opArrayDestroy'.+{#pointer *grpc_op as OpArray newtype #}++deriving instance Show OpArray++-- | Creates an empty 'OpArray' with space for the given number of ops.+{#fun unsafe op_array_create as ^ {`Int'} -> `OpArray'#}++-- | Destroys an 'OpArray' of the given size.+{#fun unsafe op_array_destroy as ^ {`OpArray', `Int'} -> `()'#}++-- | brackets creating and destroying an 'OpArray' with the given size.+withOpArray :: Int -> (OpArray -> IO a) -> IO a+withOpArray n f = bracket (opArrayCreate n) (flip opArrayDestroy n) f++-- | Creates an op of type GRPC_OP_SEND_INITIAL_METADATA at the specified+-- index of the given 'OpArray', containing the given+-- metadata. The metadata is copied and can be destroyed after calling this+-- function.+{#fun unsafe op_send_initial_metadata as ^+  {`OpArray', `Int', `MetadataKeyValPtr', `Int'} -> `()'#}++-- | Creates an op of type GRPC_OP_SEND_INITIAL_METADATA at the specified+-- index of the given 'OpArray'. The op will contain no metadata.+{#fun unsafe op_send_initial_metadata_empty as ^ {`OpArray', `Int'} -> `()'#}++-- | Creates an op of type GRPC_OP_SEND_MESSAGE at the specified index of+-- the given 'OpArray'. The given 'ByteBuffer' is+-- copied and can be destroyed after calling this function.+{#fun unsafe op_send_message as ^ {`OpArray', `Int', `ByteBuffer'} -> `()'#}++-- | Creates an 'Op' of type GRPC_OP_SEND_CLOSE_FROM_CLIENT at the specified+-- index of the given 'OpArray'.+{#fun unsafe op_send_close_client as ^ {`OpArray', `Int'} -> `()'#}++-- | Creates an op of type GRPC_OP_RECV_INITIAL_METADATA at the specified+-- index of the given 'OpArray', and ties the given+-- 'MetadataArray' pointer to that op so that the received metadata can be+-- accessed. It is the user's responsibility to destroy the 'MetadataArray'.+{#fun unsafe op_recv_initial_metadata as ^+  {`OpArray', `Int',id `Ptr MetadataArray'} -> `()'#}++-- | Creates an op of type GRPC_OP_RECV_MESSAGE at the specified index of the+-- given 'OpArray', and ties the given+-- 'ByteBuffer' pointer to that op so that the received message can be+-- accessed. It is the user's responsibility to destroy the 'ByteBuffer'.+{#fun unsafe op_recv_message as ^ {`OpArray', `Int',id `Ptr ByteBuffer'} -> `()'#}++-- | Creates an op of type GRPC_OP_RECV_STATUS_ON_CLIENT at the specified+-- index of the given 'OpArray', and ties all the+-- input pointers to that op so that the results of the receive can be+-- accessed. It is the user's responsibility to free all the input args after+-- this call.+{#fun unsafe op_recv_status_client as ^+  {`OpArray', `Int',id `Ptr MetadataArray', castPtr `Ptr StatusCode',+   `Slice'}+  -> `()'#}++-- | Creates an op of type GRPC_OP_RECV_CLOSE_ON_SERVER at the specified index+-- of the given 'OpArray', and ties the input+-- pointer to that op so that the result of the receive can be accessed. It is+-- the user's responsibility to free the pointer.+{#fun unsafe op_recv_close_server as ^ {`OpArray', `Int', id `Ptr CInt'} -> `()'#}++-- | Creates an op of type GRPC_OP_SEND_STATUS_FROM_SERVER at the specified+-- index of the given 'OpArray'. The given+-- Metadata and string are copied when creating the op, and can be safely+-- destroyed immediately after calling this function.+{#fun unsafe op_send_status_server as ^+  {`OpArray', `Int', `Int', `MetadataKeyValPtr', `StatusCode', `Slice'}+  -> `()'#}
+ src/Network/GRPC/Unsafe/Security.chs view
@@ -0,0 +1,398 @@+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE RecordWildCards    #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections      #-}++module Network.GRPC.Unsafe.Security where++import Control.Exception (bracket)+import Data.ByteString (ByteString, useAsCString, packCString, packCStringLen)+import Data.Coerce (coerce)+import Foreign.C.String (CString)+import Foreign.C.Types+import Foreign.Storable+import Foreign.Marshal.Alloc (free)+import Foreign.Ptr (nullPtr, FunPtr, Ptr, castPtr)++#include <grpc/grpc.h>+#include <grpc/grpc_security.h>+#include <grpc_haskell.h>++{#import Network.GRPC.Unsafe#}+{#import Network.GRPC.Unsafe.ChannelArgs#}+{#import Network.GRPC.Unsafe.Metadata#}+{#import Network.GRPC.Unsafe.Op#}++{#context prefix = "grpc_"#}++-- * Types++-- | Context for auth. This is essentially just a set of key-value pairs that+-- can be mutated.+-- Note: it appears that any keys set or modified on this object do not+-- appear in the AuthContext of the peer, so you must send along auth info+-- in the metadata. It's currently unclear to us what+-- the purpose of modifying this is, but we offer the ability for the sake of+-- completeness.+{#pointer *auth_context as ^ newtype#}++deriving instance Show AuthContext++instance Storable AuthContext where+  sizeOf (AuthContext p) = sizeOf p+  alignment (AuthContext p) = alignment p+  peek p = AuthContext <$> peek (castPtr p)+  poke p (AuthContext r) = poke (castPtr p) r++{#pointer *auth_property_iterator as ^ newtype#}++{#pointer *call_credentials as ^ newtype#}++{#pointer *channel_credentials as ^ newtype#}++{#pointer *server_credentials as ^ newtype#}++withAuthPropertyIterator :: AuthContext+                            -> (AuthPropertyIterator -> IO a)+                            -> IO a+withAuthPropertyIterator ctx = bracket (authContextPropertyIterator ctx)+                                       (free . coerce)++-- | Represents one key/value pair in an 'AuthContext'.+data AuthProperty = AuthProperty+  {authPropName :: ByteString,+   authPropValue :: ByteString}+  deriving (Show, Eq)++marshalAuthProperty :: Ptr AuthProperty -> IO AuthProperty+marshalAuthProperty p = do+  n <- packCString =<< ({# get auth_property->name #} p)+  vl <- fromIntegral <$> {# get auth_property->value_length #} p+  v <- packCStringLen . (,vl) =<< {#get auth_property->value #} p+  return $ AuthProperty n v++-- | The context which a client-side auth metadata plugin sees when it runs.+data AuthMetadataContext = AuthMetadataContext+  {serviceURL :: ByteString,+   -- ^ The URL of the service the current call is going to.+   methodName :: ByteString,+   -- ^ The method that is being invoked with the current call. It appears that+   -- the gRPC 0.15 core is not populating this correctly, because it's an empty+   -- string in my tests so far.+   channelAuthContext :: AuthContext+ }+  deriving Show++authMetadataContextMarshal :: Ptr AuthMetadataContext -> IO AuthMetadataContext+authMetadataContextMarshal p =+  AuthMetadataContext+   <$> (({#get auth_metadata_context->service_url #} p) >>= packCString)+   <*> (({#get auth_metadata_context->method_name #} p) >>= packCString)+   <*> ({#get auth_metadata_context->channel_auth_context#} p)++{#pointer *metadata_credentials_plugin as ^ newtype#}++{#pointer *auth_metadata_processor as ^ newtype#}++{#enum ssl_client_certificate_request_type as ^ {underscoreToCase}+  deriving (Eq, Ord, Bounded, Show)#}++-- * Auth Contexts++-- | If used, the 'AuthContext' must be released with 'AuthContextRelease'.+{#fun unsafe call_auth_context as ^+  {`Call'} -> `AuthContext'#}++{#fun unsafe auth_context_release as ^+  {`AuthContext'} -> `()'#}++{#fun unsafe auth_context_add_cstring_property as addAuthProperty'+  {`AuthContext',+   useAsCString* `ByteString',+   useAsCString* `ByteString'}+  -> `()'#}++-- | Adds a new property to the given 'AuthContext'.+addAuthProperty :: AuthContext -> AuthProperty -> IO ()+addAuthProperty ctx prop =+  addAuthProperty' ctx (authPropName prop) (authPropValue prop)++{-+TODO: The functions for getting and setting peer identities cause+unpredictable crashes when used in conjunction with other, more general+auth property getter/setter functions. If we end needing these, we should+investigate further.++coercePack :: Ptr a -> IO ByteString+coercePack = packCString . coerce++{#fun unsafe grpc_auth_context_peer_identity_property_name+  as getPeerIdentityPropertyName+  {`AuthContext'} -> `ByteString' coercePack* #}++{#fun unsafe auth_context_set_peer_identity_property_name+  as setPeerIdentity+  {`AuthContext', useAsCString* `ByteString'} -> `()'#}++{#fun unsafe auth_context_peer_identity as getPeerIdentity+  {`AuthContext'} -> `ByteString' coercePack* #}+-}+-- * Property Iteration++{#fun unsafe auth_context_property_iterator_ as ^+  {`AuthContext'} -> `AuthPropertyIterator'#}++{#fun unsafe auth_property_iterator_next as ^+  {`AuthPropertyIterator'} -> `Ptr AuthProperty' coerce#}++getAuthProperties :: AuthContext -> IO [AuthProperty]+getAuthProperties ctx = withAuthPropertyIterator ctx $ \i -> do+  go i+  where go :: AuthPropertyIterator -> IO [AuthProperty]+        go i = do p <- authPropertyIteratorNext i+                  if p == nullPtr+                     then return []+                     else do props <- go i+                             prop <- marshalAuthProperty p+                             return (prop:props)++-- * Channel Credentials++{#fun unsafe channel_credentials_release as ^+  {`ChannelCredentials'} -> `()'#}++{#fun unsafe composite_channel_credentials_create as ^+  {`ChannelCredentials', `CallCredentials',unReserved `Reserved'}+  -> `ChannelCredentials'#}++{#fun unsafe ssl_credentials_create_internal as ^+  {`CString', `CString', `CString'} -> `ChannelCredentials'#}++sslChannelCredentialsCreate :: Maybe ByteString+                               -> Maybe ByteString+                               -> Maybe ByteString+                               -> IO ChannelCredentials+sslChannelCredentialsCreate (Just s) Nothing Nothing =+  useAsCString s $ \s' -> sslCredentialsCreateInternal s' nullPtr nullPtr+sslChannelCredentialsCreate Nothing (Just s1) (Just s2) =+  useAsCString s1 $ \s1' -> useAsCString s2 $ \s2' ->+  sslCredentialsCreateInternal nullPtr s1' s2'+sslChannelCredentialsCreate (Just s1) (Just s2) (Just s3) =+  useAsCString s1 $ \s1' -> useAsCString s2 $ \s2' -> useAsCString s3 $ \s3' ->+  sslCredentialsCreateInternal s1' s2' s3'+sslChannelCredentialsCreate (Just s1) _ _ =+  useAsCString s1 $ \s1' ->+  sslCredentialsCreateInternal s1' nullPtr nullPtr+sslChannelCredentialsCreate _ _ _ =+  sslCredentialsCreateInternal nullPtr nullPtr nullPtr++withChannelCredentials :: Maybe ByteString+                          -> Maybe ByteString+                          -> Maybe ByteString+                          -> (ChannelCredentials -> IO a)+                          -> IO a+withChannelCredentials x y z = bracket (sslChannelCredentialsCreate x y z)+                                       channelCredentialsRelease++-- * Call Credentials++{#fun call_set_credentials as ^+  {`Call', `CallCredentials'} -> `CallError'#}++{#fun unsafe call_credentials_release as ^+  {`CallCredentials'} -> `()'#}++{#fun unsafe composite_call_credentials_create as ^+  {`CallCredentials', `CallCredentials', unReserved `Reserved'}+  -> `CallCredentials'#}++-- * Server Credentials++{#fun unsafe server_credentials_release as ^+  {`ServerCredentials'} -> `()'#}++{#fun ssl_server_credentials_create_internal as ^+  {`CString',+   useAsCString*  `ByteString',+   useAsCString* `ByteString',+   `SslClientCertificateRequestType'}+  -> `ServerCredentials'#}++sslServerCredentialsCreate :: Maybe ByteString+                              -- ^ PEM encoding of the client root certificates.+                              -- Can be 'Nothing' if SSL authentication of+                              -- clients is not desired.+                              -> ByteString+                              -- ^ Server private key.+                              -> ByteString+                              -- ^ Server certificate.+                              -> SslClientCertificateRequestType+                              -- ^ How to handle client certificates.+                              -> IO ServerCredentials+sslServerCredentialsCreate Nothing k c t =+  sslServerCredentialsCreateInternal nullPtr k c t+sslServerCredentialsCreate (Just cc) k c t =+  useAsCString cc $ \cc' -> sslServerCredentialsCreateInternal cc' k c t++withServerCredentials :: Maybe ByteString+                         -- ^ PEM encoding of the client root certificates.+                         -- Can be 'Nothing' if SSL authentication of+                         -- clients is not desired.+                         -> ByteString+                         -- ^ Server private key.+                         -> ByteString+                         -- ^ Server certificate.+                         -> SslClientCertificateRequestType+                         -- ^ How to handle client certificates.+                         -> (ServerCredentials -> IO a)+                         -> IO a+withServerCredentials a b c d = bracket (sslServerCredentialsCreate a b c d)+                                        serverCredentialsRelease++-- * Creating Secure Clients/Servers++{#fun server_add_secure_http2_port as ^+  {`Server',useAsCString*  `ByteString', `ServerCredentials'} -> `Int'#}++{#fun secure_channel_create as ^+  {`ChannelCredentials',useAsCString* `ByteString', `GrpcChannelArgs', unReserved `Reserved'}+  -> `Channel'#}++-- * Custom metadata processing -- server side++-- | Type synonym for the raw function pointer we pass to C to handle custom+-- server-side metadata auth processing.+type CAuthProcess = Ptr ()+                 -> AuthContext+                 -> MetadataKeyValPtr+                 -> CSize+                 -> FunPtr CDoneCallback+                 -> Ptr ()+                 -> IO ()++foreign import ccall "wrapper"+  mkAuthProcess :: CAuthProcess -> IO (FunPtr CAuthProcess)++type CDoneCallback = Ptr ()+                   -> MetadataKeyValPtr+                   -> CSize+                   -> MetadataKeyValPtr+                   -> CSize+                   -> CInt -- ^ statuscode+                   -> CString -- ^ status details+                   -> IO ()++foreign import ccall "dynamic"+  unwrapDoneCallback :: FunPtr CDoneCallback -> CDoneCallback++{#fun server_credentials_set_auth_metadata_processor_ as ^+  {`ServerCredentials', `AuthMetadataProcessor'} -> `()'#}++foreign import ccall "grpc_haskell.h mk_auth_metadata_processor"+  mkAuthMetadataProcessor :: FunPtr CAuthProcess -> IO AuthMetadataProcessor++data AuthProcessorResult = AuthProcessorResult+  { resultConsumedMetadata :: MetadataMap+  -- ^ Metadata to remove from the request before passing to the handler.+  , resultResponseMetadata :: MetadataMap+  -- ^ Metadata to add to the response.+  , resultStatus :: StatusCode+  -- ^ StatusOk if auth was successful. Using any other status code here will+  -- cause the request to be rejected without reaching a handler.+  -- For rejected requests, it's suggested that this+  -- be StatusUnauthenticated or StatusPermissionDenied.+  -- NOTE: if you are using the low-level interface and the request is rejected,+  -- then handling functions in the low-level+  -- interface such as 'serverHandleNormalCall' will not unblock until they+  -- receive another request that is not rejected. So, if you write a buggy+  -- auth plugin that rejects all requests, your server could hang.+  , resultStatusDetails :: StatusDetails}++-- | A custom auth metadata processor. This can be used to implement customized+-- auth schemes based on the metadata in the request.+type ProcessMeta = AuthContext+                   -> MetadataMap+                   -> IO AuthProcessorResult++convertProcessor :: ProcessMeta -> CAuthProcess+convertProcessor f = \_state authCtx inMeta numMeta callBack userDataPtr -> do+  meta <- getAllMetadata inMeta (fromIntegral numMeta)+  AuthProcessorResult{..} <- f authCtx meta+  let cb = unwrapDoneCallback callBack+  let status = (fromEnum resultStatus)+  withPopulatedMetadataKeyValPtr resultConsumedMetadata $ \(conMeta, conLen) ->+    withPopulatedMetadataKeyValPtr resultResponseMetadata $ \(resMeta, resLen) ->+    useAsCString (unStatusDetails resultStatusDetails) $ \dtls -> do+      cb userDataPtr+         conMeta+         (fromIntegral conLen)+         resMeta+         (fromIntegral resLen)+         (fromIntegral status)+         dtls++-- | Sets the custom metadata processor for the given server credentials.+setMetadataProcessor :: ServerCredentials -> ProcessMeta -> IO ()+setMetadataProcessor creds processor = do+  let rawProcessor = convertProcessor processor+  rawProcessorPtr <- mkAuthProcess rawProcessor+  metaProcessor <- mkAuthMetadataProcessor rawProcessorPtr+  serverCredentialsSetAuthMetadataProcessor creds metaProcessor++-- * Client-side metadata plugins++type CGetMetadata = Ptr AuthMetadataContext+                 -> FunPtr CGetMetadataCallBack+                 -> Ptr ()+                -- ^ user data ptr (opaque, but must be passed on)+                 -> IO ()++foreign import ccall "wrapper"+  mkCGetMetadata :: CGetMetadata -> IO (FunPtr CGetMetadata)++type CGetMetadataCallBack = Ptr ()+                         -> MetadataKeyValPtr+                         -> CSize+                         -> CInt+                         -> CString+                         -> IO ()++foreign import ccall "dynamic"+  unwrapGetMetadataCallback :: FunPtr CGetMetadataCallBack+                            -> CGetMetadataCallBack++data ClientMetadataCreateResult = ClientMetadataCreateResult+  { clientResultMetadata :: MetadataMap+    -- ^ Additional metadata to add to the call.+  , clientResultStatus   :: StatusCode+   -- ^ if not 'StatusOk', causes the call to fail with the given status code.+   -- NOTE: if the auth fails, the call will not get sent to the server. So, if+   -- you're writing a test, your server might wait for a request forever.+  , clientResultDetails  :: StatusDetails }++-- | Optional plugin for attaching custom auth metadata to each call.+type ClientMetadataCreate = AuthMetadataContext+                            -> IO ClientMetadataCreateResult++convertMetadataCreate :: ClientMetadataCreate -> CGetMetadata+convertMetadataCreate f = \authCtxPtr doneCallback userDataPtr -> do+  authCtx <- authMetadataContextMarshal authCtxPtr+  ClientMetadataCreateResult{..} <- f authCtx+  let cb = unwrapGetMetadataCallback doneCallback+  withPopulatedMetadataKeyValPtr clientResultMetadata $ \(meta,metaLen) ->+    useAsCString (unStatusDetails clientResultDetails) $ \details -> do+      let status = fromIntegral $ fromEnum clientResultStatus+      cb userDataPtr meta (fromIntegral metaLen) status details++foreign import ccall "grpc_haskell.h mk_metadata_client_plugin"+  mkMetadataClientPlugin :: FunPtr CGetMetadata -> IO MetadataCredentialsPlugin++{#fun metadata_credentials_create_from_plugin_ as ^+  {`MetadataCredentialsPlugin'} -> `CallCredentials' #}++createCustomCallCredentials :: ClientMetadataCreate -> IO CallCredentials+createCustomCallCredentials create = do+  let rawCreate = convertMetadataCreate create+  rawCreatePtr <- mkCGetMetadata rawCreate+  plugin <- mkMetadataClientPlugin rawCreatePtr+  metadataCredentialsCreateFromPlugin plugin
+ src/Network/GRPC/Unsafe/Slice.chs view
@@ -0,0 +1,60 @@+{-# LANGUAGE StandaloneDeriving #-}++module Network.GRPC.Unsafe.Slice where++#include <grpc/slice.h>+#include <grpc_haskell.h>++import qualified Data.ByteString as B+import Foreign.C.String+import Foreign.C.Types+import Foreign.Ptr++-- | A 'Slice' is gRPC's string type. We can easily convert these to and from+-- ByteStrings. This type is a pointer to a C type.+{#pointer *grpc_slice as Slice newtype #}++deriving instance Show Slice++-- TODO: we could also represent this type as 'Ptr Slice', by doing this:+-- newtype Slice = Slice {#type grpc_slice#}+-- This would have no practical effect, but it would communicate intent more+-- clearly by emphasizing that the type is indeed a pointer and that the data+-- it is pointing to might change/be destroyed after running IO actions. To make+-- the change, we would just need to change all occurrences of 'Slice' to+-- 'Ptr Slice' and add 'castPtr' in and out marshallers.+-- This seems like the right way to do it, but c2hs doesn't make it easy, so+-- maybe the established idiom is to do what c2hs does.++-- | Get the length of a slice.+{#fun unsafe grpc_slice_length_ as ^ {`Slice'} -> `CULong'#}++-- | Slices allocated using this function must be freed by+-- 'freeSlice'+{#fun unsafe grpc_slice_malloc_ as ^ {`Int'} -> `Slice'#}++-- | Returns a pointer to the start of the character array contained by the+-- slice.+{#fun unsafe grpc_slice_start_ as ^ {`Slice'} -> `Ptr CChar' castPtr #}++-- | Slices must be freed using 'freeSlice'.+{#fun unsafe grpc_slice_from_copied_buffer_ as ^ {`CString', `Int'} -> `Slice'#}++-- | Properly cleans up all memory used by a 'Slice'. Danger: the Slice should+-- not be used after this function is called on it.+{#fun unsafe free_slice as ^ {`Slice'} -> `()'#}++-- | Copies a 'Slice' to a ByteString.+-- TODO: there are also non-copying unsafe ByteString construction functions.+-- We could gain some speed by using them.+-- idea would be something :: (ByteString -> Response) -> IO () that handles+-- getting and freeing the slice behind the scenes.+sliceToByteString :: Slice -> IO B.ByteString+sliceToByteString slice = do+  len <- fmap fromIntegral $ grpcSliceLength slice+  str <- grpcSliceStart slice+  B.packCStringLen (str, len)++-- | Copies a 'ByteString' to a 'Slice'.+byteStringToSlice :: B.ByteString -> IO Slice+byteStringToSlice bs = B.useAsCStringLen bs $ uncurry grpcSliceFromCopiedBuffer
+ src/Network/GRPC/Unsafe/Time.chs view
@@ -0,0 +1,66 @@+module Network.GRPC.Unsafe.Time where++import Control.Exception (bracket)+import Control.Monad+import Foreign.Storable+import System.Clock++#include <grpc/support/time.h>+#include <grpc_haskell.h>++{#context prefix = "grp" #}++newtype CTimeSpec = CTimeSpec { timeSpec :: TimeSpec }+  deriving (Eq, Show)++instance Storable CTimeSpec where+  sizeOf _ = {#sizeof gpr_timespec #}+  alignment _ = {#alignof gpr_timespec #}+  peek p = fmap CTimeSpec $ TimeSpec+    <$> liftM fromIntegral ({#get gpr_timespec->tv_sec #} p)+    <*> liftM fromIntegral ({#get gpr_timespec->tv_nsec #} p)+  poke p x = do+    {#set gpr_timespec.tv_sec #} p (fromIntegral $ sec $ timeSpec x)+    {#set gpr_timespec.tv_nsec #} p (fromIntegral $ nsec $ timeSpec x)++{#enum gpr_clock_type as ClockType {underscoreToCase} deriving (Eq) #}++-- | A pointer to a CTimeSpec. Must be destroyed manually with+-- 'timespecDestroy'.+{#pointer *gpr_timespec as CTimeSpecPtr -> CTimeSpec #}++{#fun unsafe timespec_destroy as ^ {`CTimeSpecPtr'} -> `()'#}++{#fun gpr_inf_future_ as ^ {`ClockType'} -> `CTimeSpecPtr'#}++-- | Get the current time for the given 'ClockType'. Warning: 'GprTimespan' will+-- cause a crash. Probably only need to use GprClockMonotonic, which returns 0.+{#fun gpr_now_ as ^ {`ClockType'} -> `CTimeSpecPtr'#}++{#fun gpr_time_to_millis_ as ^ {`CTimeSpecPtr'} -> `Int'#}++-- | Returns a GprClockMonotonic representing a deadline n seconds in the+-- future.+{#fun seconds_to_deadline as ^ {`Int'} -> `CTimeSpecPtr'#}++withDeadlineSeconds :: Int -> (CTimeSpecPtr -> IO a) -> IO a+withDeadlineSeconds i = bracket (secondsToDeadline i) timespecDestroy++-- | Returns a GprClockMonotonic representing a deadline n milliseconds+-- in the future.+{#fun millis_to_deadline as ^ {`Int'} -> `CTimeSpecPtr'#}++-- | Returns a GprClockMonotonic representing an infinitely distant deadline.+-- wraps gpr_inf_future in the gRPC library.+{#fun unsafe infinite_deadline as ^ {} -> `CTimeSpecPtr'#}++withInfiniteDeadline :: (CTimeSpecPtr -> IO a) -> IO a+withInfiniteDeadline = bracket infiniteDeadline timespecDestroy++{#fun convert_clock_type as ^ {`CTimeSpecPtr', `ClockType'} -> `CTimeSpecPtr'#}++withConvertedClockType :: CTimeSpecPtr -> ClockType+                          -> (CTimeSpecPtr -> IO a)+                          -> IO a+withConvertedClockType cptr ctype = bracket (convertClockType cptr ctype)+                                            timespecDestroy
+ tests/LowLevelTests.hs view
@@ -0,0 +1,917 @@+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE OverloadedLists            #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE PatternSynonyms            #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TupleSections              #-}+{-# OPTIONS_GHC -fno-warn-orphans       #-}++module LowLevelTests where++import           Control.Concurrent                        (threadDelay)+import           Control.Concurrent.Async+import           Control.Monad+import           Control.Monad.Managed+import           Data.ByteString                           (ByteString,+                                                            isPrefixOf,+                                                            isSuffixOf)+import           Data.List                                 (find)+import qualified Data.Map.Strict                           as M+import qualified Data.Set                                  as S+import           GHC.Exts                                  (fromList, toList)+import           Network.GRPC.Unsafe.ChannelArgs           (Arg(..))+import           Network.GRPC.LowLevel+import qualified Network.GRPC.LowLevel.Call.Unregistered   as U+import qualified Network.GRPC.LowLevel.Client.Unregistered as U+import           Network.GRPC.LowLevel.GRPC                (threadDelaySecs)+import qualified Network.GRPC.LowLevel.Server.Unregistered as U+import qualified Pipes                                     as P+import           Test.Tasty+import           Test.Tasty.HUnit                          as HU (Assertion,+                                                                  assertBool,+                                                                  assertEqual,+                                                                  assertFailure,+                                                                  testCase,+                                                                  (@?=))++lowLevelTests :: TestTree+lowLevelTests = testGroup "Unit tests of low-level Haskell library"+  [ testGRPCBracket+  , testCompletionQueueCreateDestroy+  , testClientCreateDestroy+  , testClientCall+  , testClientTimeoutNoServer+  , testServerCreateDestroy+  , testMixRegisteredUnregistered+  , testPayload+  , testSSL+  , testAuthMetadataTransfer+  , testServerAuthProcessorCancel+  , testPayloadUnregistered+  , testServerCancel+  , testGoaway+  , testSlowServer+  , testServerCallExpirationCheck+  , testCustomUserAgent+  , testClientCompression+  , testClientServerCompression+  , testClientMaxReceiveMessageLengthChannelArg+  , testClientStreaming+  , testClientStreamingUnregistered+  , testServerStreaming+  , testServerStreamingUnregistered+  , testBiDiStreaming+  , testBiDiStreamingUnregistered+  ]++testGRPCBracket :: TestTree+testGRPCBracket =+  testCase "Start/stop GRPC" $ runManaged $ void mgdGRPC++testCompletionQueueCreateDestroy :: TestTree+testCompletionQueueCreateDestroy =+  testCase "Create/destroy CQ" $ runManaged $ do+    g <- mgdGRPC+    liftIO (withCompletionQueue g nop)++testClientCreateDestroy :: TestTree+testClientCreateDestroy =+  clientOnlyTest "start/stop" nop++testClientTimeoutNoServer :: TestTree+testClientTimeoutNoServer =+  clientOnlyTest "request timeout when server DNE" $ \c -> do+    rm <- clientRegisterMethodNormal c "/foo"+    r  <- clientRequest c rm 1 "Hello" mempty+    r @?= Left GRPCIOTimeout++testServerCreateDestroy :: TestTree+testServerCreateDestroy =+  serverOnlyTest "start/stop" (["/foo"],[],[],[]) nop++testMixRegisteredUnregistered :: TestTree+testMixRegisteredUnregistered =+  csTest "server uses unregistered calls to handle unknown endpoints"+         client+         server+         (["/foo"],[],[],[])+  where+    client c = do+      rm1 <- clientRegisterMethodNormal c "/foo"+      rm2 <- clientRegisterMethodNormal c "/bar"+      clientRequest c rm1 1 "Hello" mempty >>= do+        checkReqRslt $ \NormalRequestResult{..} -> do+          rspBody @?= "reply test"+          initMD @?= dummyMeta+          trailMD @?= dummyMeta+      clientRequest c rm2 1 "bad endpoint" mempty >>= do+        checkReqRslt $ \NormalRequestResult{..} -> do+          rspBody @?= ""+      return ()+    server s = do+       concurrently regThread unregThread+       return ()+       where regThread = do+               let rm = head (normalMethods s)+               _r <- serverHandleNormalCall s rm dummyMeta $ \c -> do+                 payload c @?= "Hello"+                 return ("reply test", dummyMeta, StatusOk, "")+               return ()+             unregThread = do+               U.serverHandleNormalCall s mempty $ \call _ -> do+                 U.callMethod call @?= "/bar"+                 return ("", mempty, StatusOk,+                         StatusDetails "Wrong endpoint")+               return ()++-- TODO: There seems to be a race here (and in other client/server pairs, of+-- course) about what gets reported when there is a failure. E.g., if one of the+-- Assertions fails in the request processing block for the server, we /may/ get+-- that error reported accurately as a call cancellation on the client, rather+-- than a useful error about the failure on the server. Maybe we'll need to+-- tweak EH behavior / async use.+testPayload :: TestTree+testPayload =+  csTest "registered normal request/response" client server (["/foo"],[],[],[])+  where+    clientMD = [ ("foo_key", "foo_val")+               , ("bar_key", "bar_val")+               , ("bar_key", "bar_repeated_val")]+    client c = do+      rm <- clientRegisterMethodNormal c "/foo"+      clientRequest c rm 10 "Hello!" clientMD >>= do+        checkReqRslt $ \NormalRequestResult{..} -> do+          rspCode @?= StatusOk+          rspBody @?= "reply test"+          details @?= "details string"+          initMD  @?= dummyMeta+          trailMD @?= dummyMeta+    server s = do+      let rm = head (normalMethods s)+      r <- serverHandleNormalCall s rm dummyMeta $ \c -> do+        payload c @?= "Hello!"+        checkMD "Server metadata mismatch" clientMD (metadata c)+        return ("reply test", dummyMeta, StatusOk, "details string")+      r @?= Right ()++testSSL :: TestTree+testSSL =+  csTest' "request/response using SSL" client server+  where+    clientConf = stdClientConf+                 {clientSSLConfig = Just (ClientSSLConfig+                                            (Just "tests/ssl/localhost.crt")+                                            Nothing+                                            Nothing)+                }+    client = TestClient clientConf $ \c -> do+      rm <- clientRegisterMethodNormal c "/foo"+      clientRequest c rm 10 "hi" mempty >>= do+        checkReqRslt $ \NormalRequestResult{..} -> do+          rspCode @?= StatusOk+          rspBody @?= "reply test"++    serverConf' = defServerConf+                  { sslConfig = Just (ServerSSLConfig+                                        Nothing+                                        "tests/ssl/localhost.key"+                                        "tests/ssl/localhost.crt"+                                        SslDontRequestClientCertificate+                                        Nothing)+                  }+    server = TestServer serverConf' $ \s -> do+      r <- U.serverHandleNormalCall s mempty $ \U.ServerCall{..} body -> do+        body @?= "hi"+        return ("reply test", mempty, StatusOk, "")+      r @?= Right ()++-- NOTE: With auth plugin tests, if an auth plugin decides someone isn't+-- authenticated, then the call never happens from the perspective of+-- the server, so the server will continue to block waiting for a call. So, if+-- these tests hang forever, it's because auth failed and the server is still+-- waiting for a successfully authenticated call to come in.++testServerAuthProcessorCancel :: TestTree+testServerAuthProcessorCancel =+  csTest' "request rejection by auth processor" client server+  where+    clientConf = stdClientConf+                 {clientSSLConfig = Just (ClientSSLConfig+                                            (Just "tests/ssl/localhost.crt")+                                            Nothing+                                            Nothing)+                }+    client = TestClient clientConf $ \c -> do+      rm <- clientRegisterMethodNormal c "/foo"+      r <- clientRequest c rm 10 "hi" mempty+      -- TODO: using checkReqRslt on this first result causes the test to hang!+      r @?= Left (GRPCIOBadStatusCode StatusUnauthenticated "denied!")+      clientRequest c rm 10 "hi" [("foo","bar")] >>= do+        checkReqRslt $ \NormalRequestResult{..} -> do+          rspCode @?= StatusOk+          rspBody @?= "reply test"++    serverProcessor = Just $ \_ m -> do+      let (status, details) = if M.member "foo" (unMap m)+                                 then (StatusOk, "")+                                 else (StatusUnauthenticated, "denied!")+      return $ AuthProcessorResult mempty mempty status details++    serverConf' = defServerConf+                  { sslConfig = Just (ServerSSLConfig+                                        Nothing+                                        "tests/ssl/localhost.key"+                                        "tests/ssl/localhost.crt"+                                        SslDontRequestClientCertificate+                                        serverProcessor)+                  }+    server = TestServer serverConf' $ \s -> do+      r <- U.serverHandleNormalCall s mempty $ \U.ServerCall{..} _body -> do+        checkMD "Handler only sees requests with good metadata"+                [("foo","bar")]+                metadata+        return ("reply test", mempty, StatusOk, "")+      r @?= Right ()++testAuthMetadataTransfer :: TestTree+testAuthMetadataTransfer =+  csTest' "Auth metadata changes sent from client to server" client server+  where+    plugin :: ClientMetadataCreate+    plugin authMetaCtx = do+      let authCtx = (channelAuthContext authMetaCtx)++      addAuthProperty authCtx (AuthProperty "foo1" "bar1")+      newProps <- getAuthProperties authCtx+      let addedProp = find ((== "foo1") . authPropName) newProps+      addedProp @?= Just (AuthProperty "foo1" "bar1")+      return $ ClientMetadataCreateResult [("foo","bar")] StatusOk ""+    clientConf = stdClientConf+                 {clientSSLConfig = Just (ClientSSLConfig+                                            (Just "tests/ssl/localhost.crt")+                                            Nothing+                                            (Just plugin))+                }+    client = TestClient clientConf $ \c -> do+      rm <- clientRegisterMethodNormal c "/foo"+      clientRequest c rm 10 "hi" mempty >>= do+        checkReqRslt $ \NormalRequestResult{..} -> do+          rspCode @?= StatusOk+          rspBody @?= "reply test"++    serverProcessor :: Maybe ProcessMeta+    serverProcessor = Just $ \authCtx m -> do+      let expected = fromList [("foo","bar")]++      props <- getAuthProperties authCtx+      let clientProp = find ((== "foo1") . authPropName) props+      assertBool "server plugin doesn't see auth properties set by client"+                 (clientProp == Nothing)+      checkMD "server plugin sees metadata added by client plugin" expected m+      return $ AuthProcessorResult mempty mempty StatusOk ""++    serverConf' = defServerConf+                  { sslConfig = Just (ServerSSLConfig+                                        Nothing+                                        "tests/ssl/localhost.key"+                                        "tests/ssl/localhost.crt"+                                        SslDontRequestClientCertificate+                                        serverProcessor)+                  }+    server = TestServer serverConf' $ \s -> do+      r <- U.serverHandleNormalCall s mempty $ \U.ServerCall{..} body -> do+        body @?= "hi"+        return ("reply test", mempty, StatusOk, "")+      r @?= Right ()++-- TODO: auth metadata doesn't propagate from parent calls to child calls.+-- Once we implement our own system for doing so, update this test and add it+-- to the tests list.+testAuthMetadataPropagate :: TestTree+testAuthMetadataPropagate = testCase "auth metadata inherited by children" $ do+  c <- async client+  s1 <- async server+  s2 <- async server2+  wait c+  wait s1+  wait s2+  return ()+  where+    clientPlugin _ =+      return $ ClientMetadataCreateResult [("foo","bar")] StatusOk ""+    clientConf = stdClientConf+                 {clientSSLConfig = Just (ClientSSLConfig+                                            (Just "tests/ssl/localhost.crt")+                                            Nothing+                                            (Just clientPlugin))+                }+    client = do+      threadDelaySecs 3+      withGRPC $ \g -> withClient g clientConf $ \c -> do+        rm <- clientRegisterMethodNormal c "/foo"+        clientRequest c rm 10 "hi" mempty >>= do+          checkReqRslt $ \NormalRequestResult{..} -> do+            rspCode @?= StatusOk+            rspBody @?= "reply test"++    server1ServerPlugin _ctx md = do+      checkMD "server1 sees client's auth metadata." [("foo","bar")] md+      -- TODO: add response meta to check, and consume meta to see what happens.+      return $ AuthProcessorResult mempty mempty StatusOk ""++    server1ServerConf = defServerConf+                 {sslConfig = Just (ServerSSLConfig+                                      Nothing+                                      "tests/ssl/localhost.key"+                                      "tests/ssl/localhost.crt"+                                      SslDontRequestClientCertificate+                                      (Just server1ServerPlugin)),+                  methodsToRegisterNormal = ["/foo"]+                }++    server1ClientPlugin _ =+      return $ ClientMetadataCreateResult [("foo1","bar1")] StatusOk ""++    server1ClientConf = stdClientConf+                 {clientSSLConfig = Just (ClientSSLConfig+                                            (Just "tests/ssl/localhost.crt")+                                            Nothing+                                            (Just server1ClientPlugin)),+                  clientServerPort = 50052+                }++    server = do+      threadDelaySecs 2+      withGRPC $ \g -> withServer g server1ServerConf $ \s ->+        withClient g server1ClientConf $ \c -> do+          let rm = head (normalMethods s)+          serverHandleNormalCall s rm mempty $ \call -> do+            rmc <- clientRegisterMethodNormal c "/foo"+            res <- clientRequestParent c (Just call) rmc 10 "hi" mempty+            case res of+              Left _ ->+                error "got bad result from server2"+              Right (NormalRequestResult{..}) ->+                return (rspBody, mempty, StatusOk, "")++    server2ServerPlugin _ctx md = do+      print md+      checkMD "server2 sees server1's auth metadata." [("foo1","bar1")] md+      --TODO: this assert fails+      checkMD "server2 sees client's auth metadata." [("foo","bar")] md+      return $ AuthProcessorResult mempty mempty StatusOk ""++    server2ServerConf = defServerConf+                 {sslConfig = Just (ServerSSLConfig+                                      Nothing+                                      "tests/ssl/localhost.key"+                                      "tests/ssl/localhost.crt"+                                      SslDontRequestClientCertificate+                                      (Just server2ServerPlugin)),+                  methodsToRegisterNormal = ["/foo"],+                  port = 50052+                }++    server2 = withGRPC $ \g -> withServer g server2ServerConf $ \s -> do+        let rm = head (normalMethods s)+        serverHandleNormalCall s rm mempty $ \_call -> do+          return ("server2 reply", mempty, StatusOk, "")++testServerCancel :: TestTree+testServerCancel =+  csTest "server cancel call" client server (["/foo"],[],[],[])+  where+    client c = do+      rm <- clientRegisterMethodNormal c "/foo"+      Left (GRPCIOBadStatusCode s _) <- clientRequest c rm 10 "" mempty+      s @?= StatusCancelled+    server s = do+      let rm = head (normalMethods s)+      r <- serverHandleNormalCall s rm mempty $ \c -> do+        serverCallCancel c StatusCancelled ""+        return (mempty, mempty, StatusCancelled, "")+      r @?= Right ()++testServerStreaming :: TestTree+testServerStreaming =+  csTest "server streaming" client server ([],[],["/feed"],[])+  where+    clientInitMD = [("client","initmd")]+    serverInitMD = [("server","initmd")]+    clientPay    = "FEED ME!"+    pays         = ["ONE", "TWO", "THREE", "FOUR"] :: [ByteString]++    client c = do+      rm <- clientRegisterMethodServerStreaming c "/feed"+      eea <- clientReader c rm 10 clientPay clientInitMD $ \_cc initMD recv -> do+        checkMD "Server initial metadata mismatch" serverInitMD initMD+        forM_ pays $ \p -> recv `is` Right (Just p)+        recv `is` Right Nothing+      eea @?= Right (dummyMeta, StatusOk, "dtls")++    server s = do+      let rm = head (sstreamingMethods s)+      r <- serverWriter s rm serverInitMD $ \sc send -> do+        checkMD "Server request metadata mismatch" clientInitMD (metadata sc)+        payload sc @?= clientPay+        forM_ pays $ \p -> send p `is` Right ()+        return (dummyMeta, StatusOk, "dtls")+      r @?= Right ()++-- TODO: these unregistered streaming tests are basically the same as the+-- registered ones. Reduce duplication.+-- TODO: Once client-side unregistered streaming functions are added, switch+-- to using them in these tests.+testServerStreamingUnregistered :: TestTree+testServerStreamingUnregistered =+  csTest "unregistered server streaming" client server ([],[],[],[])+  where+    clientInitMD = [("client","initmd")]+    serverInitMD = [("server","initmd")]+    clientPay    = "FEED ME!"+    pays         = ["ONE", "TWO", "THREE", "FOUR"] :: [ByteString]++    client c = do+      rm <- clientRegisterMethodServerStreaming c "/feed"+      eea <- clientReader c rm 10 clientPay clientInitMD $ \_cc initMD recv -> do+        checkMD "Server initial metadata mismatch" serverInitMD initMD+        forM_ pays $ \p -> recv `is` Right (Just p)+        recv `is` Right Nothing+      eea @?= Right (dummyMeta, StatusOk, "dtls")++    server s = U.withServerCallAsync s $ \call -> do+      r <- U.serverWriter s call serverInitMD $ \sc send -> do+        checkMD "Server request metadata mismatch" clientInitMD (metadata sc)+        payload sc @?= clientPay+        forM_ pays $ \p -> send p `is` Right ()+        return (dummyMeta, StatusOk, "dtls")+      r @?= Right ()++testClientStreaming :: TestTree+testClientStreaming =+  csTest "client streaming" client server ([],["/slurp"],[],[])+  where+    clientInitMD = [("a","b")]+    serverInitMD = [("x","y")]+    trailMD      = dummyMeta+    serverRsp    = "serverReader reply"+    serverDtls   = "deets"+    serverStatus = StatusOk+    pays         = ["P_ONE", "P_TWO", "P_THREE"] :: [ByteString]++    client c = do+      rm  <- clientRegisterMethodClientStreaming c "/slurp"+      eea <- clientWriter c rm 10 clientInitMD $ \send -> do+        -- liftIO $ checkMD "Server initial metadata mismatch" serverInitMD initMD+        forM_ pays $ \p -> send p `is` Right ()+      eea @?= Right (Just serverRsp, serverInitMD, trailMD, serverStatus, serverDtls)++    server s = do+      let rm = head (cstreamingMethods s)+      eea <- serverReader s rm serverInitMD $ \sc recv -> do+        checkMD "Client request metadata mismatch" clientInitMD (metadata sc)+        forM_ pays $ \p -> recv `is` Right (Just p)+        recv `is` Right Nothing+        return (Just serverRsp, trailMD, serverStatus, serverDtls)+      eea @?= Right ()++testClientStreamingUnregistered :: TestTree+testClientStreamingUnregistered =+  csTest "unregistered client streaming" client server ([],[],[],[])+  where+    clientInitMD = [("a","b")]+    serverInitMD = [("x","y")]+    trailMD      = dummyMeta+    serverRsp    = "serverReader reply"+    serverDtls   = "deets"+    serverStatus = StatusOk+    pays         = ["P_ONE", "P_TWO", "P_THREE"] :: [ByteString]++    client c = do+      rm  <- clientRegisterMethodClientStreaming c "/slurp"+      eea <- clientWriter c rm 10 clientInitMD $ \send -> do+        -- liftIO $ checkMD "Server initial metadata mismatch" serverInitMD initMD+        forM_ pays $ \p -> send p `is` Right ()+      eea @?= Right (Just serverRsp, serverInitMD, trailMD, serverStatus, serverDtls)++    server s = U.withServerCallAsync s $ \call -> do+      eea <- U.serverReader s call serverInitMD $ \sc recv -> do+        checkMD "Client request metadata mismatch" clientInitMD (metadata sc)+        forM_ pays $ \p -> recv `is` Right (Just p)+        recv `is` Right Nothing+        return (Just serverRsp, trailMD, serverStatus, serverDtls)+      eea @?= Right ()++testBiDiStreaming :: TestTree+testBiDiStreaming =+  csTest "bidirectional streaming" client server ([],[],[],["/bidi"])+  where+    clientInitMD = [("bidi-streaming","client")]+    serverInitMD = [("bidi-streaming","server")]+    trailMD      = dummyMeta+    serverStatus = StatusOk+    serverDtls   = "deets"++    client c = do+      rm  <- clientRegisterMethodBiDiStreaming c "/bidi"+      eea <- clientRW c rm 10 clientInitMD $ \_cc getMD recv send writesDone -> do+        either clientFail (checkMD "Server rsp metadata mismatch" serverInitMD) =<< getMD+        send "cw0" `is` Right ()+        recv       `is` Right (Just "sw0")+        send "cw1" `is` Right ()+        recv       `is` Right (Just "sw1")+        recv       `is` Right (Just "sw2")+        writesDone `is` Right ()+        recv       `is` Right Nothing+      eea @?= Right (trailMD, serverStatus, serverDtls)++    server s = do+      let rm = head (bidiStreamingMethods s)+      eea <- serverRW s rm serverInitMD $ \sc recv send -> do+        checkMD "Client request metadata mismatch" clientInitMD (metadata sc)+        recv       `is` Right (Just "cw0")+        send "sw0" `is` Right ()+        recv       `is` Right (Just "cw1")+        send "sw1" `is` Right ()+        send "sw2" `is` Right ()+        recv       `is` Right Nothing+        return (trailMD, serverStatus, serverDtls)+      eea @?= Right ()++testBiDiStreamingUnregistered :: TestTree+testBiDiStreamingUnregistered =+  csTest "unregistered bidirectional streaming" client server ([],[],[],[])+  where+    clientInitMD = [("bidi-streaming","client")]+    serverInitMD = [("bidi-streaming","server")]+    trailMD      = dummyMeta+    serverStatus = StatusOk+    serverDtls   = "deets"++    client c = do+      rm  <- clientRegisterMethodBiDiStreaming c "/bidi"+      eea <- clientRW c rm 10 clientInitMD $ \_cc getMD recv send writesDone -> do+        either clientFail (checkMD "Server rsp metadata mismatch" serverInitMD) =<< getMD+        send "cw0" `is` Right ()+        recv       `is` Right (Just "sw0")+        send "cw1" `is` Right ()+        recv       `is` Right (Just "sw1")+        recv       `is` Right (Just "sw2")+        writesDone `is` Right ()+        recv       `is` Right Nothing+      eea @?= Right (trailMD, serverStatus, serverDtls)++    server s = U.withServerCallAsync s $ \call -> do+      eea <- U.serverRW s call serverInitMD $ \sc recv send -> do+        checkMD "Client request metadata mismatch" clientInitMD (metadata sc)+        recv       `is` Right (Just "cw0")+        send "sw0" `is` Right ()+        recv       `is` Right (Just "cw1")+        send "sw1" `is` Right ()+        send "sw2" `is` Right ()+        recv       `is` Right Nothing+        return (trailMD, serverStatus, serverDtls)+      eea @?= Right ()++--------------------------------------------------------------------------------+-- Unregistered tests++testClientCall :: TestTree+testClientCall =+  clientOnlyTest "create/destroy call" $ \c -> do+    r <- U.withClientCall c "/foo" 10 $ const $ return $ Right ()+    r @?= Right ()++testServerCall :: TestTree+testServerCall =+  serverOnlyTest "create/destroy call" ([],[],[],[]) $ \s -> do+    r <- U.withServerCall s $ const $ return $ Right ()+    r @?= Left GRPCIOTimeout++testPayloadUnregistered :: TestTree+testPayloadUnregistered =+  csTest "unregistered normal request/response" client server ([],[],[],[])+  where+    client c =+      U.clientRequest c "/foo" 10 "Hello!" mempty >>= do+        checkReqRslt $ \NormalRequestResult{..} -> do+          rspCode @?= StatusOk+          rspBody @?= "reply test"+          details @?= "details string"+    server s = do+      r <- U.serverHandleNormalCall s mempty $ \U.ServerCall{..} body -> do+             body @?= "Hello!"+             callMethod @?= "/foo"+             return ("reply test", mempty, StatusOk, "details string")+      r @?= Right ()++testGoaway :: TestTree+testGoaway =+  csTest "Client handles server shutdown gracefully"+         client+         server+         (["/foo"],[],[],[])+  where+    client c = do+      rm <- clientRegisterMethodNormal c "/foo"+      clientRequest c rm 10 "" mempty+      clientRequest c rm 10 "" mempty+      eer <- clientRequest c rm 1 "" mempty+      assertBool "Client handles server shutdown gracefully" $ case eer of+        Left (GRPCIOBadStatusCode StatusUnavailable _)                        -> True+        Left (GRPCIOBadStatusCode StatusDeadlineExceeded "Deadline Exceeded") -> True+        Left GRPCIOTimeout                                                    -> True+        _                                                                     -> False++    server s = do+      let rm = head (normalMethods s)+      serverHandleNormalCall s rm mempty dummyHandler+      serverHandleNormalCall s rm mempty dummyHandler+      return ()++testSlowServer :: TestTree+testSlowServer =+  csTest "Client handles slow server response" client server (["/foo"],[],[],[])+  where+    client c = do+      rm <- clientRegisterMethodNormal c "/foo"+      result <- clientRequest c rm 1 "" mempty+      result @?= Left (GRPCIOBadStatusCode StatusDeadlineExceeded "Deadline Exceeded")+    server s = do+      let rm = head (normalMethods s)+      serverHandleNormalCall s rm mempty $ \_ -> do+        threadDelay (2*10^(6 :: Int))+        return dummyResp+      return ()++testServerCallExpirationCheck :: TestTree+testServerCallExpirationCheck =+  csTest "Check for call expiration" client server (["/foo"],[],[],[])+  where+    client c = do+      rm <- clientRegisterMethodNormal c "/foo"+      void $ clientRequest c rm 3 "" mempty+    server s = do+      let rm = head (normalMethods s)+      serverHandleNormalCall s rm mempty $ \c -> do+        exp1 <- serverCallIsExpired c+        assertBool "Call isn't expired when handler starts" $ not exp1+        threadDelaySecs 1+        exp2 <- serverCallIsExpired c+        assertBool "Call isn't expired after 1 second" $ not exp2+        threadDelaySecs 3+        exp3 <- serverCallIsExpired c+        assertBool "Call is expired after 4 seconds" exp3+        return dummyResp+      return ()++testCustomUserAgent :: TestTree+testCustomUserAgent =+  csTest' "Server sees custom user agent prefix/suffix" client server+  where+    clientArgs = [UserAgentPrefix "prefix!", UserAgentSuffix "suffix!"]+    client =+      TestClient (ClientConfig "localhost" 50051 clientArgs Nothing Nothing) $+        \c -> do rm <- clientRegisterMethodNormal c "/foo"+                 void $ clientRequest c rm 4 "" mempty+    server = TestServer (serverConf (["/foo"],[],[],[])) $ \s -> do+      let rm = head (normalMethods s)+      serverHandleNormalCall s rm mempty $ \c -> do+        ua <- case toList $ (unMap $ metadata c) M.! "user-agent" of+                []   -> fail "user-agent missing from metadata."+                [ua] -> return ua+                _    -> fail "multiple user-agent keys."+        assertBool "User agent prefix is present" $ isPrefixOf "prefix!" ua+        assertBool "User agent suffix is present" $ isSuffixOf "suffix!" ua+        return dummyResp+      return ()++testClientCompression :: TestTree+testClientCompression =+  csTest' "client-only compression: no errors" client server+  where+    client =+      TestClient (ClientConfig+                   "localhost"+                   50051+                   [CompressionAlgArg GrpcCompressDeflate]+                   Nothing+                   Nothing) $ \c -> do+        rm <- clientRegisterMethodNormal c "/foo"+        void $ clientRequest c rm 1 "hello" mempty+    server = TestServer (serverConf (["/foo"],[],[],[])) $ \s -> do+      let rm = head (normalMethods s)+      serverHandleNormalCall s rm mempty $ \c -> do+        payload c @?= "hello"+        return dummyResp+      return ()++testClientServerCompression :: TestTree+testClientServerCompression =+  csTest' "client/server compression: no errors" client server+  where+    cconf = ClientConfig "localhost"+                         50051+                         [CompressionAlgArg GrpcCompressDeflate]+                         Nothing+                         Nothing+    client = TestClient cconf $ \c -> do+      rm <- clientRegisterMethodNormal c "/foo"+      clientRequest c rm 1 "hello" mempty >>= do+        checkReqRslt $ \NormalRequestResult{..} -> do+          rspCode @?= StatusOk+          rspBody @?= "hello"+          details @?= ""+          initMD  @?= dummyMeta+          trailMD @?= dummyMeta+      return ()+    sconf = ServerConfig "localhost"+                         50051+                         ["/foo"] [] [] []+                         [CompressionAlgArg GrpcCompressDeflate]+                         Nothing+    server = TestServer sconf $ \s -> do+      let rm = head (normalMethods s)+      serverHandleNormalCall s rm dummyMeta $ \sc -> do+        payload sc @?= "hello"+        return ("hello", dummyMeta, StatusOk, StatusDetails "")+      return ()++testClientServerCompressionLvl :: TestTree+testClientServerCompressionLvl =+  csTest' "client/server compression: no errors" client server+  where+    cconf = ClientConfig "localhost"+                         50051+                         [CompressionLevelArg GrpcCompressLevelHigh]+                         Nothing+                         Nothing+    client = TestClient cconf $ \c -> do+      rm <- clientRegisterMethodNormal c "/foo"+      clientRequest c rm 1 "hello" mempty >>= do+        checkReqRslt $ \NormalRequestResult{..} -> do+          rspCode @?= StatusOk+          rspBody @?= "hello"+          details @?= ""+          initMD  @?= dummyMeta+          trailMD @?= dummyMeta+      return ()+    sconf = ServerConfig "localhost"+                         50051+                         ["/foo"] [] [] []+                         [CompressionLevelArg GrpcCompressLevelLow]+                         Nothing+    server = TestServer sconf $ \s -> do+      let rm = head (normalMethods s)+      serverHandleNormalCall s rm dummyMeta $ \sc -> do+        payload sc @?= "hello"+        return ("hello", dummyMeta, StatusOk, StatusDetails "")+      return ()++testClientMaxReceiveMessageLengthChannelArg :: TestTree+testClientMaxReceiveMessageLengthChannelArg = do+  testGroup "max receive message length channel arg (client channel)"+    [ csTest' "payload size < small bound succeeds" shouldSucceed server+    , csTest' "payload size > small bound fails"    shouldFail    server+    ]+  where+    -- The server always sends a 4-byte payload+    pay    = "four"+    server = TestServer (ServerConfig "localhost" 50051 ["/foo"] [] [] [] [] Nothing) $ \s -> do+      let rm = head (normalMethods s)+      void $ serverHandleNormalCall s rm mempty $ \sc -> do+        payload sc @?= pay+        pure (pay, mempty, StatusOk, StatusDetails "")++    clientMax n k = TestClient conf $ \c -> do+      rm <- clientRegisterMethodNormal c "/foo"+      clientRequest c rm 1 pay mempty >>= k+      where+        conf = ClientConfig "localhost" 50051 [MaxReceiveMessageLength n] Nothing Nothing++    -- Expect success when the max recv payload size is set to 4 bytes, and we+    -- are sent 4.+    shouldSucceed = clientMax 4 $ checkReqRslt $ \NormalRequestResult{..} -> do+      rspCode @?= StatusOk+      rspBody @?= pay+      details @?= ""++    -- Expect failure when the max recv payload size is set to 3 bytes, and we+    -- are sent 4.+    shouldFail = clientMax 3 $ \case+        Left (GRPCIOBadStatusCode StatusResourceExhausted _)+          -> pure ()+        rsp+          -> clientFail ("Expected failure response, but got: " ++ show rsp)++--------------------------------------------------------------------------------+-- Utilities and helpers++is :: (Eq a, Show a, MonadIO m) => m a -> a -> m ()+is act x = act >>= liftIO . (@?= x)++dummyMeta :: MetadataMap+dummyMeta = [("foo","bar")]++dummyResp :: (ByteString, MetadataMap, StatusCode, StatusDetails)+dummyResp = ("", mempty, StatusOk, StatusDetails "")++dummyHandler :: ServerCall a+                -> IO (ByteString, MetadataMap, StatusCode, StatusDetails)+dummyHandler _ = return dummyResp++dummyResult' :: StatusDetails+             -> IO (ByteString, MetadataMap, StatusCode, StatusDetails)+dummyResult' = return . (mempty, mempty, StatusOk, )++nop :: Monad m => a -> m ()+nop = const (return ())++serverOnlyTest :: TestName+               -> ([MethodName],[MethodName],[MethodName],[MethodName])+               -> (Server -> IO ())+               -> TestTree+serverOnlyTest nm ms =+  testCase ("Server - " ++ nm) . runTestServer . TestServer (serverConf ms)++clientOnlyTest :: TestName -> (Client -> IO ()) -> TestTree+clientOnlyTest nm =+  testCase ("Client - " ++ nm) . runTestClient . stdTestClient++csTest :: TestName+       -> (Client -> IO ())+       -> (Server -> IO ())+       -> ([MethodName],[MethodName],[MethodName],[MethodName])+       -> TestTree+csTest nm c s ms =+  csTest' nm (stdTestClient c) (TestServer (serverConf ms) s)++csTest' :: TestName -> TestClient -> TestServer -> TestTree+csTest' nm tc ts =+  testCase ("Client/Server - " ++ nm)+  $ void (s `concurrently` c)+  where+    -- We use a small delay to give the server a head start+    c = threadDelay 100000 >> runTestClient tc+    s = runTestServer ts++-- | @checkMD msg expected actual@ fails when keys from @expected@ are not in+-- @actual@, or when values differ for matching keys.+checkMD :: String -> MetadataMap -> MetadataMap -> Assertion+checkMD desc expected actual =+    assertEqual desc expected' (actual' `S.intersection` expected')+  where+    expected' = fromList . toList $ expected+    actual' = fromList . toList $ actual++checkReqRslt :: Show a => (b -> Assertion) -> Either a b -> Assertion+checkReqRslt = either clientFail++-- | The consumer which asserts that the next value it consumes is equal to the+-- given value; string parameter used as in 'assertEqual'.+assertConsumeEq :: (Eq a, Show a) => String -> a -> P.Consumer a IO ()+assertConsumeEq s v = P.lift . assertEqual s v =<< P.await++clientFail :: Show a => a -> Assertion+clientFail = assertFailure . ("Client error: " ++). show++data TestClient = TestClient ClientConfig (Client -> IO ())++runTestClient :: TestClient -> IO ()+runTestClient (TestClient conf f) =+  runManaged $ mgdGRPC >>= mgdClient conf >>= liftIO . f++stdTestClient :: (Client -> IO ()) -> TestClient+stdTestClient = TestClient stdClientConf++stdClientConf :: ClientConfig+stdClientConf = ClientConfig "localhost" 50051 [] Nothing Nothing++data TestServer = TestServer ServerConfig (Server -> IO ())++runTestServer :: TestServer -> IO ()+runTestServer (TestServer conf f) =+  runManaged $ mgdGRPC >>= mgdServer conf >>= liftIO . f++defServerConf :: ServerConfig+defServerConf = ServerConfig "localhost" 50051 [] [] [] [] [] Nothing++serverConf :: ([MethodName],[MethodName],[MethodName],[MethodName])+              -> ServerConfig+serverConf (ns, cs, ss, bs) =+  defServerConf {methodsToRegisterNormal = ns,+                 methodsToRegisterClientStreaming = cs,+                 methodsToRegisterServerStreaming = ss,+                 methodsToRegisterBiDiStreaming = bs}++mgdGRPC :: Managed GRPC+mgdGRPC = managed withGRPC++mgdClient :: ClientConfig -> GRPC -> Managed Client+mgdClient conf g = managed $ withClient g conf++mgdServer :: ServerConfig -> GRPC -> Managed Server+mgdServer conf g = managed $ withServer g conf
+ tests/LowLevelTests/Op.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}++module LowLevelTests.Op where++import           Data.ByteString                (ByteString)+import           Test.Tasty+import           Test.Tasty.HUnit               as HU (testCase, (@?=))++import           Network.GRPC.LowLevel+import           Network.GRPC.LowLevel.Call+import           Network.GRPC.LowLevel.Client+import           Network.GRPC.LowLevel.Server+import           Network.GRPC.LowLevel.Op++lowLevelOpTests :: TestTree+lowLevelOpTests = testGroup "Synchronous unit tests of low-level Op interface"+  [testCancelFromServer]++testCancelFromServer :: TestTree+testCancelFromServer =+  testCase "Client/Server - client receives server cancellation" $+  runSerialTest $ \grpc ->+    withClientServerUnaryCall grpc $+    \(Client{..}, Server{..}, ClientCall{..}, sc@ServerCall{..}) -> do+      serverCallCancel sc StatusPermissionDenied "TestStatus"+      clientRes <- runOps unsafeCC clientCQ clientRecvOps+      case clientRes of+        Left x -> error $ "Client recv error: " ++ show x+        Right [_,_,OpRecvStatusOnClientResult _ code _details] -> do+          code @?= StatusPermissionDenied+          return $ Right ()+        wrong -> error $ "Unexpected op results: " ++ show wrong+++runSerialTest :: (GRPC -> IO (Either GRPCIOError ())) -> IO ()+runSerialTest f =+  withGRPC f >>= \case Left x -> error $ show x+                       Right () -> return ()++withClientServerUnaryCall :: GRPC+                             -> ((Client, Server, ClientCall,+                                  ServerCall ByteString)+                                 -> IO (Either GRPCIOError a))+                             -> IO (Either GRPCIOError a)+withClientServerUnaryCall grpc f = do+  withClient grpc clientConf $ \c -> do+    crm <- clientRegisterMethodNormal c "/foo"+    withServer grpc serverConf $ \s ->+      withClientCall c crm 10 $ \cc -> do+        let srm = head (normalMethods s)+        -- NOTE: We need to send client ops here or else `withServerCall` hangs,+        -- because registered methods try to do recv ops immediately when+        -- created. If later we want to send payloads or metadata, we'll need+        -- to tweak this.+        _clientRes <- runOps (unsafeCC cc) (clientCQ c) clientEmptySendOps+        withServerCall s srm $ \sc ->+          f (c, s, cc, sc)++serverConf :: ServerConfig+serverConf = ServerConfig "localhost" 50051 [("/foo")] [] [] [] [] Nothing++clientConf :: ClientConfig+clientConf = ClientConfig "localhost" 50051 [] Nothing Nothing++clientEmptySendOps :: [Op]+clientEmptySendOps = [OpSendInitialMetadata mempty,+                      OpSendMessage "",+                      OpSendCloseFromClient]++clientRecvOps :: [Op]+clientRecvOps = [OpRecvInitialMetadata,+                 OpRecvMessage,+                 OpRecvStatusOnClient]++serverEmptyRecvOps :: [Op]+serverEmptyRecvOps = [OpSendInitialMetadata mempty,+                      OpRecvMessage,+                      OpRecvCloseOnServer]
+ tests/Properties.hs view
@@ -0,0 +1,12 @@+import           LowLevelTests+import           LowLevelTests.Op+import           Test.Tasty+import           UnsafeTests++main :: IO ()+main = defaultMain $ testGroup "GRPC Unit Tests"+  [ unsafeTests+  , unsafeProperties+  , lowLevelOpTests+  , lowLevelTests+  ]
+ tests/UnsafeTests.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module UnsafeTests (unsafeTests, unsafeProperties) where++import           Control.Exception               (bracket_)+import           Control.Monad+import qualified Data.ByteString                 as B+import           Foreign.Marshal.Alloc+import           Foreign.Storable+import           GHC.Exts+import           Network.GRPC.LowLevel.GRPC      (threadDelaySecs)+import           Network.GRPC.Unsafe+import           Network.GRPC.Unsafe.ByteBuffer+import           Network.GRPC.Unsafe.ChannelArgs+import           Network.GRPC.Unsafe.Metadata+import           Network.GRPC.Unsafe.Security+import           Network.GRPC.Unsafe.Slice+import           Network.GRPC.Unsafe.Time+import           System.Clock+import           Test.QuickCheck.Gen+import qualified Test.QuickCheck.Property        as QC+import           Test.Tasty+import           Test.Tasty.HUnit                as HU (testCase, (@?=))+import           Test.Tasty.QuickCheck           as QC++unsafeTests :: TestTree+unsafeTests = testGroup "Unit tests for unsafe C bindings"+  [ roundtripSliceUnit "\NULabc\NUL"+  , roundtripSliceUnit largeByteString+  , roundtripByteBufferUnit largeByteString+  , roundtripTimeSpec (TimeSpec 123 123)+  , testMetadata+  , testNow+  , testCreateDestroyMetadata+  , testCreateDestroyMetadataKeyVals+  , testCreateDestroyDeadline+  , testCreateDestroyChannelArgs+  , testCreateDestroyClientCreds+  , testCreateDestroyServerCreds+  ]++unsafeProperties :: TestTree+unsafeProperties = testGroup "QuickCheck properties for unsafe C bindings"+  [ roundtripSliceQC+  , roundtripByteBufferQC+  , roundtripMetadataQC+  , metadataIsList+  ]++instance Arbitrary B.ByteString where+  arbitrary = B.pack <$> arbitrary++instance Arbitrary MetadataMap where+  arbitrary = do+    --keys are not allowed to contain \NUL, but values are.+    ks <- arbitrary `suchThat` all (B.notElem 0)+    let l = length ks+    vs <- vector l+    return $ fromList (zip ks vs)++roundtripMetadataKeyVals :: MetadataMap -> IO MetadataMap+roundtripMetadataKeyVals m = do+  (kvPtr, l) <- createMetadata m+  m' <- getAllMetadata kvPtr l+  metadataFree kvPtr+  return m'++roundtripMetadataQC :: TestTree+roundtripMetadataQC = QC.testProperty "Metadata roundtrip" $+                      \m -> QC.ioProperty $ do m' <- roundtripMetadataKeyVals m+                                               return $ m === m'++metadataIsList :: TestTree+metadataIsList = QC.testProperty "Metadata IsList instance" $+                   \(md :: MetadataMap) -> md == (fromList $ toList md)++largeByteString :: B.ByteString+largeByteString = B.pack $ take (32*1024*1024) $ cycle [97..99]++roundtripSlice :: B.ByteString -> IO B.ByteString+roundtripSlice bs = do+  slice <- byteStringToSlice bs+  unslice <- sliceToByteString slice+  freeSlice slice+  return unslice++roundtripSliceQC :: TestTree+roundtripSliceQC = QC.testProperty "Slice roundtrip: QuickCheck" $+                   \bs -> QC.ioProperty $ do bs' <- roundtripSlice bs+                                             return $ bs == bs'++roundtripSliceUnit :: B.ByteString -> TestTree+roundtripSliceUnit bs = testCase "ByteString slice roundtrip" $ do+  unslice <- roundtripSlice bs+  unslice HU.@?= bs++roundtripByteBuffer :: B.ByteString -> IO B.ByteString+roundtripByteBuffer bs = do+  slice <- byteStringToSlice bs+  buffer <- grpcRawByteBufferCreate slice 1+  reader <- byteBufferReaderCreate buffer+  readSlice <- grpcByteBufferReaderReadall reader+  bs' <- sliceToByteString readSlice+  freeSlice slice+  byteBufferReaderDestroy reader+  grpcByteBufferDestroy buffer+  freeSlice readSlice+  return bs'++roundtripByteBufferQC :: TestTree+roundtripByteBufferQC = QC.testProperty "ByteBuffer roundtrip: QuickCheck" $+                        \bs -> QC.ioProperty $ do bs' <- roundtripByteBuffer bs+                                                  return $ bs == bs'++roundtripByteBufferUnit :: B.ByteString -> TestTree+roundtripByteBufferUnit bs = testCase "ByteBuffer roundtrip" $ do+  bs' <- roundtripByteBuffer bs+  bs' HU.@?= bs++roundtripTimeSpec :: TimeSpec -> TestTree+roundtripTimeSpec t = testCase "CTimeSpec roundtrip" $ do+  p <- malloc+  let c = CTimeSpec t+  poke p c+  c' <- peek p+  c' @?= c+  free p++testMetadata :: TestTree+testMetadata = testCase "Metadata setter/getter roundtrip" $ do+  m <- metadataAlloc 3+  setMetadataKeyVal "hello" "world" m 0+  setMetadataKeyVal "foo" "bar" m 1+  setMetadataKeyVal "Haskell" "Curry" m 2+  k0 <- getMetadataKey m 0+  v0 <- getMetadataVal m 0+  k1 <- getMetadataKey m 1+  v1 <- getMetadataVal m 1+  k2 <- getMetadataKey m 2+  v2 <- getMetadataVal m 2+  k0 HU.@?= "hello"+  v0 HU.@?= "world"+  k1 HU.@?= "foo"+  v1 HU.@?= "bar"+  k2 HU.@?= "Haskell"+  v2 HU.@?= "Curry"+  metadataFree m++currTimeMillis :: ClockType -> IO Int+currTimeMillis t = do+  gprT <- gprNow t+  tMillis <- gprTimeToMillis gprT+  timespecDestroy gprT+  return tMillis++testNow :: TestTree+testNow = testCase "Create/destroy various clock types" $ do+  _ <- currTimeMillis GprClockMonotonic+  _ <- currTimeMillis GprClockRealtime+  _ <- currTimeMillis GprClockPrecise+  return ()++testCreateDestroyMetadata :: TestTree+testCreateDestroyMetadata = testCase "Create/destroy metadataArrayPtr" $ do+  grpc $ withMetadataArrayPtr $ const $ return ()++testCreateDestroyMetadataKeyVals :: TestTree+testCreateDestroyMetadataKeyVals = testCase "Create/destroy metadata key/values" $ do+  grpc $ withMetadataKeyValPtr 10 $ const $ return ()++testCreateDestroyDeadline :: TestTree+testCreateDestroyDeadline = testCase "Create/destroy deadline" $ do+  grpc $ withDeadlineSeconds 10 $ const $ return ()++testCreateDestroyChannelArgs :: TestTree+testCreateDestroyChannelArgs = testCase "Create/destroy channel args" $+  grpc $ withChannelArgs [CompressionAlgArg GrpcCompressDeflate] $+  const $ return ()++testCreateDestroyClientCreds :: TestTree+testCreateDestroyClientCreds = testCase "Create/destroy client credentials" $+  grpc $ withChannelCredentials Nothing Nothing Nothing $ const $ return ()++testCreateDestroyServerCreds :: TestTree+testCreateDestroyServerCreds = testCase "Create/destroy server credentials" $+  grpc $ withServerCredentials Nothing+                               "tests/ssl/testServerKey.pem"+                               "tests/ssl/testServerCert.pem"+                               SslDontRequestClientCertificate+                               $ const $ return ()++assertCqEventComplete :: Event -> IO ()+assertCqEventComplete e = do+  eventCompletionType e HU.@?= OpComplete+  eventSuccess e HU.@?= True++grpc :: IO a -> IO ()+grpc = bracket_ grpcInit grpcShutdownBlocking . void++_nowarnUnused :: a+_nowarnUnused = assertCqEventComplete `undefined` threadDelaySecs
+ tests/ssl/localhost.crt view
@@ -0,0 +1,23 @@+-----BEGIN CERTIFICATE-----+MIID3DCCAsSgAwIBAgIJAN20aoC8p2pHMA0GCSqGSIb3DQEBBQUAMFExCzAJBgNV+BAYTAlVTMQswCQYDVQQIEwJDQTEhMB8GA1UEChMYSW50ZXJuZXQgV2lkZ2l0cyBQ+dHkgTHRkMRIwEAYDVQQDEwlsb2NhbGhvc3QwIBcNMTcwODA2MDcxNDMwWhgPMjEx+NzA3MTMwNzE0MzBaMFExCzAJBgNVBAYTAlVTMQswCQYDVQQIEwJDQTEhMB8GA1UE+ChMYSW50ZXJuZXQgV2lkZ2l0cyBQdHkgTHRkMRIwEAYDVQQDEwlsb2NhbGhvc3Qw+ggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQDLqLnEWZ93Gk4l3FyQgJ7z+6m7VLWfXVLRKWkGFvN01n1+lQGPi7MyC/FDKnYlCY2syPeovFU8IVS6M6Veue00u+MvuawUzls1jOcvgni9WW743LwZ6fQ+HKp0bU/xwm7wjPl9HrgzmuoQmGXX79NydP+NWpubcvpk8pdDPgY2zbCBOqd+X4rDMzYS2rucgM2idR/kA/o90lzSe//7+/nxHs9+LU1sZdQMtAEcCzjGW2s22mbYS6lyh21rWUgXxe0dttRJKrbuJj2vyFfuDjfeeQkY+vQetILWYWVfBQucKOo6to6JhVjfWGaIDYpy+XPZrw/osDkNqisN6GnJ5rHZ42QHl+AgMBAAGjgbQwgbEwHQYDVR0OBBYEFLA9tcsXLJHhPYSKgqGHebHy1c37MIGBBgNV+HSMEejB4gBSwPbXLFyyR4T2EioKhh3mx8tXN+6FVpFMwUTELMAkGA1UEBhMCVVMx+CzAJBgNVBAgTAkNBMSEwHwYDVQQKExhJbnRlcm5ldCBXaWRnaXRzIFB0eSBMdGQx+EjAQBgNVBAMTCWxvY2FsaG9zdIIJAN20aoC8p2pHMAwGA1UdEwQFMAMBAf8wDQYJ+KoZIhvcNAQEFBQADggEBAFQmEVNs5n6pAlPh6j3/JVMfgiWgORsC/RSBnBL+3jbH+8MgjQrj3cEIRzwSAAjZgnK9/SrbA5U2UoM4siT6g3MVX11ISpACKRUNTjEZcKzOO+N3yWt2jn+qqcimSmuUb3jXBaWFhlfKc4Fw5mKLz+jLyUyTOCxiykqpo7qX5Sa6Io+4tNLnSa5FZgUk47tiiLFjsAaEKqR46s7Hu325RzfnPgqoqpP1HahXuGdwhAgKWT8+kBgDyRsmspLM8tS/pO6KExjiS5VViR+/ifhULyNCeXYGBUKPmTkxBtAEgzV/Ku+h+aVuU8PmLE5KA6oSENVeiG2SmMLnKDnOMTDjmgvegNjk=+-----END CERTIFICATE-----
+ tests/ssl/localhost.key view
@@ -0,0 +1,27 @@+-----BEGIN RSA PRIVATE KEY-----+MIIEowIBAAKCAQEAy6i5xFmfdxpOJdxckICe8+pu1S1n11S0SlpBhbzdNZ9fpUBj+4uzMgvxQyp2JQmNrMj3qLxVPCFUujOlXrntNLjL7msFM5bNYznL4J4vVlu+Ny8Ge+n0PhyqdG1P8cJu8Iz5fR64M5rqEJhl1+/TcnTzVqbm3L6ZPKXQz4GNs2wgTqnfl++KwzM2Etq7nIDNonUf5AP6PdJc0nv/+/v58R7PS1NbGXUDLQBHAs4xltrNtpm2Eup+codta1lIF8XtHbbUSSq27iY9r8hX7g433nkJGL0HrSC1mFlXwULnCjqOraOiYVY3+1hmiA2Kcvlz2a8P6LA5DaorDehpyeax2eNkB5QIDAQABAoIBADkMXG0qBcdhMP7e+CXfY7623v7ArdekVqyMgwTXrP7PjnvE1ZkWMu4T9lMwM8QQNwVtjiJQDzg2xfsau+HoebtnT4hw5Ek3vMj1XVUroRK5WKKRgodnx6kWcpEGhdxc8KKlesWXs1WRUXuwlO+a2IW7wX7GoMwcmxNn+QM2/pqfZ4/LmIr6LQOaugLrEJn8/22GETttuRbxm85P9k5+h3eJir+XqS/w+NfwpR4Cy10j6kCGJrbHP0aEfCKcy6cdgdDAq2bZKpL9dQ8+SG33+BB9eJPUKfW07k9EuRV39ndvjMyd7mUChyrb92ih7GlGgFuXYgmw5T3rSQQz5crTB+ZcIyPgkCgYEA53uuCuaUe7CvqYSZ/YJ87NHtf93Y3uQLw0O32a+MheidTe7KFxts+StEnN6YSF1+e2sMxZ+2VbsHUoRHCEVqQYGYxOGeWStH+rvYCUpBh/EjPy3rij2Bf+NHD4M/+KHaUOKkW90kFgEqp/Jhj8etcZpdBry9Js/UVHcWrvJQr7Kp8CgYEA4Tqj+biLgBosOIItWIlnMSOM9RQTcuY6pXjR9BUaRV0qLW4El67qRTGLSP1I4GaD0GrKY+tRHgIuArSjxM3F9MUyaZbA94/qdpcek+p2Jq/mBuYtPSbKhX+rPYL6j6By6y2s5w+DKhSzE8/vU74AB0cOj4v0Qjn+glICLJPu2p2yPsCgYB1YdlKu8xVwK4DJzOzQwU4+TefCbGv58ugoF2HWaFe429FQ4KLn/sb2VYMui+8mnR1/z3VxPyAErxO0rb2ccTE/+QPL6qESlIkGk1SkuVvrpJL8CbwkOLY95l0O1koKmL7m0I/Ny+CXQsVaSqh7157eg+xsSy8bzE3emxkMk+Hoho/wKBgDegPeDjqCS1j0WmZB2TxAp0ZRt4ufLyMw5bNE1r+QlYmyQhOe0kfCOeuuHJ/Ie/ieqdlWKXPxmWWq9pnzivXNYiLzfSMVbu/KSHDE4BP+pFEzC9BItH21jhUS+d+7ghToCbBUsAPQRrLDF+DvcfzFM8WGulSMOI7eX/YV4+9L+ug6lAoGBALm/3ZUrL5/8MoKLgn2BNdy32Kn1Q5mS15g+0Hpa6ZsWHtIPB7U4CTXw+W8AxNKleJzADQhWE/ewmuJ54mi1P0SbrIk0J9Thwsl+eEsjSiFFn28i2wGiho5uR+mJ90C5b0GLKU09mMk5o5wjeIu27yH4/g7hjCpoOToM62Rt31kxla+-----END RSA PRIVATE KEY-----