R/config.r

In httr: Tools for Working with URLs and HTTP

#' Set curl options.
#'
#' Generally you should only need to use this function to set CURL options
#' directly if there isn't already a helpful wrapper function, like
#' [set_cookies()], [add_headers()] or
#' [authenticate()]. To use this function effectively requires
#' some knowledge of CURL, and CURL options. Use [httr_options()] to
#' see a complete list of available options. To see the libcurl documentation
#' for a given option, use [curl_docs()].
#'
#' Unlike Curl (and RCurl), all configuration options are per request, not
#' per handle.
#'
#' @seealso [set_config()] to set global config defaults, and
#'  [with_config()] to temporarily run code with set options.
#' @param token An OAuth token (1.0 or 2.0)
#' @family config
#' @family ways to set configuration
#' @seealso All known available options are listed in [httr_options()]
#' @param ... named Curl options.
#' @export
#' @examples
#' # There are a number of ways to modify the configuration of a request
#' # * you can add directly to a request
#' HEAD("https://www.google.com", verbose())
#' 
#' # * you can wrap with with_config()
#' with_config(verbose(), HEAD("https://www.google.com"))
#' 
#' # * you can set global with set_config()
#' old <- set_config(verbose())
#' HEAD("https://www.google.com")
#' # and re-establish the previous settings with
#' set_config(old, override = TRUE)
#' HEAD("https://www.google.com")
#' # or
#' reset_config()
#' HEAD("https://www.google.com")
#' 
#' # If available, you should use a friendly httr wrapper over RCurl
#' # options. But you can pass Curl options (as listed in httr_options())
#' # in config
#' HEAD("https://www.google.com/", config(verbose = TRUE))
config <- function(..., token = NULL) {
  request(options = list(...), auth_token = token)
}

#' List available options.
#'
#' This function lists all available options for [config()].
#' It provides both the short R name which you use with httr, and the longer
#' Curl name, which is useful when searching the documentation. `curl_doc`
#' opens a link to the libcurl documentation for an option in your browser.
#'
#' RCurl and httr use slightly different names to libcurl: the initial
#' `CURLOPT_` is removed, all underscores are converted to periods and
#' the option is given in lower case.  Thus "CURLOPT_SSLENGINE_DEFAULT"
#' becomes "sslengine.default".
#'
#' @param x An option name (either short or full).
#' @param matches If not missing, this restricts the output so that either
#'   the httr or curl option matches this regular expression.
#' @return A data frame with three columns:
#' \item{httr}{The short name used in httr}
#' \item{libcurl}{The full name used by libcurl}
#' \item{type}{The type of R object that the option accepts}
#' @export
#' @examples
#' httr_options()
#' httr_options("post")
#' 
#' # Use curl_docs to read the curl documentation for each option.
#' # You can use either the httr or curl option name.
#' curl_docs("userpwd")
#' curl_docs("CURLOPT_USERPWD")
httr_options <- function(matches) {
  constants <- curl::curl_options()
  constants <- constants[order(names(constants))]

  rcurl <- tolower(names(constants))

  opts <- data.frame(
    httr = rcurl,
    libcurl = translate_curl(rcurl),
    type = curl_option_types(constants),
    stringsAsFactors = FALSE
  )

  if (!missing(matches)) {
    sel <- grepl(matches, opts$httr, ignore.case = TRUE) |
      grepl(matches, opts$libcurl, ignore.case = TRUE)
    opts <- opts[sel, , drop = FALSE]
  }

  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 = "")
  invisible(x)
}

translate_curl <- function(x) {
  paste0("CURLOPT_", gsub(".", "_", toupper(x), fixed = TRUE))
}

#' @export
#' @rdname httr_options
curl_docs <- function(x) {
  stopifnot(is.character(x), length(x) == 1)

  opts <- httr_options()
  if (x %in% opts$httr) {
    x <- opts$libcurl[match(x, opts$httr)]
  }
  if (!(x %in% opts$libcurl)) {
    stop(x, " is not a known curl option", call. = FALSE)
  }

  url <- paste0("http://curl.haxx.se/libcurl/c/", x, ".html")
  BROWSE(url)
}

cache <- new.env(parent = emptyenv())
cache$default_ua <- NULL

default_ua <- function() {
  if (is.null(cache$default_ua)) {
    versions <- c(
      libcurl = curl::curl_version()$version,
      `r-curl` = as.character(utils::packageVersion("curl")),
      httr = as.character(utils::packageVersion("httr"))
    )
    cache$default_ua <- paste0(names(versions), "/", versions, collapse = " ")
  }
  cache$default_ua
}

#' Set (and reset) global httr configuration.
#'
#' @param config Settings as generated by [add_headers()],
#'   [set_cookies()] or [authenticate()].
#' @param override if `TRUE`, ignore existing settings, if `FALSE`,
#'   combine new config with old.
#' @return invisibility, the old global config.
#' @family ways to set configuration
#' @export
#' @examples
#' GET("http://google.com")
#' set_config(verbose())
#' GET("http://google.com")
#' reset_config()
#' GET("http://google.com")
set_config <- function(config, override = FALSE) {
  stopifnot(is.request(config))

  old <- getOption("httr_config") %||% config()
  if (!override) config <- c(old, config)
  options(httr_config = config)
  invisible(old)
}

#' @export
#' @rdname set_config
reset_config <- function() set_config(config(), TRUE)

#' Execute code with configuration set.
#'
#' @family ways to set configuration
#' @inheritParams set_config
#' @param expr code to execute under specified configuration
#' @export
#' @examples
#' with_config(verbose(), {
#'   GET("http://had.co.nz")
#'   GET("http://google.com")
#' })
#' 
#' # Or even easier:
#' with_verbose(GET("http://google.com"))
with_config <- function(config = config(), expr, override = FALSE) {
  stopifnot(is.request(config))

  old <- set_config(config, override)
  on.exit(set_config(old, override = TRUE))
  force(expr)
}

#' @export
#' @param ... Other arguments passed on to [verbose()]
#' @rdname with_config
with_verbose <- function(expr, ...) {
  with_config(verbose(...), expr)
}