Skip to content

Commit

Permalink
Merge pull request #401 from vubiostat/issue-397-drop-httr
Browse files Browse the repository at this point in the history
Issue 397 drop httr
  • Loading branch information
spgarbet authored Jul 31, 2024
2 parents aad8f34 + 459a6d4 commit 82a91c2
Show file tree
Hide file tree
Showing 23 changed files with 275 additions and 121 deletions.
2 changes: 1 addition & 1 deletion .gitlab-ci.yml
Original file line number Diff line number Diff line change
Expand Up @@ -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)"
6 changes: 4 additions & 2 deletions DESCRIPTION
Original file line number Diff line number Diff line change
@@ -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")),
Expand Down Expand Up @@ -40,9 +40,11 @@ Depends:
Imports:
checkmate,
chron,
httr,
curl,
jsonlite,
labelVector,
lubridate,
mime,
keyring,
getPass,
yaml
Expand Down
18 changes: 13 additions & 5 deletions NAMESPACE
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,7 @@

S3method("[",redcapFactor)
S3method(allocationTable,redcapApiConnection)
S3method(as.character,response)
S3method(as.list,redcapCodebook)
S3method(assembleCodebook,redcapConnection)
S3method(constructLinkToRedcapForm,redcapApiConnection)
Expand Down Expand Up @@ -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)
Expand All @@ -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)
Expand Down
4 changes: 4 additions & 0 deletions NEWS
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
138 changes: 138 additions & 0 deletions R/curl.R
Original file line number Diff line number Diff line change
@@ -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")
}
2 changes: 1 addition & 1 deletion R/documentation-common-args.R
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
2 changes: 1 addition & 1 deletion R/exportDataQuality.R
Original file line number Diff line number Diff line change
Expand Up @@ -52,7 +52,7 @@ exportDataQuality.redcapApiConnection <-

tryCatch(
{
result <- httr::content(response, type = 'application/json')
result <- .curlContent(response, type = 'application/json')
},
error = function(e)
{
Expand Down
2 changes: 1 addition & 1 deletion R/importFiles.R
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down
2 changes: 1 addition & 1 deletion R/importToFileRepository.R
Original file line number Diff line number Diff line change
Expand Up @@ -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 ------------------------------
Expand Down
57 changes: 32 additions & 25 deletions R/makeApiCall.R
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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),
Expand Down Expand Up @@ -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
Expand All @@ -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"))
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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')
Expand All @@ -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, ...)
}
7 changes: 5 additions & 2 deletions R/redcapAPI-package.R
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
Loading

0 comments on commit 82a91c2

Please sign in to comment.