Permalink
Browse files

Pull out common request code into make_request

  • Loading branch information...
1 parent b3d0b4b commit 50ea057be291ad959561a36c070c477ba4c83a49 @hadley hadley committed May 5, 2012
Showing with 75 additions and 69 deletions.
  1. +2 −0 R/handle.r
  2. +39 −9 R/http--request.r
  3. +2 −5 R/http-delete.r
  4. +2 −11 R/http-get.r
  5. +2 −3 R/http-head.r
  6. +1 −3 R/http-patch.r
  7. +26 −35 R/http-post.r
  8. +1 −3 R/http-put.r
View
@@ -44,6 +44,8 @@ reset_handle_config <- function(handle, config) {
blank <- lapply(config, function(x) NULL)
blank$httpauth <- NULL
curlSetOpt(.opts = blank, curl = handle$handle)
+ reset(handle$handle)
+
invisible(TRUE)
}
View
@@ -3,6 +3,9 @@
# request. \code{make_request} will take care of resetting the handle's
# config after the request is made.
make_request <- function(method, handle, url, ..., config = list()) {
+ stopifnot(is.handle(handle))
+ stopifnot(is.character(url), length(url) == 1)
+
# Sign request, if needed
if (!is.null(config$signature)) {
signed <- config$signature(method, url)
@@ -12,21 +15,48 @@ make_request <- function(method, handle, url, ..., config = list()) {
config$signature <- NULL
}
+ # Figure out curl options --------------------------------------------------
+ opts <- default_config()
+ opts$customrequest <- method
+ opts$url <- url
+
+ # Action config override defaults
+ config_f <- match.fun(str_c(tolower(method), "_config"))
+ action_config <- config_f(...)
+ opts <- modifyList(opts, action_config)
+
+ # Config argument overrides everything
+ opts <- modifyList(opts, config)
+
+ # But we always override headerfunction and writefunction
hg <- basicHeaderGatherer()
- opts <- modifyList(default_config(), as.list(config))
opts$headerfunction <- hg$update
+ buffer <- binaryBuffer()
+ opts$writefunction <-
+ getNativeSymbolInfo("R_curl_write_binary_data")$address
+ opts$writedata <- buffer@ref
- action <- match.fun(str_c(tolower(method), "_request"))
- on.exit({
- reset_handle_config(handle, opts)
- reset(handle$handle)
- })
- content <- action(handle, url, ..., opts = opts)
+ # Must always reset the handle config, even if something goes wrong
+ on.exit(reset_handle_config(handle, opts))
+ # Perform request and capture output ---------------------------------------
+ curl_opts <- curlSetOpt(curl = NULL, .opts = opts)
+
+ is_post <- isTRUE(attr(action_config, "post"))
+ if (is_post) {
+ body <- attr(action_config, "body")
+ style <- attr(action_config, "style")
+ .Call("R_post_form", handle$handle@ref, curl_opts, body, TRUE,
+ as.integer(style), PACKAGE = "RCurl")
+ } else {
+ .Call("R_curl_easy_perform", handle$handle@ref, curl_opts, TRUE,
+ integer(), PACKAGE = "RCurl")
+ }
+
+ content <- as(buffer, "raw")
info <- last_request(handle)
times <- request_times(handle)
headers <- insensitive(as.list(hg$value()))
-
status <- as.numeric(str_extract(headers$status, "[0-9]+"))
response(
@@ -63,4 +93,4 @@ parse_cookies <- function(x) {
pieces <- str_split_fixed(x, fixed("\t"), n = 7)
setNames(as.list(pieces[, 7]), pieces[, 6])
-}
+}
View
@@ -14,9 +14,6 @@ DELETE <- function(url = NULL, config = list(), ..., handle = NULL) {
make_request("delete", hu$handle, hu$url, config = config)
}
-delete_request <- function(handle, url, opts) {
- opts$customrequest <- "DELETE"
- opts$nobody <- 1L
-
- get_request(handle, url, opts)
+delete_config <- function() {
+ config(nobody = 1L)
}
View
@@ -64,15 +64,6 @@ GET <- function(url = NULL, config = list(), ..., handle = NULL) {
make_request("get", hu$handle, hu$url, config = config)
}
-get_request <- function(handle, url, opts) {
- opts$url <- url
-
- buffer <- binaryBuffer()
- opts$writefunction <-
- getNativeSymbolInfo("R_curl_write_binary_data")$address
- opts$writedata <- buffer@ref
-
- curlPerform(curl = handle$handle, .opts = opts)
-
- as(buffer, "raw")
+get_config <- function() {
+ config()
}
View
@@ -28,7 +28,6 @@ HEAD <- function(url = NULL, config = list(), ..., handle = NULL) {
}
-head_request <- function(handle, url, opts) {
- opts$nobody <- 1L
- get_request(handle, url, opts)
+head_config <- function() {
+ list(nobody = 1L)
}
View
@@ -8,6 +8,4 @@ PATCH <- function(url = NULL, config = list(), body = NULL, multipart = TRUE, ..
multipart = multipart, config = config)
}
-patch_request <- function(...) {
- send_data("patch", ...)
-}
+patch_config <- post_config
View
@@ -29,36 +29,31 @@ POST <- function(url = NULL, config = list(), body = NULL, multipart = TRUE, ...
multipart = multipart, config = config)
}
-post_request <- function(...) {
- send_data("POST", ...)
-}
-
-send_data <- function (method, handle, url, body = NULL, opts = list(), multipart = TRUE, encoding = integer()) {
- stopifnot(is.handle(handle))
- stopifnot(is.character(url), length(url) == 1)
-
- opts$url <- url
-
- buffer <- binaryBuffer()
- opts$writefunction <-
- getNativeSymbolInfo("R_curl_write_binary_data")$address
- opts$writedata <- buffer@ref
- opts$customrequest <- method
-
+post_config <- function(body = NULL, multipart = TRUE) {
+ # No body
if (is.null(body)) {
- opts$postfieldsize <- 0L
- body <- ""
- } else if (is.character(body) || is.raw(body)) {
+ return(list(postfieldsize = 0L))
+ # opts$
+ # opts$readfunction <- ""
+ # return(opts)
+ }
+
+ # Simple case of send raw text
+ if (is.character(body) || is.raw(body)) {
if (is.character(body)) {
body <- charToRaw(paste(body, collapse = "\n"))
}
- opts$readfunction <- body
- opts$upload <- TRUE
- opts$infilesize <- length(body)
- curlPerform(curl = handle$handle, .opts = opts)
- reset(handle$handle)
- return(as(buffer, "raw"))
- } else if (!multipart) {
+ return(list(
+ upload = TRUE,
+ readfunction = body,
+ infilesize = length(body)
+ ))
+ }
+
+ # Encode each param
+ stopifnot(is.list(body))
+
+ if (!multipart) {
encode <- function(x) {
if (inherits(x, "AsIs")) return(x)
curlEscape(x)
@@ -74,13 +69,9 @@ send_data <- function (method, handle, url, body = NULL, opts = list(), multipar
stopifnot(length(names(body)) > 0)
}
- # Create option list, but don't set values
- opts <- curlSetOpt(curl = NULL, .opts = opts)
-
- style <- if (multipart && body != "") NA else 47
- # handle opts params isProtected r_style
- .Call("R_post_form", handle$handle@ref, opts, body, TRUE,
- as.integer(style), PACKAGE = "RCurl")
-
- as(buffer, "raw")
+ structure(list(),
+ post = TRUE,
+ body = body,
+ style = if (multipart) NA else 47
+ )
}
View
@@ -19,6 +19,4 @@ PUT <- function(url = NULL, config = list(), body = NULL, multipart = TRUE, ...,
multipart = multipart, config = config)
}
-put_request <- function(...) {
- send_data("PUT", ...)
-}
+put_config <- post_config

0 comments on commit 50ea057

Please sign in to comment.