R/handle.R

In alexvpickering/handlr: handler for rApache http requests

#' Handles incomming rApache requests
#'
#' @param SERVER rApache variable.
#' @param GET rApache variable.
#' @param packages Vector of packages that api allows.
#' @param open Endpoints that are open to non-authenticated users.
#'    Specify as named list of vectors.
#'    for example: list(package_name = 'package_function')
#' @param timeout Time limit in seconds for function to execute.
#' @param rlimits named vector/list with rlimit values,
#'    for example: c(cpu = 60, fsize = 1e6).

#' @return
#' @export
#'
#' @examples
handle <- function(SERVER, GET, packages, open = 'all', timeout = 0, rlimits = NULL) {
  # preflight/cors
  if (preflight(SERVER)) return()

  names(SERVER$headers_in) <- tolower(names(SERVER$headers_in))


  # check if endpoint is allowed/exported
  endpoint <- get_endpoint(SERVER)
  validate_endpoint(endpoint, packages)

  # get claim if endpoint requires JSON web token
  claim <- if(!endpoint_open(endpoint, open)) {
    validate_jwt(SERVER$headers_in)
  }

  # get raw body
  SERVER$raw <- rapache('receiveBin')

  # parse request/get params
  req_data <- parse_req(SERVER, GET)
  params <- get_params(req_data)


  # get function to call (same as pkg::name)
  fun <- getExportedValue(endpoint$pkg, endpoint$fun)

  # call function in forked process with specified limits
  result <- sys::eval_safe(
    do.call(fun, params),
    timeout = timeout,
    rlimits = rlimits
  )
  rapache('sendBin', charToRaw(jsonlite::toJSON(result)))
}

#' Sets CORS headers and checks if preflight
#'
#' @param SERVER rApache variable
#'
#' @return TRUE if method is OPTIONS otherwise FALSE.
#'
#' @examples
preflight <- function(SERVER) {

  # preflight/CORS
  rapache('setHeader', header = 'Access-Control-Allow-Origin', value = '*')
  rapache('setHeader', header = 'Access-Control-Allow-Headers', value = 'Origin, Content-Type, Accept-Encoding, Authorization')

  if(SERVER$method == "OPTIONS"){
    rapache('setHeader', header = 'Access-Control-Allow-Methods', value = 'POST, GET, HEAD, OPTIONS, DELETE')
    return(TRUE)
  }
  return(FALSE)
}

#' Puts parameters for endpoint function into a list.
#'
#'
#' @param req_data Result of call to \code{get_req}.
#'
#' @return Named list of parameters suplied in request.
#'
#' @examples
get_params <- function(req_data) {

  params <- switch(req_data$method,
                   'POST' = req_data$post,
                   'GET'  = req_data$get)

  if (is.null(params)) params <- list()
  return(params)

}


#' Validates JSON web token
#'
#' Error occurs if validation fails.
#'
#' @param req_headers List with request headers.
#'
#' @return List with claim.
#'
#' @examples
validate_jwt <- function(req_headers) {
  secret <- get_env('JWT_SECRET')

  jwt <- req_headers[['authorization']]
  if (!length(jwt))
    stop('401 Requested endpoint requires authentication.')

  jwt <- gsub('^Bearer ', '', jwt)
  jose::jwt_decode_hmac(jwt, secret)
}

#' Get environment variable.
#'
#' Throws error is environment variable is not defined.
#'
#' @param var_name Environment variable to get.
#' @return Value of environment variable.
#'
#' @examples
get_env <- function(var_name) {
  var <- Sys.getenv(var_name)
  if (var == '') stop(var_name, ' environment variable is not set.')
  return(var)
}


#' Check if endpoint is open
#'
#' @inheritParams validate_endpoint
#' @inheritParams handle
#'
#' @return
#'
#' @examples
endpoint_open <- function(endpoint, open='all') {
  if (open == 'all') return(TRUE)

  return(endpoint$fun %in% open[[endpoint$pkg]])
}


#' Helper function to permit testing.
#'
#' Calls rApache function if it can
#'
#' @param rapache_function Name of rApache function to evaluate.
#' @param ... Additional arguments to rApache function.
#'
#' @return
#'
#' @examples
rapache <- function(rapache_function, ...) {
  try(get(rapache_function)(...), silent=TRUE)
}



#' Check if endpoint is allowed/exists
#'
#' @param endpoint Named list with \code{pkg} and \code{fun} strings.
#' @param allowed_packages Character vector of allowed package endpoints
#'
#' @return
#'
#' @examples
validate_endpoint <- function(endpoint, packages) {

  # check if package is allowed
  if (!endpoint$pkg %in% packages)
    stop('403 Package ', endpoint$pkg, ' is not an allowed package\n')

  # check if package exports function
  package_functions <- getNamespaceExports(endpoint$pkg)
  if (!endpoint$fun %in% package_functions)
    stop('404 Function ', endpoint$fun, ' is not exported by package ', endpoint$pkg, '.')


}



#' Gets the package and function names from a path
#'
#' @param SERVER rApache variable: list
#'
#' @return Named list with 'pkg' for the package name and 'fun' the function name.
#' @keywords internal
#'
#' @examples
get_endpoint <- function(SERVER) {

  endpoint <- strsplit(SERVER$path_info, '/')[[1]]
  endpoint <- list(pkg = endpoint[2], fun = endpoint[3])
  return(endpoint)
}