R/mock-api.R

Defines functions hash request_postfields request_body load_response find_mock_file build_mock_url mock_request use_mock_api with_mock_api

Documented in build_mock_url find_mock_file use_mock_api with_mock_api

#' Serve a mock API from files
#'
#' In this context, HTTP requests attempt to load API response fixtures from
#' files. This allows test code to proceed evaluating code that expects
#' HTTP requests to return meaningful responses. Requests that do not have a
#' corresponding fixture file raise errors, like how [without_internet()]
#' does.
#'
#' Requests are translated to mock file paths according to several rules that
#' incorporate the request method, URL, query parameters, and body. See
#' [build_mock_url()] for details.
#'
#' File paths for API fixture files may be relative to the 'tests/testthat'
#' directory, i.e. relative to the .R test files themselves. This is the default
#' location for storing and retrieving mocks, but you can put them anywhere you
#' want as long as you set the appropriate location with [.mockPaths()].
#'
#' @param expr Code to run inside the fake context
#' @return The result of `expr`
#' @seealso [use_mock_api()] to enable mocking on its own (not in a context); [build_mock_url()]; [.mockPaths()]
#' @export
with_mock_api <- function(expr) {
  use_mock_api()
  on.exit(stop_mocking())
  eval.parent(expr)
}

#' Turn on API mocking
#'
#' This function intercepts HTTP requests made through `httr` and serves mock
#' file responses instead. It is what [with_mock_api()] does, minus the
#' automatic disabling of mocking when the context finishes.
#'
#' Note that you in order to resume normal request behavior, you will need to
#' call [stop_mocking()] yourself---this function does not clean up after itself
#' as `with_mock_api` does.
#' @return Nothing; called for its side effects.
#' @seealso [with_mock_api()] [stop_mocking()] [block_requests()]
#' @export
use_mock_api <- function() mock_perform(mock_request)

mock_request <- function(req, handle, refresh) {
  # If there's a query, then req$url has been through build_url(parse_url())
  # and if it's a file and not URL, it has grown a ":///" prefix. Prune that.
  req$url <- sub("^:///", "", req$url)
  f <- build_mock_url(get_current_requester()(req))
  mockfile <- find_mock_file(f)
  if (!is.null(mockfile)) {
    return(load_response(mockfile, req))
  }
  # Else: fail.
  # For ease of debugging if a file isn't found, include it in the
  # error that gets printed.
  req$mockfile <- f
  return(stop_request(req))
}

#' Convert a request to a mock file path
#'
#' Requests are translated to mock file paths according to several rules that
#' incorporate the request method, URL, query parameters, and body.
#'
#' First, the request protocol, such as "https://", is removed from the URL.
#' Second, if the request URL contains a query string, it will be popped off,
#' hashed by [digest::digest()], and the first six characters appended to the
#' file being read. Third, request bodies are similarly hashed and
#' appended. Finally, if a request method other than GET is used it will be
#' appended to the end of the end of the file name.
#'
#' Mock file paths also have a file extension appended, based on the
#' `Content-Type` of the response, though this function, which is only concerned
#' with the request, does not add the extension. In an
#' HTTP API, a "directory" itself is a resource,
#' so the extension allows distinguishing directories and files in the file
#' system. That is, a mocked `GET("http://example.com/api/")` may read a
#' "example.com/api.json" file, while
#' `GET("http://example.com/api/object1/")` reads "example.com/api/object1.json".
#'
#' Other examples:
#' * `GET("http://example.com/api/object1/?a=1")` may read
#' "example.com/api/object1-b64371.xml".
#' * `POST("http://example.com/api/object1/?a=1")` may read
#' "example.com/api/object1-b64371-POST.json".
#'
#' This function is exported so that other packages can construct similar mock
#' behaviors or override specific requests at a higher level than
#' `with_mock_api` mocks.
#'
#' Note that if you are trying to guess the mock file paths corresponding to a
#' test for which you intend to create a mock file manually,
#' instead of trying to build the URL, you should run the test
#' with `with_mock_api` as the error message will contain the mock file path.
#'
#' @param req A `request` object, or a character "URL" to convert
#' @param method character HTTP method. If `req` is a 'request' object,
#' its request method will override this argument
#' @return A file path and name, without an extension. The file, or a file with
#' some extension appended, may or may not
#' exist: existence is not a concern of this function.
#' @importFrom digest digest
#' @seealso [with_mock_api()] [capture_requests()]
#' @export
build_mock_url <- function(req, method = "GET") {
  if (is.character(req)) {
    # A URL/file download
    url <- req
    body <- NULL
  } else {
    url <- req$url
    method <- req$method
    body <- request_body(req)
  }

  # Remove protocol
  url <- sub("^.*?://", "", url)
  # Handle query params
  parts <- unlist(strsplit(url, "?", fixed = TRUE))
  # Remove trailing slash
  f <- sub("\\/$", "", parts[1])
  # Sanitize the path to be portable for all R platforms
  f <- gsub(":", "-", f)
  if (length(parts) > 1) {
    # There's a query string. Append the digest as a suffix.
    f <- paste0(f, "-", hash(parts[2]))
  }

  # Handle body and append its hash if present
  if (!is.null(body)) {
    f <- paste0(f, "-", hash(body))
  }

  if (method != "GET") {
    # Append method to the file name for non GET requests
    f <- paste0(f, "-", method)
  }
  return(f)
}

