middleware.Rmd

Combining handlers

Since it’s so common for httpHandlers to be invoked in this “cascading” fashion, we’ll introduce a function that takes zero or more handlers and returns a single handler. And while we’re at it, making a directory of static content available is such a common thing to do, we’ll allow strings representing paths to be used instead of handlers; any such strings we encounter will be converted into staticHandler objects.

joinHandlers <- function(handlers) {
  # Zero handlers; return a null handler
  if (length(handlers) == 0)
    return(function(req) NULL)

  # Just one handler (function)? Return it.
  if (is.function(handlers))
    return(handlers)

  handlers <- lapply(handlers, function(h) {
    if (is.character(h))
      return(staticHandler(h))
    else
      return(h)
  })

  # Filter out NULL
  handlers <- handlers[!sapply(handlers, is.null)]

  if (length(handlers) == 0)
    return(function(req) NULL)
  if (length(handlers) == 1)
    return(handlers[[1]])

  function(req) {
    for (handler in handlers) {
      response <- handler(req)
      if (!is.null(response))
        return(response)
    }
    return(NULL)
  }
}

Note that we don’t have an equivalent of joinHandlers for wsHandlers. It’s easy to imagine it, we just haven’t needed one.

Handler routing

Handlers do not have a built-in notion of routing. Conceptually, given a list of handlers, all the handlers are peers and they all get to see every request (well, up until the point that a handler returns a response).

You could implement routing in each handler by checking the request’s PATH_INFO field, but since it’s such a common need, let’s make it simple by introducing a routeHandler function. This is a handler decorator and it’s responsible for 1) filtering out requests that don’t match the given route, and 2) temporarily modifying the request object to take the matched part of the route off of the PATH_INFO (and add it to the end of SCRIPT_NAME). This way, the handler doesn’t need to figure out about what part of its URL path has already been matched via routing.

(BTW, it’s safe for routeHandler calls to nest.)

routeHandler <- function(prefix, handler) {
  force(prefix)
  force(handler)

  if (identical("", prefix))
    return(handler)

  if (length(prefix) != 1 || !isTRUE(grepl("^/[^\\]+$", prefix))) {
    stop("Invalid URL prefix \"", prefix, "\"")
  }

  pathPattern <- paste("^\\Q", prefix, "\\E/", sep = "")
  function(req) {
    if (isTRUE(grepl(pathPattern, req$PATH_INFO))) {
      origScript <- req$SCRIPT_NAME
      origPath <- req$PATH_INFO
      on.exit({
        req$SCRIPT_NAME <- origScript
        req$PATH_INFO <- origPath
      }, add = TRUE)
      pathInfo <- substr(req$PATH_INFO, nchar(prefix)+1, nchar(req$PATH_INFO))
      req$SCRIPT_NAME <- paste(req$SCRIPT_NAME, prefix, sep = "")
      req$PATH_INFO <- pathInfo
      return(handler(req))
    } else {
      return(NULL)
    }
  }
}

We have a version for websocket handlers as well. Pity about the copy/paste job.

routeWSHandler <- function(prefix, wshandler) {
  force(prefix)
  force(wshandler)

  if (identical("", prefix))
    return(wshandler)

  if (length(prefix) != 1 || !isTRUE(grepl("^/[^\\]+$", prefix))) {
    stop("Invalid URL prefix \"", prefix, "\"")
  }

  pathPattern <- paste("^\\Q", prefix, "\\E/", sep = "")
  function(ws) {
    req <- ws$request
    if (isTRUE(grepl(pathPattern, req$PATH_INFO))) {
      origScript <- req$SCRIPT_NAME
      origPath <- req$PATH_INFO
      on.exit({
        req$SCRIPT_NAME <- origScript
        req$PATH_INFO <- origPath
      }, add = TRUE)
      pathInfo <- substr(req$PATH_INFO, nchar(prefix)+1, nchar(req$PATH_INFO))
      req$SCRIPT_NAME <- paste(req$SCRIPT_NAME, prefix, sep = "")
      req$PATH_INFO <- pathInfo
      return(wshandler(ws))
    } else {
      return(NULL)
    }
  }
}

Handler implementations

Now let’s actually write some handlers. Note that these functions aren’t themselves handlers, you call them and they return a handler. Handler factory functions, if you will.

Here’s one that serves up static assets from a directory.

staticHandler <- function(root) {
  force(root)
  return(function(req) {
    if (!identical(req$REQUEST_METHOD, 'GET'))
      return(NULL)

    path <- req$PATH_INFO

    if (is.null(path))
      return(httpResponse(400, content="<h1>Bad Request</h1>"))

    if (path == '/')
      path <- '/index.html'

    abs.path <- resolve(root, path)
    if (is.null(abs.path))
      return(NULL)

    ext <- tools::file_ext(abs.path)
    content.type <- getContentType(ext)
    response.content <- readBin(abs.path, 'raw', n=file.info(abs.path)$size)
    return(httpResponse(200, content.type, response.content))
  })
}