R/fake_request.R

In fiery: A Lightweight and Flexible Web Framework

#' @include aaa.R
NULL

#' A Class mimicking InputStream from httpuv
#'
#' @importFrom R6 R6Class
#'
#' @noRd
#'
InputStreamFake <- R6Class('InputStreamFake',
  public = list(
    initialize = function(content) {
      if (!is.raw(content)) {
        check_character(content)
        content <- paste(content, collapse = '\n')
        content <- paste0(content, '\n')
        content <- charToRaw(content)
      }
      private$content <- rawConnection(content)
      private$length <- length(content)
      seek(private$content, 0)
    },
    read_lines = function(n = -1L) {
      readLines(private$content, n, warn = FALSE)
    },
    read = function(l = -1L) {
      # l < 0 means read all remaining bytes
      if (l < 0)
        l <- private$length - seek(private$content)

      if (l == 0)
        return(raw())
      else
        return(readBin(private$content, raw(), l))
    },
    rewind = function() {
      seek(private$content, 0)
    },
    close = function() {
      try(close(private$content), silent = TRUE)
    }
  ),
  private = list(
    content = NULL,
    length = NULL,

    finalize = function() {
      try(close(private$content), silent = TRUE)
    }
  )
)
#' A Class mimicking NullInputStream from httpuv
#'
#' @importFrom R6 R6Class
#'
#' @noRd
#'
NullInputStreamFake <- R6Class('NullInputStreamFake',
  public = list(
    read_lines = function(n = -1L) {
      character()
    },
    read = function(l = -1L) {
      raw()
    },
    rewind = function() invisible(),
    close = function() invisible()
  )
)
#' A Class mimicking ErrorStream from httpuv
#'
#' @importFrom R6 R6Class
#'
#' @noRd
#'
ErrorStreamFake <- R6Class('ErrorStreamFake',
  public = list(
    cat = function(... , sep = " ", fill = FALSE, labels = NULL) {
      base::cat(..., sep=sep, fill=fill, labels=labels, file=stderr())
    },
    flush = function() {
      base::flush(stderr())
    }
  )
)

#' Create a fake request to use in testing
#'
#' This function creates a new request for a specific resource defined by a
#' URL. It mimics the format of the requests provided through httpuv, meaning
#' that it can be used in place for the requests send to the `before-request`,
#' `request`, and `after-request` handlers. This is only provided so that
#' handlers can be tested without having to start up a server.
#'
#' @param url A complete url for the resource the request should ask for
#'
#' @param method The request type (get, post, put, etc). Defaults to `"get"`
#'
#' @param app_location A string giving the first part of the url path that should
#' be stripped from the path
#'
#' @param content The content of the request, either a raw vector or a string
#'
#' @param headers A list of name-value pairs that defines the request headers
#'
#' @param ... Additional name-value pairs that should be added to the request
#'
#' @param remote_address The IP address of the presumed sender
#'
#' @return A Rook-compliant environment
#'
#' @importFrom utils packageVersion
#'
#' @export
#' @keywords internal
#'
#' @examples
#' req <- fake_request(
#'     'http://www.my-fake-website.com/path/to/a/query/?key=value&key2=value2',
#'     content = 'Some important content'
#' )
#'
#' # Get the main address of the URL
#' req[['SERVER_NAME']]
#'
#' # Get the query string
#' req[['QUERY_STRING']]
#'
#' # ... etc.
#'
#' # Cleaning up connections
#' rm(req)
#' gc()
#'
fake_request <- function(url, method = 'get', app_location = '', content = '', headers = list(), ..., remote_address = "123.123.123.123") {
  rook <- new.env(parent = emptyenv())
  rook$REQUEST_METHOD <- toupper(method)

  # Split up URL
  url <- split_url(url)
  rook$rook.url_scheme <- url$scheme
  rook$SERVER_NAME <- url$domain
  rook$SERVER_PORT <- url$port
  if (app_location != '') {
    app_location <- sub('/$', '', app_location)
    appLocReg <- paste0('^', app_location)
    if (!grepl(appLocReg, url$path)) {
      cli::cli_abort('{.arg app_location} must correspond to the beginning of the path')
    }
    rook$SCRIPT_NAME <- app_location
    url$path <- sub(appLocReg, '', url$path)
  } else {
    rook$SCRIPT_NAME <- app_location
  }
  rook$PATH_INFO <- url$path
  rook$QUERY_STRING <- url$query

  # Misc
  rook$httpuv.version <- packageVersion('httpuv')
  rook$rook.version <- "1.1-0"
  rook$REMOTE_PORT <- paste(sample(0:9, 5, TRUE), collapse = '')
  rook$REMOTE_ADDR <- remote_address

  # Headers
  if (length(headers) > 0) {
    names(headers) <- paste0('HTTP_', sub('^HTTP_', '', toupper(gsub("-", "_", names(headers)))))
    for (i in names(headers)) {
      check_scalar(headers[[i]])
      assign(i, as.character(headers[[i]]), envir = rook)
    }
  }

  # Extra
  extra <- list(...)
  for (i in names(extra)) {
    assign(i, extra[[i]], envir = rook)
  }

  # Input
  if (length(content) == 1 && content == '') {
    rook$rook.input <- NullInputStreamFake$new()
  } else {
    rook$rook.input <- InputStreamFake$new(content)
  }
  rook$rook.errors <- ErrorStreamFake$new()

  rook
}
#' @importFrom stringi stri_match
split_url <- function(url) {
  matches <- stri_match(
    url,
    regex = '^(([^:/?#]+)://)?(([^/?#:]*)(:(\\d+))?)?([^?#]*)(\\?([^#]*))?(#(.*))?'
  )[1,]

  parsedURL <- list(
    scheme = if (is.na(matches[3])) 'http' else matches[3],
    domain = matches[5],
    port = matches[7],
    path = if (is.na(matches[8]) | matches[8] == '') '/' else matches[8],
    query = if (is.na(matches[10])) '' else matches[10],
    fragment = if (is.na(matches[12])) '' else matches[12]
  )

  if (is.na(parsedURL$port)) {
    parsedURL$port <- if (parsedURL$scheme == 'http') '80' else '443'
  }
  parsedURL
}