Some improvements to the cURL interface

R/ncurl.R

@@ -19,7 +19,7 @@
 #'   A non-character or non-named vector will be ignored.
 #' @param data (optional) character string request data to be submitted. If a
 #'   vector, only the first element is taken, and non-character objects are
-#'   ignored.
+#'   ignored. Alternatively a raw vector giving the data to transfer directly
 #' @param response (optional) a character vector specifying the response headers
 #'   to return e.g. `c("date", "server")`. These are case-insensitive and
 #'   will return NULL if not present. A non-character vector will be ignored.
@@ -111,9 +111,19 @@ ncurl <- function(
 #'
 #' The promises created are completely event-driven and non-polling.
 #'
-#' If a status code of 200 (OK) is returned then the promise is resolved with
-#' the reponse body, otherwise it is rejected with a translation of the status
-#' code or 'errorValue' as the case may be.
+#' The promise is resolved to a list with the following elements:
+#'   \itemize{
+#'     \item `$status` - integer HTTP repsonse status code (200 - OK).
+#'     Use [status_code()] for a translation of the meaning.
+#'     \item `$headers` - named list of response headers supplied in `response`,
+#'     or NULL otherwise. If the status code is within the 300 range, i.e. a
+#'     redirect, the response header 'Location' is automatically appended to
+#'     return the redirect address.
+#'     \item `$body` - the response body, as a character string if
+#'     `convert = TRUE` (may be further parsed as html, json, xml etc. as
+#'     required), or a raw byte vector if FALSE (use [writeBin()] to save as a
+#'     file).
+#'   }
 #'
 #' @seealso [ncurl()] for synchronous http requests; [ncurl_session()] for
 #'   persistent connections.
@@ -246,17 +256,23 @@ as.promise.ncurlAio <- function(x) {
         function(resolve, reject) .keep(x, environment())
       )$then(
         onFulfilled = function(value, .visible) {
-          value == 200L || stop(if (value < 100) nng_error(value) else status_code(value))
-          .subset2(x, "value")
+          list(
+            status = .subset2(x, "status"),
+            headers = .subset2(x, "headers"),
+            body = .subset2(x, "data")
+          )
         }
       )
     } else {
       value <- .subset2(x, "result")
       promises::promise(
         function(resolve, reject)
           resolve({
-            value == 200L || stop(if (value < 100) nng_error(value) else status_code(value))
-            .subset2(x, "value")
+            list(
+              status = .subset2(x, "status"),
+              headers = .subset2(x, "headers"),
+              body = .subset2(x, "data")
+            )
           })
       )
     }

src/ncurl.c

@@ -1,5 +1,6 @@
 // nanonext - C level - ncurl --------------------------------------------------
 
+#include "Rinternals.h"
 #define NANONEXT_HTTP
 #include "nanonext.h"
 
@@ -60,6 +61,15 @@ static nano_buf nano_char_buf(const SEXP data) {
 
 }
 
+static nano_buf nano_raw_buf(const SEXP data) {
+
+  nano_buf buf;
+  NANO_INIT(&buf, RAW(data), Rf_xlength(data));
+
+  return buf;
+
+}
+
 // aio completion callbacks ----------------------------------------------------
 
 static void haio_invoke_cb(void *arg) {
@@ -175,8 +185,11 @@ SEXP rnng_ncurl(SEXP http, SEXP convert, SEXP follow, SEXP method, SEXP headers,
       }
     }
   }
-  if (data != R_NilValue && TYPEOF(data) == STRSXP) {
-    nano_buf enc = nano_char_buf(data);
+  if (data != R_NilValue) {
+    nano_buf enc;
+    if (TYPEOF(data) == STRSXP) enc = nano_char_buf(data);
+    else if (TYPEOF(data) == RAWSXP) enc = nano_raw_buf(data);
+    else goto fail;
     if ((xc = nng_http_req_set_data(req, enc.buf, enc.cur)))
       goto fail;
   }
@@ -345,8 +358,11 @@ SEXP rnng_ncurl_aio(SEXP http, SEXP convert, SEXP method, SEXP headers, SEXP dat
       }
     }
   }
-  if (data != R_NilValue && TYPEOF(data) == STRSXP) {
-    nano_buf enc = nano_char_buf(data);
+  if (data != R_NilValue) {
+    nano_buf enc;
+    if (TYPEOF(data) == STRSXP) enc = nano_char_buf(data);
+    else if (TYPEOF(data) == RAWSXP) enc = nano_raw_buf(data);
+    else goto fail;
     if ((xc = nng_http_req_set_data(handle->req, enc.buf, enc.cur)))
       goto fail;
   }
@@ -550,8 +566,11 @@ SEXP rnng_ncurl_session(SEXP http, SEXP convert, SEXP method, SEXP headers, SEXP
       }
     }
   }
-  if (data != R_NilValue && TYPEOF(data) == STRSXP) {
-    nano_buf enc = nano_char_buf(data);
+  if (data != R_NilValue) {
+    nano_buf enc;
+    if (TYPEOF(data) == STRSXP) enc = nano_char_buf(data);
+    else if (TYPEOF(data) == RAWSXP) enc = nano_raw_buf(data);
+    else goto fail;
     if ((xc = nng_http_req_set_data(handle->req, enc.buf, enc.cur)))
       goto fail;
   }