Issue 397 drop httr

.gitlab-ci.yml

@@ -10,5 +10,5 @@ test:
     - cp $KEYRING tests/testthat.yml
     - apt-get update
     - apt-get install -y libsecret-1-dev libsodium-dev
-    - R --no-save -e "install.packages(c('devtools','checkmate','chron','httr','labelVector','lubridate','keyring','getPass','yaml','Hmisc','mockery'))"
+    - R --no-save -e "install.packages(c('devtools','checkmate','chron','curl','labelVector','lubridate','keyring','getPass','yaml','Hmisc','mockery','mime','jsonlite'))"
     - R --no-save -e "Sys.setenv(CI=1); devtools::test(stop_on_failure=TRUE)"

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: redcapAPI
 Type: Package
 Title: Interface to 'REDCap'
-Version: 2.9.4
+Version: 2.10.0
 Authors@R: c(
     person("Benjamin", "Nutter", email = "benjamin.nutter@gmail.com", 
            role = c("ctb", "aut")),
@@ -40,9 +40,11 @@ Depends:
 Imports:
     checkmate,
     chron,
-    httr,
+    curl,
+    jsonlite,
     labelVector,
     lubridate,
+    mime,
     keyring,
     getPass,
     yaml

NAMESPACE

@@ -2,6 +2,7 @@
 
 S3method("[",redcapFactor)
 S3method(allocationTable,redcapApiConnection)
+S3method(as.character,response)
 S3method(as.list,redcapCodebook)
 S3method(assembleCodebook,redcapConnection)
 S3method(constructLinkToRedcapForm,redcapApiConnection)
@@ -217,12 +218,18 @@ export(vectorToApiBodyList)
 export(widerRepeated)
 import(checkmate)
 importFrom(chron,times)
+importFrom(curl,curl_fetch_memory)
+importFrom(curl,curl_version)
+importFrom(curl,form_file)
+importFrom(curl,handle_cookies)
+importFrom(curl,handle_reset)
+importFrom(curl,handle_setform)
+importFrom(curl,handle_setheaders)
+importFrom(curl,handle_setopt)
+importFrom(curl,new_handle)
+importFrom(curl,parse_headers_list)
 importFrom(getPass,getPass)
-importFrom(httr,POST)
-importFrom(httr,config)
-importFrom(httr,content)
-importFrom(httr,set_config)
-importFrom(httr,upload_file)
+importFrom(jsonlite,fromJSON)
 importFrom(keyring,key_delete)
 importFrom(keyring,key_get)
 importFrom(keyring,key_list)
@@ -234,6 +241,7 @@ importFrom(labelVector,get_label)
 importFrom(labelVector,is.labelled)
 importFrom(labelVector,set_label)
 importFrom(lubridate,parse_date_time)
+importFrom(mime,guess_type)
 importFrom(stats,reshape)
 importFrom(utils,capture.output)
 importFrom(utils,compareVersion)

NEWS

@@ -10,6 +10,10 @@ A future release of version 3.0.0 will introduce several breaking changes!
 * The `exportProjectInfo` and `exportBundle` functions are being discontinued. Their functionality is replaced by caching values on the connection object.
 * The `cleanseMetaData` function is being discontinued.
 
+## 2.10.0
+
+* Replace "httr" dependency with "curl"
+
 ## 2.9.4
 
 * Minor code refactoring

R/curl.R

@@ -0,0 +1,138 @@
+#' @keywords internal
+
+.curlCompact <- function(x)
+{
+  x[vapply(x, length, numeric(1)) != 0]
+}
+
+.curlDefaultUa <- function()
+{
+  versions <- c(libcurl = curl::curl_version()$version, `r-curl` = as.character(utils::packageVersion("curl")))
+  paste0(names(versions), "/", versions, collapse = " ")
+}
+
+.curlConfig <- function(url, token)
+{
+  cfg <- getOption('curl_config')
+
+  if(is.null(cfg)) cfg <- list(headers=list(), fields=NULL, options=list())
+  if(is.null(cfg$options)) cfg$options <- list()
+
+  structure(list(
+    method     = 'POST',
+    url        = url,
+    headers    = c(cfg$headers, Accept = "application/json, text/xml, application/xml, */*"),
+    fields     = cfg$fields,
+    options    = modifyList(list(timeout_ms = 3e5,
+                                 useragent  = .curlDefaultUa(),
+                                 post       = TRUE),
+                            cfg$options),
+    auth_token = token,
+    output     = structure(list(), class = c("write_memory", "write_function"))
+  ), class = "request")
+}
+
+.curlMergeConfig <- function(x, 
+                             y)
+{
+  if(!is.null(y))
+  {
+    if(!is.null(y$options)) x$options <- modifyList(x$options, y$options)
+    if(!is.null(y$headers)) x$headers[names(y$headers)] <- y$headers
+    if(!is.null(y$fields))  x$fields[names(y$fields)] <- y$fields
+  }
+  x
+}
+
+.curlUploadFile <- function(path,
+                            type = NULL)
+{
+  stopifnot(is.character(path), length(path) == 1, file.exists(path))
+  if (is.null(type)) type <- mime::guess_type(path)
+  curl::form_file(path, type)
+}
+
+as.character.form_file <- function(x, ...) x
+
+.curlContent <- function(x, 
+                         type = 'text/plain',
+                         ...)
+{
+  stopifnot(inherits(x, "response"))
+  raw <- if (inherits(x$content, 'path'))
+         {
+           readBin(x$content, "raw", file.info(x$content)$size)
+         } else
+         {
+           x$content
+         }
+  if (length(raw) == 0) return("")
+
+  enc <- if(grepl("charset", x$headers[["content-type"]]))
+         {
+           toupper(sub('.*charset=([^;]+).*', '\\1', x$headers[["content-type"]]))
+         } else
+         {
+           'ISO-8859-1' # [Default if unspecified](https://www.w3.org/International/articles/http-charset/index)
+         }
+  x <- iconv(readBin(raw, character()), from = enc, to = 'UTF-8', '\U25a1')
+  if(grepl('\U25a1', x)) warning("Project contains invalid characters. Mapped to '\U25a1'.")
+
+  if(type == 'text/csv')
+  {
+    utils::read.csv(x, ...)
+  } else if(type == 'application/json')
+  {
+    jsonlite::fromJSON(x, simplifyVector = FALSE, ...)
+  } else
+  {
+    x
+  }
+}
+
+.curlPost <- function(body,
+                      config)
+{
+  h    <- curl::new_handle()
+  body <- .curlCompact(body)
+
+  # Argument Validation ---------------------------------------------
+  coll <- checkmate::makeAssertCollection()
+  checkmate::assert_list(x = body, 
+                         names = "named",
+                         add = coll)
+  checkmate::reportAssertions(coll)
+
+  flds <- lapply(body, function(x) 
+  {
+    if(inherits(x, 'list') || inherits(x, 'character'))
+    {
+      x
+    } else
+    {
+      as.character(x)
+    }
+  })
+
+  config$fields <- c(flds, config$fields)
+
+  curl::handle_setopt(h, .list = config$options)
+  if (!is.null(config$fields)) curl::handle_setform(h, .list = config$fields)
+
+  curl::handle_setheaders(h, .list = config$headers)
+  on.exit(curl::handle_reset(h), add = TRUE)
+
+  resp <- curl::curl_fetch_memory(config$url, h)
+  rh   <- curl::parse_headers_list(resp$headers)
+  structure(list(
+    url         = resp$url,
+    status_code = resp$status_code,
+    headers     = rh,
+    all_headers = resp$headers,
+    cookies     = curl::handle_cookies(h),
+    content     = resp$content,
+    times       = resp$times,
+    request     = config,
+    handle      = h
+  ), class = "response")
+}

R/documentation-common-args.R

@@ -22,7 +22,7 @@ NULL
 #' @description Common API arguments
 #' 
 #' @param config A named `list`. Additional configuration parameters to pass to
-#'   [httr::POST()]. These are appended to any parameters in
+#'   [curl::handle_setopt]. These are appended to any parameters in
 #'   `rcon$config`.
 #' @param api_param A named `list`. Additional API parameters to pass into the
 #'   body of the API call. This provides users to execute calls with options

R/exportDataQuality.R

@@ -52,7 +52,7 @@ exportDataQuality.redcapApiConnection <-
 
   tryCatch(
   {
-    result <- httr::content(response, type = 'application/json')
+    result <- .curlContent(response, type = 'application/json')
   },
   error = function(e)
   {

R/importFiles.R

@@ -128,7 +128,7 @@ importFiles.redcapApiConnection <- function(rcon,
                action = 'import', 
                record = record,
                field = field, 
-               file = httr::upload_file(file), 
+               file = .curlUploadFile(file),
                returnFormat = 'csv', 
                event = event, 
                repeat_instance = repeat_instance)

R/importToFileRepository.R

@@ -47,7 +47,7 @@ importToFileRepository.redcapApiConnection <- function(rcon,
   body <- list(content = "fileRepository", 
                action = "import", 
                returnFormat = "csv",
-               file = httr::upload_file(file), 
+               file = .curlUploadFile(file),
                folder_id = folder_id)
 
   # flush the cached File Repository ------------------------------

R/makeApiCall.R

@@ -7,14 +7,14 @@
 #'   execute calls for new REDCap features that are not yet implemented.
 #'   
 #' @inheritParams common-rcon-arg
-#' @param body `list` List of parameters to be passed to [httr::POST()]'s 
+#' @param body `list` List of parameters to be passed to [curl::]'s 
 #'   `body` argument
 #' @param url `character(1)` A url string to hit. Defaults to rcon$url.
 #' @param success_status_codes `integerish` A vector of success codes to ignore
 #'   for error handling. Defaults to c(200L).
 #' @param ... This will capture `api_param` (if specified) which will modify the body of the 
 #'   the specified body of the request. It also captures `config` which will get
-#'   passed to httr::POST.
+#'   passed to curl::handle_setopt.
 #' @details The intent of this function is to provide an approach to execute
 #'   calls to the REDCap API that is both consistent and flexible. Importantly, 
 #'   this provides a framework for making calls to the API using features that
@@ -28,8 +28,9 @@
 #'   `vectorToApiBodyList`; options that are not an array can be entered
 #'   directly (see examples). 
 #'   
-#'   The config list is a list of parameters to pass to [httr::POST()]. 
-#'   Refer to documentation there for details.
+#'   The config list is a list of parameter overrides that reflect the curl
+#'   request object. The most commonly used elements of this list 
+#'   is `options` or maybe `headers`. 
 #'   
 #'   Using the settings stored in the `redcapConnection` object, a response
 #'   code of 408 (Request Timeout), 500 (Internal Server Error), 
@@ -181,32 +182,28 @@ makeApiCall <- function(rcon,
   body <- utils::modifyList(body, list(token = rcon$token))
   body <- utils::modifyList(body, api_param)
   body <- body[lengths(body) > 0]
-
-  config <- utils::modifyList(rcon$config, config)
+
+  config <- .curlMergeConfig(rcon$config, config)
+  if(!is.null(url)) config$url <- url
 
   # Functional Code -------------------------------------------------
 
-  if(is.null(url)) url <- rcon$url
-
   for (i in seq_len(rcon$retries()))
   {
     response <-
       tryCatch(
       {
-        httr::POST(url = url, body = body, config = config)
+        .curlPost(body = body, config = config)
       },
       error=function(e)
       {
         if(grepl("Timeout was reached", e$message))
         {
           structure(
             list(
-              status_code=408L,
-              content=charToRaw(e$message),
-              headers=structure(
-                list('Content-Type'="text/csv; charset=utf-8"),
-                class = c("insensitive", "list")
-              )
+              status_code = 408L,
+              content = charToRaw(e$message),
+              headers = list('content-type' = "text/csv; charset=utf-8")
             ),
             class="response")
         } else
@@ -215,12 +212,10 @@ makeApiCall <- function(rcon,
         }
       })
 
-    httr_config <- getOption("httr_config")
-    if(!is.null(httr_config)                     &&
-       "options" %in% names(httr_config)         &&
-       "verbose" %in% names(httr_config$options) &&
-       is.logical(httr_config$options$verbose)   &&
-       httr_config$options$verbose
+    if("options" %in% names(config)         &&
+       "verbose" %in% names(config$options) &&
+       is.logical(config$options$verbose)   &&
+       config$options$verbose
       )
     {
       message(paste0(">>>\n", as.character(response), "<<<\n"))
@@ -260,10 +255,10 @@ makeApiCall <- function(rcon,
   {
     if(response$status_code == 301L)
     {
-      warning(paste("Permanent 301 redirect", response$url, "to", response$headers$Location))
+      warning(paste("Permanent 301 redirect", response$url, "to", response$headers$location))
     } else
     {
-      message(paste("Temporary 302 redirect", response$url, "to", response$headers$Location))
+      message(paste("Temporary 302 redirect", response$url, "to", response$headers$location))
     }
 
     # Good for a single call
@@ -317,8 +312,8 @@ as.data.frame.response <- function(x, row.names=NULL, optional=FALSE, ...)
   na.strings <- extra$na.strings
   if(is.null(na.strings)) na.strings <- ""
 
-  enc <- if(grepl("charset", x$headers[["Content-Type"]]))
-    toupper(sub('.*charset=([^;]+).*', '\\1', x$headers[["Content-Type"]])) else
+  enc <- if(grepl("charset", x$headers[["content-type"]]))
+    toupper(sub('.*charset=([^;]+).*', '\\1', x$headers[["content-type"]])) else
     'ISO-8859-1' # [Default if unspecified](https://www.w3.org/International/articles/http-charset/index)
   mapped <- iconv(readBin(x$content, character()),
                   enc, 'UTF-8', '\U25a1')
@@ -340,3 +335,15 @@ as.data.frame.response <- function(x, row.names=NULL, optional=FALSE, ...)
       ...)
   }
 }
+
+#' @name as.character.response
+#' @title S3 method to turn curl response into character
+#' 
+#' @description Converts a raw curl response into a character string.
+#' @export
+#' @param x response from curl to render to character
+#' @param ... If type='text/csv' this is passed to read.csv. If type='application/json'
+#'            this is sent to jsonlite::fromJSON
+as.character.response <- function(x, ...) {
+  .curlContent(x, ...)
+}

R/redcapAPI-package.R

@@ -16,13 +16,16 @@
 #' 
 #' @name redcapAPI
 #' @keywords internal
-#' @import checkmate 
+#' @import checkmate
 #' @importFrom chron times
 #' @importFrom getPass getPass
-#' @importFrom httr config content POST set_config upload_file
+#' @importFrom curl curl_fetch_memory curl_version form_file handle_cookies handle_reset
+#' handle_setform handle_setheaders handle_setopt new_handle parse_headers_list
+#' @importFrom jsonlite fromJSON
 #' @importFrom keyring key_delete key_get key_list key_set_with_value keyring_create keyring_list keyring_unlock
 #' @importFrom labelVector get_label is.labelled set_label
 #' @importFrom lubridate parse_date_time
+#' @importFrom mime guess_type
 #' @importFrom stats reshape
 #' @importFrom utils capture.output compareVersion head modifyList
 #' osVersion packageVersion read.csv tail write.csv write.table