ncurl() gains 'request' argument for specifying arbitrary headers to return

Author: shikokuchuo

NEWS.md

@@ -4,7 +4,8 @@
 
 * Implements `sha224()`, `sha256()`, `sha384()` and `sha512()` series of fast, optimised cryptographic hash and HMAC generation functions using the 'Mbed TLS' library.
 * `ncurl()` and `stream()` gain the argmument 'pem' for optionally specifying a certificate authority certificate chain PEM file for authenticating secure sites.
-* `ncurl()` now returns additional `$status` (response status code) and `$time` (server date header) fields.
+* `ncurl()` gains the argument 'request' for specifying response headers to return.
+* `ncurl()` now returns additional `$status` (response status code) and `$headers` (response headers) fields.
 * `messenger()` gains the argument 'auth' for authenticating communications based on a pre-shared key.
 * `random()` gains the argument 'n' for generating a vector of random numbers.
 

R/nano.R

@@ -273,7 +273,7 @@ print.sendAio <- function(x, ...) {
 #'
 print.ncurlAio <- function(x, ...) {
 
-  cat("< ncurlAio >\n - $status for response status code\n - $time for server date header\n - $raw for raw message\n - $data for message data\n", file = stdout())
+  cat("< ncurlAio >\n - $status for response status code\n - $headers for requested response headers\n - $raw for raw message\n - $data for message data\n", file = stdout())
   invisible(x)
 
 }
@@ -341,5 +341,5 @@ print.errorValue <- function(x, ...) {
 
 #' @export
 #'
-.DollarNames.ncurlAio <- function(x, pattern = "") grep(pattern, c("status", "time", "raw", "data"),
+.DollarNames.ncurlAio <- function(x, pattern = "") grep(pattern, c("status", "headers", "raw", "data"),
                                                         value = TRUE, fixed = TRUE)

R/ncurl.R

@@ -29,6 +29,10 @@
 #'     HTTP request headers e.g. \code{list(`Content-Type` = "text/plain")} or
 #'     \code{c(Authorization = "Bearer APIKEY")}.
 #' @param data (optional) the request data to be submitted.
+#' @param request (optional) a character vector or list specifying the response
+#'     headers to return e.g. \code{c("Date", "Server")} or
+#'     \code{list("date", "server")}. These are case-insensitive and will return
+#'     NULL if not present.
 #' @param pem (optional) applicable to secure HTTPS sites only. The path to a
 #'     file containing X.509 certificate(s) in PEM format, comprising the
 #'     certificate authority certificate chain (and revocation list if present).
@@ -37,7 +41,7 @@
 #' @return Named list of 4 elements:
 #'     \itemize{
 #'     \item{\code{$status}} {- integer HTTP repsonse status code (200 - OK).}
-#'     \item{\code{$time}} {- character 'Date' server response header.}
+#'     \item{\code{$headers}} {- list of requested response headers.}
 #'     \item{\code{$raw}} {- raw vector of the received resource (use
 #'     \code{\link{writeBin}} to save to a file).}
 #'     \item{\code{$data}} {- converted character string (if \code{'convert' = TRUE}
@@ -59,7 +63,7 @@
 #'     string at \code{$raw} and \code{$data} will be NULL.
 #'
 #' @examples
-#' ncurl("https://httpbin.org/get")
+#' ncurl("https://httpbin.org/get", request = c("Date", "Server"))
 #' ncurl("http://httpbin.org/put",,,"PUT", list(Authorization = "Bearer APIKEY"), "hello world")
 #' ncurl("http://httpbin.org/post",,,"POST", c(`Content-Type` = "application/json"),'{"k":"v"}')
 #'
@@ -71,6 +75,7 @@ ncurl <- function(url,
                   method = NULL,
                   headers = NULL,
                   data = NULL,
+                  request = NULL,
                   pem = NULL) {
 
   data <- if (!missing(data)) writeBin(object = data, con = raw())
@@ -80,55 +85,56 @@ ncurl <- function(url,
     aio <- .Call(rnng_ncurl_aio, url, method, headers, data, pem)
     is.integer(aio) && return(aio)
 
-    convert <- missing(convert) || isTRUE(convert)
-    status <- time <- raw <- data <- NULL
+    force(convert)
+    force(request)
+    status <- headers <- raw <- data <- NULL
     unresolv <- TRUE
     env <- new.env(hash = FALSE)
     makeActiveBinding(sym = "status", fun = function(x) {
       if (unresolv) {
-        res <- .Call(rnng_aio_http, aio)
+        res <- .Call(rnng_aio_http, aio, convert, request)
         missing(res) && return(.Call(rnng_aio_unresolv))
         if (is.integer(res)) {
           data <<- raw <<- res
         } else {
           status <<- res[[1L]]
-          time <<- res[[2L]]
+          headers <<- res[[2L]]
           raw <<- res[[3L]]
-          data <<- if (convert) tryCatch(rawToChar(raw), error = function(e) NULL)
+          data <<- res[[4L]]
         }
         aio <<- env[["aio"]] <<- NULL
         unresolv <<- FALSE
       }
       status
     }, env = env)
-    makeActiveBinding(sym = "time", fun = function(x) {
+    makeActiveBinding(sym = "headers", fun = function(x) {
       if (unresolv) {
-        res <- .Call(rnng_aio_http, aio)
+        res <- .Call(rnng_aio_http, aio, convert, request)
         missing(res) && return(.Call(rnng_aio_unresolv))
         if (is.integer(res)) {
           data <<- raw <<- res
         } else {
           status <<- res[[1L]]
-          time <<- res[[2L]]
+          headers <<- res[[2L]]
           raw <<- res[[3L]]
-          data <<- if (convert) tryCatch(rawToChar(raw), error = function(e) NULL)
+          data <<- res[[4L]]
         }
         aio <<- env[["aio"]] <<- NULL
         unresolv <<- FALSE
       }
-      time
+      headers
     }, env = env)
     makeActiveBinding(sym = "raw", fun = function(x) {
       if (unresolv) {
-        res <- .Call(rnng_aio_http, aio)
+        res <- .Call(rnng_aio_http, aio, convert, request)
         missing(res) && return(.Call(rnng_aio_unresolv))
         if (is.integer(res)) {
           data <<- raw <<- res
         } else {
           status <<- res[[1L]]
-          time <<- res[[2L]]
+          headers <<- res[[2L]]
           raw <<- res[[3L]]
-          data <<- if (convert) tryCatch(rawToChar(raw), error = function(e) NULL)
+          data <<- res[[4L]]
         }
         aio <<- env[["aio"]] <<- NULL
         unresolv <<- FALSE
@@ -137,15 +143,15 @@ ncurl <- function(url,
     }, env = env)
     makeActiveBinding(sym = "data", fun = function(x) {
       if (unresolv) {
-        res <- .Call(rnng_aio_http, aio)
+        res <- .Call(rnng_aio_http, aio, convert, request)
         missing(res) && return(.Call(rnng_aio_unresolv))
         if (is.integer(res)) {
           data <<- raw <<- res
         } else {
           status <<- res[[1L]]
-          time <<- res[[2L]]
+          headers <<- res[[2L]]
           raw <<- res[[3L]]
-          data <<- if (convert) tryCatch(rawToChar(raw), error = function(e) NULL)
+          data <<- res[[4L]]
         }
         aio <<- env[["aio"]] <<- NULL
         unresolv <<- FALSE
@@ -157,7 +163,7 @@ ncurl <- function(url,
 
   } else {
 
-    res <- .Call(rnng_ncurl, url, convert, method, headers, data, pem)
+    res <- .Call(rnng_ncurl, url, convert, method, headers, data, request, pem)
 
     is.character(res) && {
       continue <- if (interactive()) readline(sprintf("Follow redirect to <%s>? [Y/n] ", res)) else "n"

README.Rmd

@@ -425,10 +425,13 @@ For advanced use, supports additional HTTP methods such as POST or PUT.
 ```{r ncurladv}
 res <- ncurl("http://httpbin.org/post", async = TRUE, method = "POST",
              headers = c(`Content-Type` = "application/json", Authorization = "Bearer APIKEY"),
-             data = '{"key": "value"}')
+             data = '{"key": "value"}',
+             request = c("Date", "Server"))
 res
 
-call_aio(res)$data
+call_aio(res)$headers
+
+res$data
 
 ```
 

README.md

@@ -384,7 +384,7 @@ aio
 #> < recvAio >
 #>  - $data for message data
 aio$data |> str()
-#>  num [1:100000000] -0.503 0.475 1.854 0.741 0.834 ...
+#>  num [1:100000000] 1.783 0.185 1.083 0.849 0.801 ...
 ```
 
 As `call_aio()` is blocking and will wait for completion, an alternative
@@ -536,35 +536,43 @@ ncurl("https://httpbin.org/headers")
 #> $status
 #> [1] 200
 #> 
-#> $time
-#> [1] "Thu, 01 Sep 2022 18:21:48 GMT"
+#> $headers
+#> NULL
 #> 
 #> $raw
 #>   [1] 7b 0a 20 20 22 68 65 61 64 65 72 73 22 3a 20 7b 0a 20 20 20 20 22 48 6f 73
 #>  [26] 74 22 3a 20 22 68 74 74 70 62 69 6e 2e 6f 72 67 22 2c 20 0a 20 20 20 20 22
 #>  [51] 58 2d 41 6d 7a 6e 2d 54 72 61 63 65 2d 49 64 22 3a 20 22 52 6f 6f 74 3d 31
-#>  [76] 2d 36 33 31 30 66 38 33 63 2d 34 37 34 63 35 32 63 32 30 39 35 36 63 34 64
-#> [101] 66 37 32 61 66 35 61 66 36 22 0a 20 20 7d 0a 7d 0a
+#>  [76] 2d 36 33 31 31 32 62 32 30 2d 33 31 39 35 33 31 38 35 35 66 61 36 33 36 62
+#> [101] 30 32 62 34 37 62 37 63 38 22 0a 20 20 7d 0a 7d 0a
 #> 
 #> $data
-#> [1] "{\n  \"headers\": {\n    \"Host\": \"httpbin.org\", \n    \"X-Amzn-Trace-Id\": \"Root=1-6310f83c-474c52c20956c4df72af5af6\"\n  }\n}\n"
+#> [1] "{\n  \"headers\": {\n    \"Host\": \"httpbin.org\", \n    \"X-Amzn-Trace-Id\": \"Root=1-63112b20-319531855fa636b02b47b7c8\"\n  }\n}\n"
 ```
 
 For advanced use, supports additional HTTP methods such as POST or PUT.
 
 ``` r
 res <- ncurl("http://httpbin.org/post", async = TRUE, method = "POST",
              headers = c(`Content-Type` = "application/json", Authorization = "Bearer APIKEY"),
-             data = '{"key": "value"}')
+             data = '{"key": "value"}',
+             request = c("Date", "Server"))
 res
 #> < ncurlAio >
 #>  - $status for response status code
-#>  - $time for server date header
+#>  - $headers for requested response headers
 #>  - $raw for raw message
 #>  - $data for message data
 
-call_aio(res)$data
-#> [1] "{\n  \"args\": {}, \n  \"data\": \"{\\\"key\\\": \\\"value\\\"}\", \n  \"files\": {}, \n  \"form\": {}, \n  \"headers\": {\n    \"Authorization\": \"Bearer APIKEY\", \n    \"Content-Length\": \"16\", \n    \"Content-Type\": \"application/json\", \n    \"Host\": \"httpbin.org\", \n    \"X-Amzn-Trace-Id\": \"Root=1-6310f83c-48c315072c11b954353e13f4\"\n  }, \n  \"json\": {\n    \"key\": \"value\"\n  }, \n  \"origin\": \"185.225.45.49\", \n  \"url\": \"http://httpbin.org/post\"\n}\n"
+call_aio(res)$headers
+#> $Date
+#> [1] "Thu, 01 Sep 2022 21:58:57 GMT"
+#> 
+#> $Server
+#> [1] "gunicorn/19.9.0"
+
+res$data
+#> [1] "{\n  \"args\": {}, \n  \"data\": \"{\\\"key\\\": \\\"value\\\"}\", \n  \"files\": {}, \n  \"form\": {}, \n  \"headers\": {\n    \"Authorization\": \"Bearer APIKEY\", \n    \"Content-Length\": \"16\", \n    \"Content-Type\": \"application/json\", \n    \"Host\": \"httpbin.org\", \n    \"X-Amzn-Trace-Id\": \"Root=1-63112b21-1018c937316c24cb11110b8a\"\n  }, \n  \"json\": {\n    \"key\": \"value\"\n  }, \n  \"origin\": \"185.225.45.49\", \n  \"url\": \"http://httpbin.org/post\"\n}\n"
 ```
 
 In this respect, it may be used as a performant and lightweight method
@@ -607,10 +615,10 @@ s |> send('{"action": "subscribe", "symbols": "EURUSD"}')
 #> [26] 73 79 6d 62 6f 6c 73 22 3a 20 22 45 55 52 55 53 44 22 7d 00
 
 s |> recv(keep.raw = FALSE)
-#> [1] "{\"s\":\"EURUSD\",\"a\":0.99582,\"b\":0.9958,\"dc\":\"-0.8003\",\"dd\":\"-0.0080\",\"ppms\":false,\"t\":1662056512000}"
+#> [1] "{\"s\":\"EURUSD\",\"a\":0.99499,\"b\":0.99426,\"dc\":\"-0.8844\",\"dd\":\"-0.0088\",\"ppms\":false,\"t\":1662069549000}"
 
 s |> recv(keep.raw = FALSE)
-#> [1] "{\"s\":\"EURUSD\",\"a\":0.99583,\"b\":0.99581,\"dc\":\"-0.7993\",\"dd\":\"-0.0080\",\"ppms\":false,\"t\":1662056513000}"
+#> [1] "{\"s\":\"EURUSD\",\"a\":0.99474,\"b\":0.99454,\"dc\":\"-0.9098\",\"dd\":\"-0.0091\",\"ppms\":false,\"t\":1662069549000}"
 
 close(s)
 ```

man/ncurl.Rd

@@ -650,7 +650,7 @@ SEXP rnng_ncurl_aio(SEXP http, SEXP method, SEXP headers, SEXP data, SEXP pem) {
 
 }
 
-SEXP rnng_aio_http(SEXP aio) {
+SEXP rnng_aio_http(SEXP aio, SEXP convert, SEXP request) {
 
   if (R_ExternalPtrTag(aio) != nano_AioSymbol)
     error_return("object is not a valid Aio");
@@ -667,33 +667,71 @@ SEXP rnng_aio_http(SEXP aio) {
 
   nano_handle *handle = (nano_handle *) haio->data;
   uint16_t code = nng_http_res_get_status(handle->res);
-  const char *date = nng_http_res_get_header(handle->res, "Date");
 
   if (code != 200) {
     REprintf("HTTP Server Response: %d %s\n", code, nng_http_res_get_reason(handle->res));
     if (code >= 300 && code < 400) {
       SEXP out;
-      PROTECT(out = Rf_allocVector(VECSXP, 3));
+      PROTECT(out = Rf_allocVector(VECSXP, 4));
       SET_VECTOR_ELT(out, 0, Rf_ScalarInteger(code));
-      SET_VECTOR_ELT(out, 1, Rf_mkString(date == NULL ? "" : date));
+      SET_VECTOR_ELT(out, 1, R_NilValue);
       SET_VECTOR_ELT(out, 2, Rf_mkString(nng_http_res_get_header(handle->res, "Location")));
+      SET_VECTOR_ELT(out, 3, R_NilValue);
       UNPROTECT(1);
       return out;
     }
   }
 
   void *dat;
   size_t sz;
-  SEXP out, vec;
+  SEXP out, vec, cvec = R_NilValue, rvec = R_NilValue;
 
-  PROTECT(out = Rf_allocVector(VECSXP, 3));
+  PROTECT(out = Rf_allocVector(VECSXP, 4));
   SET_VECTOR_ELT(out, 0, Rf_ScalarInteger(code));
-  SET_VECTOR_ELT(out, 1, Rf_mkString(date == NULL ? "" : date));
+
+  if (request != R_NilValue) {
+    const R_xlen_t rlen = Rf_xlength(request);
+    PROTECT(rvec = Rf_allocVector(VECSXP, rlen));
+    SEXP rnames;
+
+    switch (TYPEOF(request)) {
+    case STRSXP:
+      for (R_xlen_t i = 0; i < rlen; i++) {
+        const char *r = nng_http_res_get_header(handle->res, CHAR(STRING_ELT(request, i)));
+        SET_VECTOR_ELT(rvec, i, r == NULL ? R_NilValue : Rf_mkString(r));
+      }
+      Rf_namesgets(rvec, request);
+      break;
+    case VECSXP:
+      PROTECT(rnames = Rf_allocVector(STRSXP, rlen));
+      for (R_xlen_t i = 0; i < rlen; i++) {
+        SEXP rname = STRING_ELT(VECTOR_ELT(request, i), 0);
+        SET_STRING_ELT(rnames, i, rname);
+        const char *r = nng_http_res_get_header(handle->res, CHAR(rname));
+        SET_VECTOR_ELT(rvec, i, r == NULL ? R_NilValue : Rf_mkString(r));
+      }
+      Rf_namesgets(rvec, rnames);
+      UNPROTECT(1);
+      break;
+    }
+    UNPROTECT(1);
+  }
+  SET_VECTOR_ELT(out, 1, rvec);
+
   nng_http_res_get_data(handle->res, &dat, &sz);
   vec = Rf_allocVector(RAWSXP, sz);
   memcpy(RAW(vec), dat, sz);
   SET_VECTOR_ELT(out, 2, vec);
 
+  if (Rf_asLogical(convert)) {
+    SEXP expr;
+    int xc;
+    PROTECT(expr = Rf_lang2(nano_RtcSymbol, vec));
+    cvec = R_tryEvalSilent(expr, R_BaseEnv, &xc);
+    UNPROTECT(1);
+  }
+  SET_VECTOR_ELT(out, 3, cvec);
+
   UNPROTECT(1);
   return out;
 

src/aio.c

@@ -59,7 +59,7 @@ static void RegisterSymbols(void) {
 static const R_CallMethodDef CallEntries[] = {
   {"rnng_aio_call", (DL_FUNC) &rnng_aio_call, 1},
   {"rnng_aio_get_msg", (DL_FUNC) &rnng_aio_get_msg, 3},
-  {"rnng_aio_http", (DL_FUNC) &rnng_aio_http, 1},
+  {"rnng_aio_http", (DL_FUNC) &rnng_aio_http, 3},
   {"rnng_aio_result", (DL_FUNC) &rnng_aio_result, 1},
   {"rnng_aio_stop", (DL_FUNC) &rnng_aio_stop, 1},
   {"rnng_aio_stream_in", (DL_FUNC) &rnng_aio_stream_in, 3},
@@ -89,7 +89,7 @@ static const R_CallMethodDef CallEntries[] = {
   {"rnng_matchargs", (DL_FUNC) &rnng_matchargs, 1},
   {"rnng_matchwarn", (DL_FUNC) &rnng_matchwarn, 1},
   {"rnng_messenger", (DL_FUNC) &rnng_messenger, 1},
-  {"rnng_ncurl", (DL_FUNC) &rnng_ncurl, 6},
+  {"rnng_ncurl", (DL_FUNC) &rnng_ncurl, 7},
   {"rnng_ncurl_aio", (DL_FUNC) &rnng_ncurl_aio, 5},
   {"rnng_protocol_open", (DL_FUNC) &rnng_protocol_open, 2},
   {"rnng_random", (DL_FUNC) &rnng_random, 1},