From 59159c1fbad216f88c74c78315eb335af8e4b427 Mon Sep 17 00:00:00 2001 From: hadley Date: Mon, 4 May 2015 16:29:44 -0500 Subject: [PATCH 1/5] Switch dep to curl --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index e1767ac7..fcec91e3 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -15,7 +15,7 @@ Imports: jsonlite, methods, mime, - RCurl (>= 1.95-0), + curl (>= 0.5.99), R6, stringr (>= 0.6.1) Suggests: From 3630742521d178be753c9c972082b10de91310db Mon Sep 17 00:00:00 2001 From: hadley Date: Mon, 4 May 2015 16:34:20 -0500 Subject: [PATCH 2/5] Use curl handle --- R/handle.r | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/R/handle.r b/R/handle.r index a8a91b10..d295618b 100644 --- a/R/handle.r +++ b/R/handle.r @@ -25,17 +25,17 @@ handle <- function(url, cookies = TRUE) { url <- parse_http://github.com/url(url) cookie_path <- if (cookies) tempfile() else NULL - h <- RCurl::getCurlHandle(cookiefile = cookie_path, .defaults = list()) + h <- curl::new_handle(cookiefile = cookie_path) structure(list(handle = h, url = url), class = "handle") } #' @export print.handle <- function(x, ...) { - cat("Host: ", build_url(http://github.com/x$url) , " <", ref(x), ">\n", sep = "") + cat("Host: ", build_url(http://github.com/x$url) , " <", ref(x$handle), ">\n", sep = "") } ref <- function(x) { - str_extract(capture.output(print(x$handle@ref)), "0x[0-9a-f]*") + str_extract(capture.output(print(x))[1], "0x[0-9a-f]*") } is.handle <- function(x) inherits(x, "handle") @@ -44,7 +44,7 @@ reset_handle_config <- function(handle, config) { # Calls curl_easy_reset (http://curl.haxx.se/libcurl/c/curl_easy_reset.html) # Does not change live connections, session ID cache, DNS cache, cookies # or shares. - RCurl::reset(handle$handle) + curl::handle_reset(handle) invisible(TRUE) } From f04a938984d645887a52f695167384ffe513a169 Mon Sep 17 00:00:00 2001 From: hadley Date: Tue, 5 May 2015 08:40:35 -0500 Subject: [PATCH 3/5] Work on curl conversion --- R/body.R | 44 +++++++--------- R/config.r | 22 +++++--- R/cookies.r | 12 +---- R/doctor.R | 2 +- R/handle.r | 9 ---- R/http--request.r | 17 ------ R/perform.R | 90 +++++++------------------------- R/request.R | 130 ++++++++++++++++++++++++++++++++++++++++++++++ R/upload-file.r | 17 +++--- R/url-query.r | 8 +-- R/url.r | 4 +- R/utils.r | 11 ++-- 12 files changed, 206 insertions(+), 160 deletions(-) create mode 100644 R/request.R diff --git a/R/body.R b/R/body.R index 476be987..358312ab 100644 --- a/R/body.R +++ b/R/body.R @@ -1,9 +1,11 @@ body_config <- function(body = NULL, encode = "form", type = NULL) { # Post without body - if (is.null(body)) return(body_raw(raw())) + if (is.null(body)) + return(body_raw(raw())) # No body - if (identical(body, FALSE)) return(body_httr(post = TRUE, nobody = TRUE)) + if (identical(body, FALSE)) + return(body_httr(post = TRUE, nobody = TRUE)) # For character/raw, send raw bytes if (is.character(body) || is.raw(body)) { @@ -11,11 +13,9 @@ body_config <- function(body = NULL, encode = "form", type = NULL) { } # Send single file lazily - if (inherits(body, "FileUploadInfo")) { - con <- file(body$filename, "rb") - mime_type <- body$contentType %||% - mime::guess_type(body$filename, empty = NULL) - size <- file.info(body$filename)$size + if (inherits(body, "upload_file")) { + con <- file(body$path, "rb") + size <- file.info(body$path)$size return(body_httr( post = TRUE, @@ -26,7 +26,7 @@ body_config <- function(body = NULL, encode = "form", type = NULL) { bin }, postfieldsize = size, - type = mime_type + type = body$type )) } @@ -41,39 +41,25 @@ body_config <- function(body = NULL, encode = "form", type = NULL) { } else if (encode == "json") { body_raw(jsonlite::toJSON(body, auto_unbox = TRUE), "application/json") } else if (encode == "multipart") { - # For multipart, rely on RCurl .postForm function to make it possible - # to intermingle on-disk and in-memory content. - - charify <- function(x) { - if (inherits(x, "FileUploadInfo")) return(x) - as.character(x) - } - body <- lapply(body, charify) + # For multipart, rely on curl::handle_setform + body <- lapply(body, as.character) stopifnot(length(names(body)) > 0) - body_rcurl(http://github.com/body%20=%20body,%20style%20=%20NA) + body_rcurl(http://github.com/body) } else { stop("Unknown encoding", call. = FALSE) } } -body_rcurl <- function(body = NULL, style = NULL) { +body_rcurl <- function(body = NULL) { list( config = NULL, body = body, - style = style, curl_post = TRUE ) } -body_httr <- function(..., type = NULL) { - list( - config = c(config(...), content_type(type)), - curl_post = FALSE - ) -} - body_raw <- function(body, type = NULL) { if (!is.raw(body)) { body <- charToRaw(paste(body, collapse = "\n")) @@ -88,3 +74,9 @@ body_raw <- function(body, type = NULL) { base } + +body_httr <- function(..., type = NULL) { + list( + config = c(config(...), content_type(type)) + ) +} diff --git a/R/config.r b/R/config.r index 81335515..25b81d61 100644 --- a/R/config.r +++ b/R/config.r @@ -43,10 +43,10 @@ config <- function(...) { options <- list(...) - known <- c(RCurl::listCurlOptions(), "token", "writer") + known <- tolower(c(names(curl::curl_options()), "token", "writer")) unknown <- setdiff(names(options), known) if (length(unknown) > 0) { - stop("Unknown RCurl options: ", paste0(unknown, collapse = ", ")) + stop("Unknown curl options: ", paste0(unknown, collapse = ", ")) } # Clean up duplicated options @@ -96,16 +96,15 @@ is.config <- function(x) inherits(x, "config") #' curl_docs("CURLOPT_USERPWD") httr_options <- function(matches) { - constants <- RCurl::getCurlOptionsConstants() + constants <- curl::curl_options() constants <- constants[order(names(constants))] - rcurl <- names(constants) - curl <- translate_curl(http://github.com/rcurl) + rcurl <- tolower(names(constants)) opts <- data.frame( httr = rcurl, libcurl = translate_curl(http://github.com/rcurl), - type = unname(RCurl::getCurlOptionTypes(constants)), + type = curl_option_types(constants), stringsAsFactors = FALSE ) @@ -118,6 +117,13 @@ httr_options <- function(matches) { opts } +curl_option_types <- function(opts = curl::curl_options()) { + type_name <- c("integer", "string", "function", "number") + type <- floor(opts / 10000) + + type_name[type + 1] +} + #' @export print.opts_list <- function(x, ...) { cat(paste0(format(names(x)), ": ", x, collapse = "\n"), "\n", sep = "") @@ -194,7 +200,7 @@ default_config <- function() { c(config( followlocation = TRUE, maxredirs = 10L, - encoding = "gzip" + accept_encoding = "gzip" ), user_agent(default_ua()), add_headers(Accept = "application/json, text/xml, application/xml, */*"), @@ -206,7 +212,7 @@ default_config <- function() { default_ua <- function() { versions <- c( - curl = RCurl::curlVersion()$version, + curl = curl::curl_version()$version, Rcurl = as.character(packageVersion("RCurl")), httr = as.character(packageVersion("httr")) ) diff --git a/R/cookies.r b/R/cookies.r index f52f3ca7..ac6f2ab6 100644 --- a/R/cookies.r +++ b/R/cookies.r @@ -15,7 +15,7 @@ set_cookies <- function(..., .cookies = character(0)) { cookies <- c(..., .cookies) stopifnot(is.character(cookies)) - cookies_str <- vapply(cookies, RCurl::curlEscape, FUN.VALUE = character(1)) + cookies_str <- vapply(cookies, curl::curl_escape, FUN.VALUE = character(1)) cookie <- paste(names(cookies), cookies_str, sep = "=", collapse = ";") @@ -37,13 +37,5 @@ cookies.response <- function(x) x$cookies #' @export cookies.handle <- function(x) { - raw <- RCurl::getCurlInfo(x$handle, "cookielist")[[1]] - if (length(raw) == 0) return(list()) - - parsed <- read.delim(text = raw, sep = "\t", header = FALSE, - stringsAsFactors = FALSE) - names(parsed) <- c("domain", "tailmatch", "path", "secure", "expires", "name", - "value") - - stats::setNames(as.list(parsed$value), parsed$name) + curl::handle_cookies(x$handle) } diff --git a/R/doctor.R b/R/doctor.R index fe59c580..0a7a5448 100644 --- a/R/doctor.R +++ b/R/doctor.R @@ -8,7 +8,7 @@ brew_dr <- function() { } check_for_nss <- function() { - if (!grepl("^NSS", RCurl::curlVersion()$ssl_version)) return() + if (!grepl("^NSS", curl::curl_version()$ssl_version)) return() warning(' ------------------------------------------------------------------------ diff --git a/R/handle.r b/R/handle.r index d295618b..a075580b 100644 --- a/R/handle.r +++ b/R/handle.r @@ -39,12 +39,3 @@ ref <- function(x) { } is.handle <- function(x) inherits(x, "handle") - -reset_handle_config <- function(handle, config) { - # Calls curl_easy_reset (http://curl.haxx.se/libcurl/c/curl_easy_reset.html) - # Does not change live connections, session ID cache, DNS cache, cookies - # or shares. - curl::handle_reset(handle) - invisible(TRUE) -} - diff --git a/R/http--request.r b/R/http--request.r index a52d36e6..c1c220b6 100644 --- a/R/http--request.r +++ b/R/http--request.r @@ -43,20 +43,3 @@ make_request <- function(method, handle, url, config = NULL, body = NULL, res } } - -last_request <- function(x) { - stopifnot(is.handle(x)) - RCurl::getCurlInfo(x[[1]]) -} - -request_times <- function(x) { - req <- last_request(x) - - c(redirect = req$redirect.time, - namelookup = req$namelookup.time, - connect = req$connect.time, - pretransfer = req$pretransfer.time, - starttransfer = req$starttransfer.time, - total = req$total.time) - -} diff --git a/R/perform.R b/R/perform.R index 94f1f370..03ea9f63 100644 --- a/R/perform.R +++ b/R/perform.R @@ -1,3 +1,4 @@ + # Abstract over the differences in RCurl API depending on whether or not # you send a body. perform <- function(handle, writer, method, opts, body) { @@ -10,31 +11,22 @@ perform <- function(handle, writer, method, opts, body) { body = body ) - headers <- character() - add_header <- function(text) { - headers <<- c(headers, text) - nchar(text, "bytes") - } - opts$headerfunction <- add_header - - writer <- write_init(writer) - opts <- modifyList(opts, write_opts(writer)) +# writer <- write_init(writer) +# opts <- modifyList(opts, write_opts(writer)) + # Set handle options opts <- modify_config(body$config, opts) - # Ensure config always gets reset - on.exit(reset_handle_config(handle, opts), add = TRUE) - curl_opts <- RCurl::curlSetOpt(curl = NULL, .opts = opts) + browser() + do.call(curl::handle_setopt, c(list(handle$handle), opts)) + on.exit(curl::handle_reset(handle$handle), add = TRUE) - if (isTRUE(body$curl_post)) { - RCurl::.postForm(handle$handle, curl_opts, body$body, body$style) - # Reset curl options that RCurl sets - RCurl::curlSetOpt(httppost = NULL, post = NULL, postfields = NULL, - curl = handle$handle) - } else { - RCurl::curlPerform(curl = handle$handle, .opts = curl_opts$values) - } - headers <- parse_headers(headers) + if (isTRUE(body$curl_post)) + do.call(curl::handle_setform, c(list(handle$handle), body)) + + res <- curl::curl_perform(handle = handle$handle) + + headers <- curl::parse_headers(res$headers, multiple = TRUE) content <- write_term(writer) if (!is.null(headers$date)) { @@ -44,61 +36,15 @@ perform <- function(handle, writer, method, opts, body) { } response( - url = last_request(handle)$effective.url, - status_code = last(headers)$status, - headers = last(headers)$headers, + url = res$url, + status_code = res$status_code, + headers = last(headers), all_headers = headers, - cookies = cookies(handle), + cookies = curl::handle_cookies(handle), content = content, date = date, - times = request_times(handle), + times = res$times, request = request ) } - - -# http://www.w3.org/Protocols/rfc2616/rfc2616-sec6.html - -# Parses a header lines as recieved from libcurl. Multiple responses -# will be intermingled, each separated by an http status line. -parse_headers <- function(lines) { - lines <- gsub("\r?\n$", "", lines) - - new_response <- grepl("^HTTP", lines) - grps <- cumsum(new_response) - - lapply(unname(split(lines, grps)), parse_single_header) -} - -parse_single_header <- function(lines) { - status <- parse_http_status(lines[[1]]) - - # Parse headers into name-value pairs - header_lines <- lines[lines != ""][-1] - pos <- regexec("^([^:]*):\\s*(.*)$", header_lines) - pieces <- regmatches(header_lines, pos) - - n <- vapply(pieces, length, integer(1)) - if (any(n != 3)) { - bad <- header_lines[n != 3] - pieces <- pieces[n == 3] - - warning("Failed to parse headers:\n", paste0(bad, "\n"), call. = FALSE) - } - - names <- vapply(pieces, "[[", 2, FUN.VALUE = character(1)) - values <- lapply(pieces, "[[", 3) - headers <- insensitive(stats::setNames(values, names)) - - list(status = status$status, version = status$version, headers = headers) -} - -parse_http_status <- function(x) { - status <- as.list(strsplit(x, "\\s+")[[1]]) - names(status) <- c("version", "status", "message")[seq_along(status)] - status$status <- as.integer(status$status) - - - status -} diff --git a/R/request.R b/R/request.R new file mode 100644 index 00000000..96642951 --- /dev/null +++ b/R/request.R @@ -0,0 +1,130 @@ +request <- function(method = "GET", url = NA_character_, headers = character(), + fields = list(), + options = character(), auth_token = NULL, + output = c("memory", "file", "stream")) { + stopifnot(is.character(method), length(method) == 1) + stopifnot(is.character(url), length(url) == 1) + stopifnot(is.character(headers)) + output <- match.arg(output) + + structure( + list( + method = toupper(method), + url = url, + headers = keep_last(headers), + fields = fields, + options = compact(keep_last(options)), + auth_token = auth_token, + output = output + ), + class = "request" + ) +} + +request_default <- function() { + cert <- system.file("cacert.pem", package = "httr") + request( + options = list( + followlocation = TRUE, + maxredirs = 10L, + accept_encoding = "gzip", + useragent = default_ua(), + if (.Platform$OS.type == "windows") config(cainfo = cert), + getOption("httr_config") + ), + headers = c(Accept = "application/json, text/xml, application/xml, */*") + ) +} + +is.request <- function(x) inherits(x, "request") + +combine_requests <- function(x, y) { + stopifnot(is.request(x), is.request(y)) + + request( + y$method, + y$url, + keep_last(x$headers, y$headers), + c(x$fields, y$fields), + keep_last(x$options, y$options), + y$output + ) +} + +#' @export +c.request <- function(...) { + Reduce(combine_requests, list(...)) +} + +#' @export +print.request <- function(x, ...) { + x <- request_build(x) + + cat(x$method, " ", x$url, " -> ", x$output, "\n", sep = "") + named_vector("Options", x$options) + named_vector("Headers", x$headers) + named_vector("Fields", x$fields) +} + +named_vector <- function(title, x) { + if (length(x) == 0) return() + + cat(title, ":\n", sep = "") + bullets <- paste0("* ", names(x), ": ", as.character(x)) + cat(bullets, sep = "\n") +} + +keep_last <- function(...) { + x <- c(...) + x[!duplicated(names(x), fromLast = TRUE)] +} + + +request_build <- function(req) { + req <- c(request_default(), req) + + if (req$method != "POST") + req$options$customrequest <- req$method + + # Sign request, if needed + if (!is.null(req$token)) + req <- c(req, req$token$sign(req$method, req$url)) + + req +} + +# Abstract over the differences in RCurl API depending on whether or not +# you send a body. +httr_perform <- function(req, handle) { + stopifnot(is.request(req), inherits(handle, "curl_handle")) + req <- request_build(req) + + # Set handle options + do.call(curl::handle_setopt, c(list(handle), req$options)) + do.call(curl::handle_setheaders, c(list(handle), req$headers)) + do.call(curl::handle_setfields, c(list(handle), req$fields)) + on.exit(curl::handle_reset(handle), add = TRUE) + + resp <- curl::curl_perform(req$url, handle) + + all_headers <- curl::parse_headers(resp$headers, multiple = TRUE) + headers <- last(all_headers) + if (!is.null(headers$date)) { + date <- parse_http_date(headers$Date) + } else { + date <- Sys.time() + } + + response( + url = res$url, + status_code = res$status_code, + headers = headers, + all_headers = all_headers, + cookies = curl::handle_cookies(handle), + content = content, + date = date, + times = res$times, + request = request + ) +} + diff --git a/R/upload-file.r b/R/upload-file.r index 41f7a07a..9fa4e356 100644 --- a/R/upload-file.r +++ b/R/upload-file.r @@ -1,16 +1,21 @@ #' Upload a file with \code{\link{POST}} or \code{\link{PUT}}. #' -#' This is a tiny wrapper for \pkg{RCurl}'s \code{\link[RCurl]{fileUpload}}. -#' #' @param path path to file #' @param type mime type of path. If not supplied, will be guess by #' \code{\link[mime]{guess_type}} when needed. #' @export #' @examples -#' POST("http://httpbin.org/post", -#' body = list(y = upload_file(system.file("CITATION")))) +#' citation <- upload_file(system.file("CITATION")) +#' POST("http://httpbin.org/post", body = citation) +#' POST("http://httpbin.org/post", body = list(y = citation)) upload_file <- function(path, type = NULL) { - stopifnot(is.character(path), length(path) == 1) - RCurl::fileUpload(path, contentType = type) + stopifnot(is.character(path), length(path) == 1, file.exists(path)) + + if (is.null(type)) + type <- mime::guess_type(path) + + structure(list(path = path, type = type), class = "upload_file") } +#' @export +as.character.upload_file <- function(x) x diff --git a/R/url-query.r b/R/url-query.r index 934a606c..3019fad9 100644 --- a/R/url-query.r +++ b/R/url-query.r @@ -2,8 +2,8 @@ parse_query <- function(query) { params <- vapply(strsplit(query, "&")[[1]], str_split_fixed, "=", 2, FUN.VALUE = character(2)) - values <- as.list(RCurl::curlUnescape(params[2, ])) - names(values) <- RCurl::curlUnescape(params[1, ]) + values <- as.list(curl::curl_unescape(params[2, ])) + names(values) <- curl::curl_unescape(params[1, ]) values } @@ -14,10 +14,10 @@ compose_query <- function(elements) { encode <- function(x) { if (inherits(x, "AsIs")) return(x) - RCurl::curlEscape(x) + curl::curl_escape(x) } - names <- RCurl::curlEscape(names(elements)) + names <- curl::curl_escape(names(elements)) values <- vapply(elements, encode, character(1)) paste0(names, "=", values, collapse = "&") diff --git a/R/url.r b/R/url.r index 2ea61515..18213854 100644 --- a/R/url.r +++ b/R/url.r @@ -117,8 +117,8 @@ build_url <- function(url) { if (is.list(url$query)) { url$query <- compact(url$query) - names <- RCurl::curlEscape(names(url$query)) - values <- RCurl::curlEscape(url$query) + names <- curl::curl_escape(names(url$query)) + values <- curl::curl_escape(url$query) query <- paste0(names, "=", values, collapse = "&") } else { diff --git a/R/utils.r b/R/utils.r index c4a2374c..f4cb2cb6 100644 --- a/R/utils.r +++ b/R/utils.r @@ -6,17 +6,13 @@ timestamp <- function(x = Sys.time()) { format(x, "%Y-%m-%dT%H:%M:%SZ", tz = "UTC") } -sort_names <- function(x) x[order(names(x))] +sort_names <- function(x) x[order(names(x))] nonce <- function(length = 10) { paste(sample(c(letters, LETTERS, 0:9), length, replace = TRUE), collapse = "") } -curl_version <- function() { - as.numeric_version(RCurl::curlVersion()$version) -} - has_env_var <- function(x) !identical(Sys.getenv(x), "") named <- function(x) x[has_names(x)] @@ -53,3 +49,8 @@ compact <- function(x) { null <- vapply(x, is.null, logical(1)) x[!null] } + +keep_last <- function(...) { + x <- c(...) + x[!duplicated(names(x), fromLast = TRUE)] +} From 8549fd531d30a38746b82ce1a2d5418168fb5783 Mon Sep 17 00:00:00 2001 From: hadley Date: Thu, 7 May 2015 14:58:39 -0500 Subject: [PATCH 4/5] Require latest curl --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index fcec91e3..7bbec1ff 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -15,7 +15,7 @@ Imports: jsonlite, methods, mime, - curl (>= 0.5.99), + curl (>= 0.5.9001), R6, stringr (>= 0.6.1) Suggests: From 9e762211c3ce09071ce11a90d2cb923eca7c4e85 Mon Sep 17 00:00:00 2001 From: hadley Date: Mon, 11 May 2015 15:01:46 -0500 Subject: [PATCH 5/5] WIP --- NAMESPACE | 22 +----- NEWS.md | 11 +++ R/body.R | 13 +--- R/config.r | 57 +-------------- R/doctor.R | 2 +- R/handle.r | 9 ++- R/headers.r | 54 +++++++++++--- R/http--request.r | 6 -- R/http-delete.r | 5 +- R/http-get.r | 5 +- R/http-head.r | 5 +- R/http-post.r | 6 +- R/perform.R | 50 ------------- R/progress.R | 7 +- R/request.R | 128 +++++++++++++++++---------------- R/safe-callback.R | 29 ++------ R/timeout.r | 2 +- R/url.r | 2 +- R/utils.r | 27 ++++++- R/verbose.r | 7 +- R/write-function.R | 124 +++++++------------------------- man/handle.Rd | 3 +- man/{brew_dr.Rd => httr_dr.Rd} | 6 +- man/safe_callback.Rd | 13 +--- man/upload_file.Rd | 7 +- man/write_function.Rd | 19 ----- man/write_stream.Rd | 8 ++- src/.gitignore | 3 - src/writer.c | 47 ------------ 29 files changed, 224 insertions(+), 453 deletions(-) delete mode 100644 R/perform.R rename man/{brew_dr.Rd => httr_dr.Rd} (83%) delete mode 100644 src/.gitignore delete mode 100644 src/writer.c diff --git a/NAMESPACE b/NAMESPACE index d1e8e6df..e8cab28d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -4,6 +4,7 @@ S3method("$",insensitive) S3method("[",insensitive) S3method("[[",insensitive) S3method(as.character,response) +S3method(as.character,upload_file) S3method(c,config) S3method(cookies,handle) S3method(cookies,response) @@ -15,21 +16,10 @@ S3method(print,handle) S3method(print,oauth_app) S3method(print,oauth_endpoint) S3method(print,opts_list) +S3method(print,request) S3method(print,response) -S3method(print,write_disk) -S3method(print,write_memory) -S3method(print,write_stream) S3method(status_code,numeric) S3method(status_code,response) -S3method(write_init,write_disk) -S3method(write_init,write_memory) -S3method(write_init,write_stream) -S3method(write_opts,write_disk) -S3method(write_opts,write_memory) -S3method(write_opts,write_stream) -S3method(write_term,write_disk) -S3method(write_term,write_memory) -S3method(write_term,write_stream) export(BROWSE) export(DELETE) export(GET) @@ -47,7 +37,6 @@ export(accept_json) export(accept_xml) export(add_headers) export(authenticate) -export(brew_dr) export(build_url) export(cache_info) export(config) @@ -67,6 +56,7 @@ export(hmac_sha1) export(http_condition) export(http_date) export(http_status) +export(httr_dr) export(httr_options) export(init_oauth1.0) export(init_oauth2.0) @@ -111,13 +101,7 @@ export(with_config) export(with_verbose) export(write_disk) export(write_function) -export(write_init) export(write_memory) -export(write_opts) export(write_stream) -export(write_term) import(stringr) importFrom(R6,R6Class) -useDynLib(httr,close_file) -useDynLib(httr,write_callback) -useDynLib(httr,writer) diff --git a/NEWS.md b/NEWS.md index d50b9ded..4588d3f9 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,16 @@ # httr 0.6.1.9000 +* `cookies` argument to `handle()` is deprecated + +* `brew_dr()` renamed to `httr_dr()` + +* Uses `CURL_CA_BUNDLE` environment variable to look for cert bundle on + Windows (#223). + +* `safe_callback()` is deprecated - it's no longer needed with curl. + +* RCurl has been replaced by curl by Jeroen Ooms. + * `config()` and `c.config()` now clean up duplicated options (#213). * `POST()` and `PUT()` now clean up after themselves when uploading a single diff --git a/R/body.R b/R/body.R index 358312ab..90e589fc 100644 --- a/R/body.R +++ b/R/body.R @@ -41,30 +41,21 @@ body_config <- function(body = NULL, encode = "form", type = NULL) { } else if (encode == "json") { body_raw(jsonlite::toJSON(body, auto_unbox = TRUE), "application/json") } else if (encode == "multipart") { - # For multipart, rely on curl::handle_setform body <- lapply(body, as.character) stopifnot(length(names(body)) > 0) - body_rcurl(http://github.com/body) + request(fields = body) } else { stop("Unknown encoding", call. = FALSE) } } - -body_rcurl <- function(body = NULL) { - list( - config = NULL, - body = body, - curl_post = TRUE - ) -} - body_raw <- function(body, type = NULL) { if (!is.raw(body)) { body <- charToRaw(paste(body, collapse = "\n")) } + request() base <- body_httr( post = TRUE, postfieldsize = length(body), diff --git a/R/config.r b/R/config.r index 25b81d61..37a9deb3 100644 --- a/R/config.r +++ b/R/config.r @@ -41,27 +41,7 @@ #' # in config #' HEAD("https://www.google.com/", config(verbose = TRUE)) config <- function(...) { - options <- list(...) - - known <- tolower(c(names(curl::curl_options()), "token", "writer")) - unknown <- setdiff(names(options), known) - if (length(unknown) > 0) { - stop("Unknown curl options: ", paste0(unknown, collapse = ", ")) - } - - # Clean up duplicated options - headers <- names(options) == "httpheader" - if (any(headers)) { - all_headers <- unlist(unname(options[headers])) - all_headers <- all_headers[!duplicated(names(all_headers), fromLast = TRUE)] - - options <- options[!headers] - options[["httpheader"]] <- all_headers - } - options <- options[!duplicated(names(options), fromLast = TRUE)] - - class(options) <- "config" - options + request(options = list(...)) } is.config <- function(x) inherits(x, "config") @@ -150,21 +130,6 @@ curl_docs <- function(x) { BROWSE(url) } -# Grepping http://curl.haxx.se/libcurl/c/curl_easy_setopt.html for -# "linked list", finds the follow options: -# -# CURLOPT_HTTPHEADER -# CURLOPT_HTTPPOST -# CURLOPT_HTTP200ALIASES -# CURLOPT_MAIL_RCPT -# CURLOPT_QUOTE -# CURLOPT_POSTQUOTE -# CURLOPT_PREQUOTE -# CURLOPT_RESOLVE -# -# Of these, only CURLOPT_HTTPHEADER is likely ever to be used, so we'll -# deal with it specially. It's possible you might also want to do that -# with cookies, but that would require a bigger rewrite. #' @export c.config <- function(...) { Reduce(modify_config, list(...)) @@ -194,26 +159,10 @@ make_config <- function(x, ...) { structure(Reduce(modify_config, configs), class = "config") } -default_config <- function() { - cert <- system.file("cacert.pem", package = "httr") - - c(config( - followlocation = TRUE, - maxredirs = 10L, - accept_encoding = "gzip" - ), - user_agent(default_ua()), - add_headers(Accept = "application/json, text/xml, application/xml, */*"), - write_memory(), - if (.Platform$OS.type == "windows") config(cainfo = cert), - getOption("httr_config") - ) -} - default_ua <- function() { versions <- c( - curl = curl::curl_version()$version, - Rcurl = as.character(packageVersion("RCurl")), + libcurl = curl::curl_version()$version, + `r-curl` = as.character(packageVersion("curl")), httr = as.character(packageVersion("httr")) ) paste0(names(versions), "/", versions, collapse = " ") diff --git a/R/doctor.R b/R/doctor.R index 0a7a5448..4f186556 100644 --- a/R/doctor.R +++ b/R/doctor.R @@ -3,7 +3,7 @@ #' Currently one check: that curl uses nss. #' #' @export -brew_dr <- function() { +httr_dr <- function() { check_for_nss() } diff --git a/R/handle.r b/R/handle.r index a075580b..35b82dad 100644 --- a/R/handle.r +++ b/R/handle.r @@ -5,8 +5,7 @@ #' it will mostly be hidden from the user. #' #' @param url full url to site -#' @param cookies if \code{TRUE} (the default), maintain cookies across -#' requests. +#' @param cookies DEPRECATED #' @export #' @examples #' handle("http://google.com/") @@ -22,10 +21,10 @@ handle <- function(url, cookies = TRUE) { stopifnot(is.character(url), length(url) == 1) - url <- parse_http://github.com/url(url) - cookie_path <- if (cookies) tempfile() else NULL + if (!missing(cookies)) + warning("Cookies argument is depcrated", call. = FALSE) - h <- curl::new_handle(cookiefile = cookie_path) + h <- curl::new_handle() structure(list(handle = h, url = url), class = "handle") } diff --git a/R/headers.r b/R/headers.r index a5e0c7f9..1142534e 100644 --- a/R/headers.r +++ b/R/headers.r @@ -39,14 +39,7 @@ headers.response <- function(x) { #' # Override default headers with empty strings #' GET("http://httpbin.org/headers", add_headers(Accept = "")) add_headers <- function(..., .headers = character()) { - headers <- c(..., .headers) - if (length(headers) == 0) return() - stopifnot(is.character(headers)) - - # Keep last of duplicated headers - headers <- headers[!duplicated(names(headers), fromLast = TRUE)] - - config(httpheader = headers) + request(headers = c(..., .headers)) } @@ -109,3 +102,48 @@ accept_json <- function() accept("application/json") #' @rdname content_type accept_xml <- function() accept("application/xml") + + + +# Parses a header lines as recieved from libcurl. Multiple responses +# will be intermingled, each separated by an http status line. +parse_headers <- function(raw) { + lines <- strsplit(rawToChar(raw), "\r?\n")[[1]] + + new_response <- grepl("^HTTP", lines) + grps <- cumsum(new_response) + + lapply(unname(split(lines, grps)), parse_single_header) +} + +parse_single_header <- function(lines) { + status <- parse_http_status(lines[[1]]) + + # Parse headers into name-value pairs + header_lines <- lines[lines != ""][-1] + pos <- regexec("^([^:]*):\\s*(.*)$", header_lines) + pieces <- regmatches(header_lines, pos) + + n <- vapply(pieces, length, integer(1)) + if (any(n != 3)) { + bad <- header_lines[n != 3] + pieces <- pieces[n == 3] + + warning("Failed to parse headers:\n", paste0(bad, "\n"), call. = FALSE) + } + + names <- vapply(pieces, "[[", 2, FUN.VALUE = character(1)) + values <- lapply(pieces, "[[", 3) + headers <- insensitive(stats::setNames(values, names)) + + list(status = status$status, version = status$version, headers = headers) +} + +parse_http_status <- function(x) { + status <- as.list(strsplit(x, "\\s+")[[1]]) + names(status) <- c("version", "status", "message")[seq_along(status)] + status$status <- as.integer(status$status) + + + status +} diff --git a/R/http--request.r b/R/http--request.r index c1c220b6..8be5b082 100644 --- a/R/http--request.r +++ b/R/http--request.r @@ -6,12 +6,6 @@ make_request <- function(method, handle, url, config = NULL, body = NULL, stopifnot(is.handle(handle)) stopifnot(is.character(url), length(url) == 1) - # Combine with default config - opts <- modify_config(default_config(), config) - if (method != "POST") { - opts$customrequest <- method - } - # Sign request, if needed token <- opts$token if (!is.null(token)) { diff --git a/R/http-delete.r b/R/http-delete.r index 35488e0b..28c9849a 100644 --- a/R/http-delete.r +++ b/R/http-delete.r @@ -28,7 +28,6 @@ #' POST("http://httpbin.org/delete") DELETE <- function(url = NULL, config = list(), ..., handle = NULL) { hu <- handle_url(http://github.com/handle,%20url,%20...) - config <- make_config(config, ...) - - make_request("delete", hu$handle, hu$url, config) + req <- request_build("DELETE", hu$url, config, ...) + request_perform(req, hu$handle$handle) } diff --git a/R/http-get.r b/R/http-get.r index c6b17e55..202b2672 100644 --- a/R/http-get.r +++ b/R/http-get.r @@ -63,7 +63,6 @@ #' GET(handle = google, path = "search") GET <- function(url = NULL, config = list(), ..., handle = NULL) { hu <- handle_url(http://github.com/handle,%20url,%20...) - config <- make_config(config, ...) - - make_request("get", hu$handle, hu$url, config) + req <- request_build("GET", hu$url, config, ...) + request_perform(req, hu$handle$handle) } diff --git a/R/http-head.r b/R/http-head.r index ada18d7a..6a106327 100644 --- a/R/http-head.r +++ b/R/http-head.r @@ -24,7 +24,6 @@ #' HEAD("http://google.com/")$headers HEAD <- function(url = NULL, config = list(), ..., handle = NULL) { hu <- handle_url(http://github.com/handle,%20url,%20...) - config <- make_config(config, ..., list(nobody = TRUE)) - - make_request("head", hu$handle, hu$url, config) + req <- request_build("HEAD", hu$url, config, ..., config(nobody = TRUE)) + request_perform(req, hu$handle$handle) } diff --git a/R/http-post.r b/R/http-post.r index bceaf007..289fedc3 100644 --- a/R/http-post.r +++ b/R/http-post.r @@ -51,8 +51,6 @@ POST <- function(url = NULL, config = list(), ..., body = NULL, encode <- match.arg(encode) hu <- handle_url(http://github.com/handle,%20url,%20...) - config <- make_config(config, ...) - - make_request("post", hu$handle, hu$url, config, - body_config(body, encode)) + req <- request_build("POST", hu$url, config, ..., body_config(body, encode)) + request_perform(req, hu$handle$handle) } diff --git a/R/perform.R b/R/perform.R deleted file mode 100644 index 03ea9f63..00000000 --- a/R/perform.R +++ /dev/null @@ -1,50 +0,0 @@ - -# Abstract over the differences in RCurl API depending on whether or not -# you send a body. -perform <- function(handle, writer, method, opts, body) { - # Cache exact request so it can easily be replayed. - request <- list( - handle = handle, - writer = writer, - method = toupper(method), - opts = opts, - body = body - ) - -# writer <- write_init(writer) -# opts <- modifyList(opts, write_opts(writer)) - - # Set handle options - opts <- modify_config(body$config, opts) - browser() - do.call(curl::handle_setopt, c(list(handle$handle), opts)) - on.exit(curl::handle_reset(handle$handle), add = TRUE) - - - if (isTRUE(body$curl_post)) - do.call(curl::handle_setform, c(list(handle$handle), body)) - - res <- curl::curl_perform(handle = handle$handle) - - headers <- curl::parse_headers(res$headers, multiple = TRUE) - content <- write_term(writer) - - if (!is.null(headers$date)) { - date <- parse_http_date(headers$Date) - } else { - date <- Sys.time() - } - - response( - url = res$url, - status_code = res$status_code, - headers = last(headers), - all_headers = headers, - cookies = curl::handle_cookies(handle), - content = content, - date = date, - times = res$times, - request = request - ) -} - diff --git a/R/progress.R b/R/progress.R index 8392b52f..c51a67b7 100644 --- a/R/progress.R +++ b/R/progress.R @@ -13,7 +13,10 @@ progress <- function(type = c("down", "up")) { type <- match.arg(type) - config(noprogress = FALSE, progressfunction = progress_bar(type)) + request(options = list( + noprogress = FALSE, + progressfunction = progress_bar(type) + )) } progress_bar <- function(type) { @@ -53,7 +56,7 @@ progress_bar <- function(type) { 0L } - safe_callback(show_progress) + show_progress } diff --git a/R/request.R b/R/request.R index 96642951..f48833c7 100644 --- a/R/request.R +++ b/R/request.R @@ -1,15 +1,20 @@ -request <- function(method = "GET", url = NA_character_, headers = character(), - fields = list(), - options = character(), auth_token = NULL, - output = c("memory", "file", "stream")) { - stopifnot(is.character(method), length(method) == 1) - stopifnot(is.character(url), length(url) == 1) - stopifnot(is.character(headers)) - output <- match.arg(output) +request <- function(method = NULL, url = NULL, headers = NULL, + fields = NULL, options = NULL, auth_token = NULL, + output = NULL) { + if (!is.null(method)) + stopifnot(is.character(method), length(method) == 1) + if (!is.null(url)) + stopifnot(is.character(url), length(url) == 1) + if (!is.null(headers)) + stopifnot(is.character(headers)) + if (!is.null(fields)) + stopifnot(is.list(fields)) + if (!is.null(output)) + stopifnot(inherits(output, "write_function")) structure( list( - method = toupper(method), + method = method, url = url, headers = keep_last(headers), fields = fields, @@ -20,68 +25,69 @@ request <- function(method = "GET", url = NA_character_, headers = character(), class = "request" ) } +is.request <- function(x) inherits(x, "request") request_default <- function() { - cert <- system.file("cacert.pem", package = "httr") request( options = list( - followlocation = TRUE, - maxredirs = 10L, - accept_encoding = "gzip", useragent = default_ua(), - if (.Platform$OS.type == "windows") config(cainfo = cert), + cainfo = find_cert_bundle(), getOption("httr_config") ), - headers = c(Accept = "application/json, text/xml, application/xml, */*") + headers = c(Accept = "application/json, text/xml, application/xml, */*"), + output = write_function("write_memory") ) } -is.request <- function(x) inherits(x, "request") +as.request <- function(x) UseMethod("as.request") +as.request.list <- function(x) structure(x, class = "request") +as.request.request <- function(x) x + +request_build <- function(method, url, config = list(), ...) { + extra <- list(...) + extra[has_names(extra)] <- NULL + + req <- Reduce(request_combine, extra) + if (!identical(config, list)) + req <- request_combine(as.request(config), req) + + req$method <- method + req$url <- url -combine_requests <- function(x, y) { + req +} + +request_combine <- function(x, y) { + if (length(x) == 0 && length(y) == 0) return(request()) + if (length(x) == 0) return(y) + if (length(y) == 0) return(x) stopifnot(is.request(x), is.request(y)) request( - y$method, - y$url, - keep_last(x$headers, y$headers), - c(x$fields, y$fields), - keep_last(x$options, y$options), - y$output + method = y$method %||% x$method, + url = y$url %||% x$url, + headers = keep_last(x$headers, y$headers), + fields = c(x$fields, y$fields), + options = keep_last(x$options, y$options), + auth_token = y$auth_token %||% x$auth_token, + output = y$output %||% x$output ) } -#' @export -c.request <- function(...) { - Reduce(combine_requests, list(...)) -} - #' @export print.request <- function(x, ...) { - x <- request_build(x) - - cat(x$method, " ", x$url, " -> ", x$output, "\n", sep = "") + cat("\n") + if (!is.null(x$method) && !is.null(x$url)) + cat(toupper(x$method), " ", x$url, "\n", sep = "") + if (!is.null(x$output)) + cat("Output: ", class(x$output)[[1]], "\n", sep = "") named_vector("Options", x$options) named_vector("Headers", x$headers) named_vector("Fields", x$fields) } -named_vector <- function(title, x) { - if (length(x) == 0) return() - - cat(title, ":\n", sep = "") - bullets <- paste0("* ", names(x), ": ", as.character(x)) - cat(bullets, sep = "\n") -} - -keep_last <- function(...) { - x <- c(...) - x[!duplicated(names(x), fromLast = TRUE)] -} - - -request_build <- function(req) { - req <- c(request_default(), req) +request_prepare <- function(req) { + req <- request_combine(request_default(), req) if (req$method != "POST") req$options$customrequest <- req$method @@ -93,22 +99,20 @@ request_build <- function(req) { req } -# Abstract over the differences in RCurl API depending on whether or not -# you send a body. -httr_perform <- function(req, handle) { +request_perform <- function(req, handle) { stopifnot(is.request(req), inherits(handle, "curl_handle")) - req <- request_build(req) + req <- request_prepare(req) - # Set handle options - do.call(curl::handle_setopt, c(list(handle), req$options)) - do.call(curl::handle_setheaders, c(list(handle), req$headers)) - do.call(curl::handle_setfields, c(list(handle), req$fields)) + browser() + curl::handle_setopt(handle, .list = req$options) + curl::handle_setheaders(handle, .list = req$headers) + curl::handle_setform(handle, .list = req$fields) on.exit(curl::handle_reset(handle), add = TRUE) - resp <- curl::curl_perform(req$url, handle) + resp <- request_fetch(req$output, req$url, handle) - all_headers <- curl::parse_headers(resp$headers, multiple = TRUE) - headers <- last(all_headers) + all_headers <- parse_headers(resp$headers) + headers <- last(all_headers)$headers if (!is.null(headers$date)) { date <- parse_http_date(headers$Date) } else { @@ -116,14 +120,14 @@ httr_perform <- function(req, handle) { } response( - url = res$url, - status_code = res$status_code, + url = resp$url, + status_code = resp$status_code, headers = headers, all_headers = all_headers, cookies = curl::handle_cookies(handle), - content = content, + content = resp$content, date = date, - times = res$times, + times = resp$times, request = request ) } diff --git a/R/safe-callback.R b/R/safe-callback.R index cdd367cd..8969b995 100644 --- a/R/safe-callback.R +++ b/R/safe-callback.R @@ -1,31 +1,10 @@ #' Generate a safe R callback. #' -#' Whenever an R callback function is passed to Rcurl, it needs to be wrapped -#' in this handler which converts errors and interrupts to the appropriate -#' values that cause RCurl to terminate a request -#' #' @param f A function. +#' @keywords deprecated #' @export -#' @examples -#' f1 <- function(x) { -#' if (x < 0) stop("Negative value") -#' sqrt(x) -#' } -#' f2 <- safe_callback(f1) -#' f2(-10) safe_callback <- function(f) { - force(f) - - function(...) { - tryCatch(f(...), - error = function(e, ...) { - message("Error:", e$message) - 1L - }, - interrupt = function(...) { - message("Interrupted by user") - 1L - } - ) - } + warning("`safe_callback()` is no longer needed and will be removed in a ", + "future version", call. = FALSE) + f } diff --git a/R/timeout.r b/R/timeout.r index 38f7306b..dacd4e0e 100644 --- a/R/timeout.r +++ b/R/timeout.r @@ -14,5 +14,5 @@ timeout <- function(seconds) { stop("Timeout cannot be less than 1 ms", call. = FALSE) } - config(timeout.ms = seconds * 1000) + config(timeout_ms = seconds * 1000) } diff --git a/R/url.r b/R/url.r index 18213854..8189b905 100644 --- a/R/url.r +++ b/R/url.r @@ -118,7 +118,7 @@ build_url <- function(url) { if (is.list(url$query)) { url$query <- compact(url$query) names <- curl::curl_escape(names(url$query)) - values <- curl::curl_escape(url$query) + values <- curl::curl_escape(as.character(url$query)) query <- paste0(names, "=", values, collapse = "&") } else { diff --git a/R/utils.r b/R/utils.r index f4cb2cb6..fd9253b3 100644 --- a/R/utils.r +++ b/R/utils.r @@ -22,7 +22,7 @@ has_names <- function(x) { nms <- names(x) if (is.null(nms)) return(rep(FALSE, length(x))) - names(x) != "" + is.na(names(x)) || names(x) != "" } travis_encrypt <- function(vars) { @@ -54,3 +54,28 @@ keep_last <- function(...) { x <- c(...) x[!duplicated(names(x), fromLast = TRUE)] } + +named_vector <- function(title, x) { + if (length(x) == 0) return() + + cat(title, ":\n", sep = "") + bullets <- paste0("* ", names(x), ": ", as.character(x)) + cat(bullets, sep = "\n") +} + +keep_last <- function(...) { + x <- c(...) + x[!duplicated(names(x), fromLast = TRUE)] +} + +find_cert_bundle <- function() { + if (.Platform$OS.type != "windows") + return() + + env <- Sys.getenv("CURL_CA_BUNDLE") + if (!identical(env, "")) { + env + } else { + system.file("cacert.pem", package = "httr") + } +} diff --git a/R/verbose.r b/R/verbose.r index 3c938ebd..e61eec15 100644 --- a/R/verbose.r +++ b/R/verbose.r @@ -51,7 +51,7 @@ #' POST_verbose("") #' POST_verbose("xyz") verbose <- function(data_out = TRUE, data_in = FALSE, info = FALSE, ssl = FALSE) { - debug <- function(msg, type, curl) { + debug <- function(type, msg) { switch(type + 1, text = if (info) prefix_message("* ", msg), headerIn = prefix_message("<- ", msg), @@ -59,11 +59,10 @@ verbose <- function(data_out = TRUE, data_in = FALSE, info = FALSE, ssl = FALSE) dataIn = if (data_in) prefix_message("<< ", msg, TRUE), dataOut = if (data_out) prefix_message(">> ", msg, TRUE), sslDataIn = if (data_in && ssl) prefix_message("*< ", msg, TRUE), - sslDataOut = if (data_out && ssl) prefix_message("*> ", msg, TRUE), + sslDataOut = if (data_out && ssl) prefix_message("*> ", msg, TRUE) ) - 0 } - config(debugfunction = safe_callback(debug), verbose = TRUE) + config(debugfunction = debug, verbose = TRUE) } prefix_message <- function(prefix, x, blank_line = FALSE) { diff --git a/R/write-function.R b/R/write-function.R index ddf65537..38e163b0 100644 --- a/R/write-function.R +++ b/R/write-function.R @@ -2,14 +2,6 @@ #' #' This S3 object allows you to control how the response body is saved. #' -#' There are three key methods: -#' \itemize{ -#' \item \code{write_init()}: called before the write is started. It should -#' return a modified object. -#' \item \code{write_opts()}: returns a list options passed on to RCurl -#' \item \code{write_term()}: called after the request is complete. -#' Should return the content (or a pointer to it) -#' } #' @param subclass,... Class name and fields. Used in class constructors. #' @param x A \code{write_function} object to process. #' @keywords internal @@ -17,17 +9,6 @@ write_function <- function(subclass, ...) { structure(list(...), class = c(subclass, "write_function")) } -#' @export -#' @rdname write_function -write_init <- function(x) UseMethod("write_init") -#' @export -#' @rdname write_function -write_opts <- function(x) UseMethod("write_opts") -#' @export -#' @rdname write_function -write_term <- function(x) UseMethod("write_term") - -# Disk ------------------------------------------------------------------------- #' Control where the response body is written. #' @@ -39,7 +20,6 @@ write_term <- function(x) UseMethod("write_term") #' @param path Path to content to. #' @param overwrite Will only overwrite existing \code{path} if TRUE. #' @export -#' @useDynLib httr writer #' @examples #' tmp <- tempfile() #' r1 <- GET("https://www.google.com/", write_disk(tmp)) @@ -57,68 +37,13 @@ write_disk <- function(path, overwrite = FALSE) { if (!overwrite && file.exists(path)) { stop("Path exists and overwrite is FALSE", call. = FALSE) } - config( - writer = write_function("write_disk", path = path, file = NULL) - ) -} -#' @export -write_init.write_disk <- function(x) { - x$file <- RCurl::CFILE(x$path, "wb") - x -} -#' @export -write_opts.write_disk <- function(x) { - list( - writefunction = writer$address, - writedata = x$file@ref - ) -} -#' @export -#' @useDynLib httr close_file -write_term.write_disk <- function(x) { - .Call(close_file, x$file@ref) - x$file <- NULL - path(x$path) -} -#' @export -print.write_disk <- function(x, ...) { - cat(" ", x$path, "\n", sep = "") + request(output = write_function("write_disk", path = path, file = NULL)) } -path <- function(x) structure(x, class = "path") -#' @export -length.path <- function(x) file.info(x)$size -is.path <- function(x) inherits(x, "path") - -# Memory ----------------------------------------------------------------------- - #' @rdname write_disk #' @export write_memory <- function() { - config( - writer = write_function("write_memory", buffer = NULL) - ) -} -#' @export -print.write_memory <- function(x, ...) { - cat("\n") -} - -#' @export -write_init.write_memory <- function(x) { - x$buffer <- RCurl::binaryBuffer() - x -} -#' @export -write_opts.write_memory <- function(x) { - list( - writefunction = getNativeSymbolInfo("R_curl_write_binary_data")$address, - writedata = x$buffer@ref - ) -} -#' @export -write_term.write_memory <- function(x) { - methods::as(x$buffer, "raw") + request(output = write_function("write_memory")) } # Streaming ----------------------------------------------------------------------- @@ -131,37 +56,36 @@ write_term.write_memory <- function(x) { #' #' @param f Callback function. It should have a single argument, a raw #' vector containing the bytes recieved from the server. This will usually -#' be 16k or less +#' be 16k or less. It should return the length of bytes processed - if +#' this is less than the input length, the function will terminate. #' @examples #' GET("https://jeroenooms.github.io/data/diamonds.json", -#' write_stream(function(x) print(length(x))) +#' write_stream(function(x) { +#' print(length(x)) +#' length(x) +#' }) #' ) #' @export write_stream <- function(f) { stopifnot(is.function(f), length(formals(f)) == 1) - - config( - writer = write_function("write_stream", f = safe_callback(f)) - ) -} -#' @export -print.write_stream <- function(x, ...) { - cat("\n") + request(output = write_function("write_stream", f = f)) } -#' @export -write_init.write_stream <- function(x) { - x + +request_fetch <- function(x, url, handle) UseMethod("request_fetch") +request_fetch.write_memory <- function(x, url, handle) { + curl::curl_fetch_memory(url, handle = handle) } -#' @export -#' @useDynLib httr write_callback -write_opts.write_stream <- function(x) { - list( - writefunction = write_callback$address, - writedata = x$f - ) +request_fetch.write_disk <- function(x, url, handle) { + resp <- curl::curl_fetch_disk(url, x$path, handle = handle) + resp$content <- path(resp$content) + resp } -#' @export -write_term.write_stream <- function(x) { - raw() +request_fetch.write_stream <- function(x, url, handle) { + curl::curl_fetch_stream(url, x$f, handle = handle) } + +path <- function(x) structure(x, class = "path") +#' @export +length.path <- function(x) file.info(x)$size +is.path <- function(x) inherits(x, "path") diff --git a/man/handle.Rd b/man/handle.Rd index 9d8732e8..f7bf0497 100644 --- a/man/handle.Rd +++ b/man/handle.Rd @@ -9,8 +9,7 @@ handle(url, cookies = TRUE) \arguments{ \item{url}{full url to site} -\item{cookies}{if \code{TRUE} (the default), maintain cookies across -requests.} +\item{cookies}{DEPRECATED} } \description{ This handle preserves settings and cookies across multiple requests. It is diff --git a/man/brew_dr.Rd b/man/httr_dr.Rd similarity index 83% rename from man/brew_dr.Rd rename to man/httr_dr.Rd index fdc147d6..8c753350 100644 --- a/man/brew_dr.Rd +++ b/man/httr_dr.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2 (4.1.1): do not edit by hand % Please edit documentation in R/doctor.R -\name{brew_dr} -\alias{brew_dr} +\name{httr_dr} +\alias{httr_dr} \title{Diagnose common configuration problems} \usage{ -brew_dr() +httr_dr() } \description{ Currently one check: that curl uses nss. diff --git a/man/safe_callback.Rd b/man/safe_callback.Rd index 5f46f43e..acd5be5f 100644 --- a/man/safe_callback.Rd +++ b/man/safe_callback.Rd @@ -10,16 +10,7 @@ safe_callback(f) \item{f}{A function.} } \description{ -Whenever an R callback function is passed to Rcurl, it needs to be wrapped -in this handler which converts errors and interrupts to the appropriate -values that cause RCurl to terminate a request -} -\examples{ -f1 <- function(x) { - if (x < 0) stop("Negative value") - sqrt(x) -} -f2 <- safe_callback(f1) -f2(-10) +Generate a safe R callback. } +\keyword{deprecated} diff --git a/man/upload_file.Rd b/man/upload_file.Rd index 8b8b405a..e3ccb2da 100644 --- a/man/upload_file.Rd +++ b/man/upload_file.Rd @@ -13,10 +13,11 @@ upload_file(path, type = NULL) \code{\link[mime]{guess_type}} when needed.} } \description{ -This is a tiny wrapper for \pkg{RCurl}'s \code{\link[RCurl]{fileUpload}}. +Upload a file with \code{\link{POST}} or \code{\link{PUT}}. } \examples{ -POST("http://httpbin.org/post", - body = list(y = upload_file(system.file("CITATION")))) +citation <- upload_file(system.file("CITATION")) +POST("http://httpbin.org/post", body = citation) +POST("http://httpbin.org/post", body = list(y = citation)) } diff --git a/man/write_function.Rd b/man/write_function.Rd index 3294e706..2b0785ac 100644 --- a/man/write_function.Rd +++ b/man/write_function.Rd @@ -2,18 +2,9 @@ % Please edit documentation in R/write-function.R \name{write_function} \alias{write_function} -\alias{write_init} -\alias{write_opts} -\alias{write_term} \title{S3 object to define response writer.} \usage{ write_function(subclass, ...) - -write_init(x) - -write_opts(x) - -write_term(x) } \arguments{ \item{subclass,...}{Class name and fields. Used in class constructors.} @@ -23,15 +14,5 @@ write_term(x) \description{ This S3 object allows you to control how the response body is saved. } -\details{ -There are three key methods: -\itemize{ - \item \code{write_init()}: called before the write is started. It should - return a modified object. - \item \code{write_opts()}: returns a list options passed on to RCurl - \item \code{write_term()}: called after the request is complete. - Should return the content (or a pointer to it) -} -} \keyword{internal} diff --git a/man/write_stream.Rd b/man/write_stream.Rd index cd1729a5..d2863f0f 100644 --- a/man/write_stream.Rd +++ b/man/write_stream.Rd @@ -9,7 +9,8 @@ write_stream(f) \arguments{ \item{f}{Callback function. It should have a single argument, a raw vector containing the bytes recieved from the server. This will usually -be 16k or less} +be 16k or less. It should return the length of bytes processed - if +this is less than the input length, the function will terminate.} } \description{ This is the most general way of processing the response from the server - @@ -18,7 +19,10 @@ with them. } \examples{ GET("https://jeroenooms.github.io/data/diamonds.json", - write_stream(function(x) print(length(x))) + write_stream(function(x) { + print(length(x)) + length(x) + }) ) } diff --git a/src/.gitignore b/src/.gitignore deleted file mode 100644 index 3521f270..00000000 --- a/src/.gitignore +++ /dev/null @@ -1,3 +0,0 @@ -*.so -*.dll -*.o \ No newline at end of file diff --git a/src/writer.c b/src/writer.c deleted file mode 100644 index e742707e..00000000 --- a/src/writer.c +++ /dev/null @@ -1,47 +0,0 @@ -#include -#include -#include - -// From http://stackoverflow.com/questions/17329288/ -// License: http://creativecommons.org/licenses/by-sa/3.0/ -// Author: Ast Derek, https://github.com/AstDerek -size_t writer(void *buffer, size_t size, size_t nmemb, void* stream) { - fwrite(buffer, size, nmemb, (FILE *) stream); - return size * nmemb; -} - -// From: RCurl -// BSD_3_clause -// YEAR: 2001-2014 -// COPYRIGHT HOLDER: Duncan Temple Lang -// ORGANIZATION: Bell Labs, Lucent Technologies; University of California -void close_file(SEXP r_file) { - FILE *f = (FILE *) R_ExternalPtrAddr(r_file); - if (f) { - fflush(f); - fclose(f); - R_SetExternalPtrAddr(r_file, NULL); - } -} - - -// Adapted from RCurl -// BSD_3_clause -// YEAR: 2001-2014 -// COPYRIGHT HOLDER: Duncan Temple Lang -// ORGANIZATION: Bell Labs, Lucent Technologies; University of California -size_t write_callback(void *buffer, size_t size, size_t nmemb, void* fun) { - if (TYPEOF(fun) != CLOSXP) return 0; - - // Convert buffer into a raw vector - SEXP bytes = PROTECT(allocVector(RAWSXP, size * nmemb)); - memcpy(RAW(bytes), buffer, size * nmemb); - - // Call fun with bytes as first argument - SEXP call = PROTECT(LCONS(fun, LCONS(bytes, R_NilValue))); - Rf_eval(call, R_GlobalEnv); - UNPROTECT(2); - - return size * nmemb; -} -