Implement request callbacks, closes #408

NAMESPACE

@@ -49,6 +49,7 @@ export(content_type_json)
 export(content_type_xml)
 export(cookies)
 export(curl_docs)
+export(get_callback)
 export(guess_media)
 export(handle)
 export(handle_find)
@@ -88,6 +89,7 @@ export(rerequest)
 export(reset_config)
 export(revoke_all)
 export(safe_callback)
+export(set_callback)
 export(set_config)
 export(set_cookies)
 export(sha1_hash)

R/callback.R

@@ -0,0 +1,102 @@
+
+callback_env <- new.env(parent = emptyenv())
+callback_env$request <- NULL
+callback_env$response <- NULL
+
+#' Install or uninstall a callback function
+#'
+#' Supported callback functions: \describe{
+#' \item{\sQuote{request}}{This callback is called before an HTTP request
+#'   is performed, with the \code{request} object as an argument.
+#'   If the callback returns a value other than \code{NULL}, the HTTP
+#'   request is not performed at all, and the return value of the callback
+#'   is returned. This mechanism can be used to replay previously
+#'   recorded HTTP responses.
+#' }
+#' \item{\sQuote{response}}{This callback is called after an HTTP request
+#'   is performed. The callback is called with two arguments: the
+#'   \code{request} object and the \code{response} object of the HTTP
+#'   request. If this callback returns a value other than \code{NULL},
+#'   then this value is returned by \code{httr}.}
+#' }
+#'
+#' Note that it is not possible to install multiple callbacks of the same
+#' type. The installed callback overwrites the previously intalled one.
+#' To uninstall a callback function, set it to \code{NULL} with
+#' \code{set_callback()}.
+#'
+#' See the \code{httrmock} package for a proper example that uses
+#' callbacks.
+#'
+#' @param name Character scalar, name of the callback to query or set.
+#' @param new_callback The callback function to install, a function object;
+#'   or \code{NULL} to remove the currently installed callback (if any).
+#'
+#' @return \code{get_callback} returns the currently installed
+#'   callback, or \code{NULL} if none is installed.
+#'
+#'   \code{set_callback} returns the previously installed callback,
+#'   or \code{NULL} if none was installed.
+#'
+#' @export
+#' @examples
+#' \dontrun{
+#' ## Log all HTTP requests to the screeen
+#' req_logger <- function(req) {
+#'   cat("HTTP request to", sQuote(req$url), "\n")
+#' }
+#'
+#' old <- set_callback("request", req_logger)
+#' g1 <- GET("https://httpbin.org")
+#' g2 <- GET("https://httpbin.org/ip")
+#' set_callback("request", old)
+#'
+#' ## Log all HTTP requests and response status codes as well
+#' req_logger2 <- function(req) {
+#'   cat("HTTP request to", sQuote(req$url), "... ")
+#' }
+#' res_logger <- function(req, res) {
+#'   cat(res$status_code, "\n")
+#' }
+#'
+#' old_req <- set_callback("request", req_logger2)
+#' old_res <- set_callback("response", res_logger)
+#' g3 <- GET("https://httpbin.org")
+#' g4 <- GET("https://httpbin.org/ip")
+#' set_callback("request", old_req)
+#' set_callback("response", old_res)
+#'
+#' ## Return a recorded response, without performing the HTTP request
+#' replay <- function(req) {
+#'   if (req$url == "https://httpbin.org") g3
+#' }
+#' old_req <- set_callback("request", replay)
+#' grec <- GET("https://httpbin.org")
+#' grec$date == g3$date
+#' set_callback("request", old_req)
+#' }
+
+get_callback <- function(name) {
+  stopifnot(is.character(name), length(name) == 1, !is.na(name))
+  if (!name %in% ls(callback_env)) stop("Unknown httr callback: ", name)
+  callback_env[[name]]
+}
+
+#' @export
+#' @rdname get_callback
+
+set_callback <- function(name, new_callback = NULL) {
+  stopifnot(is.character(name), length(name) == 1, !is.na(name))
+  if (!name %in% ls(callback_env)) stop("Unknown httr callback: ", name)
+
+  old <- callback_env[[name]]
+  stopifnot(is.null(new_callback) || is.function(new_callback))
+  callback_env[[name]] <- new_callback
+  invisible(old)
+}
+
+perform_callback <- function(name, ...) {
+  if (!is.null(callback <- get_callback(name))) {
+    callback(...)
+  }
+}

R/request.R

@@ -122,8 +122,12 @@ request_prepare <- function(req) {
 
 request_perform <- function(req, handle, refresh = TRUE) {
   stopifnot(is.request(req), inherits(handle, "curl_handle"))
+
   req <- request_prepare(req)
 
+  ## This callback can cancel the request
+  if (!is.null(res <- perform_callback("request", req = req))) return(res)
+
   curl::handle_setopt(handle, .list = req$options)
   if (!is.null(req$fields))
     curl::handle_setform(handle, .list = req$fields)
@@ -149,7 +153,7 @@ request_perform <- function(req, handle, refresh = TRUE) {
     date <- Sys.time()
   }
 
-  response(
+  res <- response(
     url = resp$url,
     status_code = resp$status_code,
     headers = headers,
@@ -161,5 +165,12 @@ request_perform <- function(req, handle, refresh = TRUE) {
     request = req,
     handle = handle
   )
+
+  ## If the callback provides a result, we return that
+  if (!is.null(cbres <- perform_callback("response", req, res))) {
+    return(cbres)
+  }
+
+  res
 }
 

tests/testthat/test-callback.R

@@ -0,0 +1,14 @@
+context("Callback")
+
+test_that("request callback", {
+
+  f <- function(req) req$url
+  old <- set_callback("request", f)
+  on.exit(set_callback("request", old))
+
+  expect_identical(GET("foo.bar"), "foo.bar")
+
+  expect_identical(f, get_callback("request"))
+  expect_identical(f, set_callback("request", old))
+  expect_identical(old, get_callback("request"))
+})