#' Go through mock paths to find the local mock file location
#'
#' @param file A file path, as generated by [build_mock_url()].
#' @return A path to a file that exists, or `NULL` if none found.
#' @keywords internal
#' @export
find_mock_file <- function(file) {
  for (path in .mockPaths()) {
    # Look for files of any .extension in the indicated directory,
    # be they .R, .json, ...
    mp <- file.path(path, file)
    if (file.exists(mp) && !dir.exists(mp) && grepl("\\.", basename(mp))) {
      # With write_disk() downloading, 'file' may reference a specific
      # file and include the extension .R-FILE. So if that file exists,
      # no need to search for it. Just return it.
      return(mp)
    }
    # Turn the basename into a regular expression that will match it (and
    # only it) with any .extension
    mockbasename <- paste0("^\\Q", basename(mp), "\\E.[[:alnum:]]*$")
    mockfiles <- dir(dirname(mp),
      pattern = mockbasename, all.files = TRUE,
      full.names = TRUE
    )
    # Remove directories
    mockfiles <- setdiff(mockfiles, list.dirs(dirname(mp), full.names = TRUE))
    if (length(mockfiles)) {
      # TODO: check for length > 1
      return(mockfiles[1])
    }
  }
  return(NULL)
}

#' @importFrom utils tail
load_response <- function(file, req) {
  ext <- tail(unlist(strsplit(file, ".", fixed = TRUE)), 1)
  if (ext == "R") {
    # It's a full "response". Source it.
    return(source(file)$value)
  } else if (ext %in% names(EXT_TO_CONTENT_TYPE)) {
    return(fake_response(
      req,
      content = readBin(file, "raw", n = file.size(file)),
      status_code = 200L,
      headers = list(`Content-Type` = EXT_TO_CONTENT_TYPE[[ext]])
    ))
  } else if (ext == "204") {
    return(fake_response(req, status_code = 204L))
  } else {
    stop("Unsupported mock file extension: ", ext, call. = FALSE)
  }
}

request_body <- function(req) {
  # request_body returns a string if the request has a body, NULL otherwise
  b <- request_postfields(req)
  if (is.null(b)) {
    b <- req$fields
    if (!is.null(b)) {
      # Get a readable string representation
      # control "niceNames" was added in R 3.5
      b <- deparse(b, control = "niceNames")
      # Strip out unhelpful indentation that it may add, then collapse
      # to single string, if broken into multiple lines
      b <- paste(sub("^ +", "", b), collapse = "")
    }
  }
  return(b)
}

request_postfields <- function(req) {
  b <- req[["options"]][["postfields"]]
  if (length(b) > 0) {
    # Check length this way because b may be NULL or length 0 raw vector
    return(rawToChar(b))
  } else {
    return(NULL)
  }
}

hash <- function(string, n = 6) substr(digest(string), 1, n)
nealrichardson/httptest documentation built on Feb. 5, 2024, 12:35 a.m.