R/webmockr-opts.R

In webmockr: Stubbing and Setting Expectations on 'HTTP' Requests

#' webmockr configuration
#'
#' @export
#' @param allow_net_connect (logical) Default: `FALSE`
#' @param allow_localhost  (logical) Default: `FALSE`
#' @param allow (character) one or more URI/URL to allow (and by extension
#' all others are not allowed)
#' @param show_stubbing_instructions (logical) Default: `TRUE`. If `FALSE`,
#' stubbing instructions are not shown
#' @param uri (character) a URI/URL as a character string - to determine
#' whether or not it is allowed
#'
#' @section webmockr_allow_net_connect:
#' If there are stubs found for a request, even if net connections are
#' allowed (by running `webmockr_allow_net_connect()`) the stubbed
#' response will be returned. If no stub is found, and net connections
#' are allowed, then a real HTTP request can be made.
#'
#' @examples \dontrun{
#' webmockr_configure()
#' webmockr_configure(
#'  allow_localhost = TRUE
#' )
#' webmockr_configuration()
#' webmockr_configure_reset()
#'
#' webmockr_allow_net_connect()
#' webmockr_net_connect_allowed()
#'
#' # disable net connect for any URIs
#' webmockr_disable_net_connect()
#' ### gives NULL with no URI passed
#' webmockr_net_connect_allowed()
#' # disable net connect EXCEPT FOR given URIs
#' webmockr_disable_net_connect(allow = "google.com")
#' ### is a specific URI allowed?
#' webmockr_net_connect_allowed("google.com")
#' }
webmockr_configure <- function(
  allow_net_connect = FALSE,
  allow_localhost = FALSE,
  allow = NULL,
  show_stubbing_instructions = TRUE) {

  opts <- list(
    allow_net_connect = allow_net_connect,
    allow_localhost = allow_localhost,
    allow = allow,
    show_stubbing_instructions = show_stubbing_instructions
  )
  for (i in seq_along(opts)) {
    assign(names(opts)[i], opts[[i]], envir = webmockr_conf_env)
  }
  webmockr_configuration()
}

#' @export
#' @rdname webmockr_configure
webmockr_configure_reset <- function() webmockr_configure()

#' @export
#' @rdname webmockr_configure
webmockr_configuration <- function() {
  structure(as.list(webmockr_conf_env), class = "webmockr_config")
}

#' @export
#' @rdname webmockr_configure
webmockr_allow_net_connect <- function() {
  if (!webmockr_net_connect_allowed()) {
    message("net connect allowed")
    assign('allow_net_connect', TRUE, envir = webmockr_conf_env)
  }
}

#' @export
#' @rdname webmockr_configure
webmockr_disable_net_connect <- function(allow = NULL) {
  assert(allow, "character")
  message("net connect disabled")
  assign('allow_net_connect', FALSE, envir = webmockr_conf_env)
  assign('allow', allow, envir = webmockr_conf_env)
}

#' @export
#' @rdname webmockr_configure
webmockr_net_connect_allowed <- function(uri = NULL) {
  assert(uri, c("character", "list"))
  if (is.null(uri)) return(webmockr_conf_env$allow_net_connect)
  uri <- normalize_uri(uri)
  webmockr_conf_env$allow_net_connect ||
    (webmockr_conf_env$allow_localhost && is_localhost(uri) ||
       `!!`(webmockr_conf_env$allow) &&
       net_connect_explicit_allowed(webmockr_conf_env$allow, uri))
}

net_connect_explicit_allowed <- function(allowed, uri = NULL) {
  if (is.null(allowed)) return(FALSE)
  if (is.null(uri)) return(FALSE)
  z <- parse_a_url(uri)
  if (is.na(z$domain)) return(FALSE)
  if (inherits(allowed, "list")) {
    any(vapply(allowed, net_connect_explicit_allowed, logical(1), uri = uri))
  } else if (inherits(allowed, "character")) {
    if (length(allowed) == 1) {
      allowed == uri ||
        allowed == z$domain ||
        allowed == sprintf("%s:%s", z$domain, z$port) ||
        allowed == sprintf("%s://%s:%s", z$scheme, z$domain, z$port) ||
        allowed == sprintf("%s://%s", z$scheme, z$domain) &&
        z$port == z$default_port
    } else {
      any(vapply(allowed, net_connect_explicit_allowed, logical(1), uri = uri))
    }
  }
}

#' @export
print.webmockr_config <- function(x, ...) {
  cat("<webmockr configuration>", sep = "\n")
  cat(paste0("  crul enabled?: ", webmockr_lightswitch$crul), sep = "\n")
  cat(paste0("  httr enabled?: ", webmockr_lightswitch$httr), sep = "\n")
  cat(paste0("  allow_net_connect?: ", x$allow_net_connect), sep = "\n")
  cat(paste0("  allow_localhost?: ", x$allow_localhost), sep = "\n")
  cat(paste0("  allow: ", x$allow %||% ""), sep = "\n")
  cat(paste0("  show_stubbing_instructions: ", x$show_stubbing_instructions),
      sep = "\n")
}

webmockr_conf_env <- new.env()