R/mockup.R

In nteetor/prairie: Get Web Applications Growing In R

#' Mockup a Route
#'
#' Creates a mockup of a route object. A mockup simulates what sort of response
#' is generated by a route given a method, uri, and headers (optional).
#'
#' @param r A route object.
#'
#' @details
#'
#' Unfortunately, \code{httpuv} requires a least one header is specified.
#' Therefore, \code{headers} defaults to and must have at least one field
#' specified.
#'
#' @return
#'
#' A route mockup will return the response object returned by the route handler.
#' However, if the method passed to the mockup is not handled by the route or if
#' the path is not handled by the route a 404 response object with a description
#' as the body is returned.
#'
#' @export
#' @name mockup
#' @examples
#' mkup_logger <- mockup(
#'   route(
#'     'GET',
#'     '^',
#'     function(req) {
#'       print(req)
#'       response()
#'     }
#'   )
#' )
#'
#' mkup_logger('GET', '/yellow/brick/path')
#' mkup_logger('GET', '/phonday', headers = list(Accepts = 'text/html'))
mockup <- function(r) {
  if (!is.route(r)) {
    stop('cannot create a mockup of ', class(r), ' objects', call. = FALSE)
  }

  m <- structure(
    function(method, uri, headers = list(`Content-Type` = 'text/plain')) {
      if (!is.character(method)) {
        stop('argument `method` must be of class character', call. = FALSE)
      }

      if (length(method) != 1) {
        stop('argument `method` must be a single character string',
             call. = FALSE)
      }

      if (!is.character(uri)) {
        stop('argument `uri` must be of class character', call. = FALSE)
      }

      if (length(uri) != 1) {
        stop('argument `uri` must be a single character string', call. = FALSE)
      }

      if (!is.list(headers)) {
        stop('argument `header` must of class list', call. = FALSE)
      }

      e <- new.env(parent = emptyenv())
      e$REQUEST_METHOD <- method
      split_on_query <- strsplit(uri, '?', fixed = TRUE)[[1]]
      e$PATH_INFO <- split_on_query[1]
      e$QUERY_STRING <- if (length(split_on_query) > 1) split_on_query[2] else ''
      for (nm in names(headers)) {
        e[[nm]] <- paste0('HTTP_', headers[[nm]])
      }
      req <- as.request(e)

      if (is_match(r, req)) {
        res <- r$handler(req)

        if (!is.response(res)) {
          stop('route handler returned ', class(res), ', not response',
               call. = FALSE)
        }
      } else {
        res <- response()
        status(res) <- 404
        body(res) <- paste0(
          'The method, uri combination could not be handled by the route.\n\n',
          format(route),
          format(request)
        )
      }

      invisible(res)
    },
    class = c('mockup', class(r))
  )

  attr(m, 'source') <- r

  m
}

print.mockup <- function(x, ...) {
  print.route(attr(x, 'source', exact = TRUE))
}