Automatically serve HEAD static requests for static files (#799)

NEWS.md

@@ -4,13 +4,15 @@
 
 ## New features
 
+* Static file handler now serves HEAD requests. (#798)
 * Introduces new GeoJSON serializer and parser. GeoJSON objects are parsed into `sf` objects and `sf` or `sfc` objects will be serialized into GeoJSON. (@josiahparry, #830)
 * Update feather serializer to use the arrow package. The new default feather MIME type is `application/vnd.apache.arrow.file`. (@pachadotdev #849)
 * Add parquet serializer and parser by using the arrow package (@pachadotdev #849)
 * Updated example `14-future` to use `promises::future_promise()` and added an endpoint that uses `{coro}` to write _simpler_ async / `{promises}` code (#785)
 
 ## Bug fixes
 
+* Static handler returns Last-Modified response header. (#798)
 * OpenAPI response type detection had a scoping issue. Use serializer defined `Content-Type` header instead. (@meztez, #789)
 
 * The default shared secret filter returns error responses without throwing an error. (#808)

R/plumber-static.R

@@ -12,68 +12,76 @@ PlumberStatic <- R6Class(
     #' @param direc a path to an asset directory.
     #' @param options options to be evaluated in the `PlumberStatic` router environment
     #' @return A new `PlumberStatic` router
-    initialize = function(direc, options){
+    initialize = function(direc, options) {
       super$initialize(filters=NULL)
 
       private$dir <- direc
 
-      if(missing(direc)){
+      if (missing(direc)) {
         stop("Cannot add asset directory when no directory was specified")
       }
 
       # Relative paths
-      if(substr(direc, 1, 2) == "./"){
+      if (substr(direc, 1, 2) == "./") {
         direc <- substr(direc, 3, nchar(direc))
       }
 
-      if (missing(options)){
+      if (missing(options)) {
         options <- list()
       }
 
       # Evaluate to convert to list
-      if (is.function(options)){
+      if (is.function(options)) {
         options <- options()
-      } else if (is.expression(options)){
+      } else if (is.expression(options)) {
         options <- eval(options, private$envir)
       }
 
-      badRequest <- function(res){
+      badRequest <- function(res) {
         res$body <- "<h1>Bad Request</h1>"
         res$status <- 400
         res
       }
 
-      expr <- function(req, res){
+      expr <- function(req, res) {
         # Adapted from shiny:::staticHandler
-        if (!identical(req$REQUEST_METHOD, 'GET')){
+        if (!req$REQUEST_METHOD %in% c('GET', 'HEAD')) {
           return(badRequest(res))
         }
 
         path <- req$PATH_INFO
 
-        if (is.null(path)){
+        if (is.null(path)) {
           return(badRequest(res))
         }
 
-        if (path == '/'){
+        if (path == '/') {
           path <- '/index.html'
         }
 
         path <- httpuv::decodeURIComponent(path)
         abs.path <- resolve_path(direc, path)
-        if (is.null(abs.path)){
+        if (is.null(abs.path)) {
           # TODO: Should this be inherited from a parent router?
           val <- private$notFoundHandler(req=req, res=res)
           return(val)
         }
 
         ext <- tools::file_ext(abs.path)
+        info <- file.info(abs.path)
         contentType <- getContentType(ext)
-        responseContent <- readBin(abs.path, 'raw', n=file.info(abs.path)$size)
-
-        res$status <- 200
+        # Similar to: https://github.com/rstudio/httpuv/blob/220319d/src/webapplication.cpp#L617-L623
         res$setHeader("Content-Type", contentType)
-        res$body <- responseContent
+        res$setHeader("Content-Length", info$size)
+        res$setHeader("Last-Modified", http_date_string(info$mtime))
+        res$body <-
+          if (req$REQUEST_METHOD == 'GET') {
+            readBin(abs.path, 'raw', n = info$size)
+          } else {
+            # HEAD request
+            NULL
+          }
+        res$status <- 200
         res
       }
 
@@ -86,9 +94,9 @@ PlumberStatic <- R6Class(
     #' router, set to `TRUE`.
     #' @param ... additional arguments for recursive calls
     #' @return A terminal friendly representation of a `PlumberStatic()` router.
-    print = function(prefix="", topLevel=TRUE, ...){
+    print = function(prefix="", topLevel=TRUE, ...) {
       cat(prefix)
-      if (!topLevel){
+      if (!topLevel) {
         cat("\u2502 ")
       }
       cat(crayon::silver("# Plumber static router serving from directory: ", private$dir, "\n", sep = ""))

R/utils.R

@@ -1,5 +1,21 @@
+#' HTTP Date String
+#'
+#' Given a POSIXct object, return a date string in the format required for a
+#' HTTP Date header. For example: "Wed, 21 Oct 2015 07:28:00 GMT"
+#'
+#' @noRd
+http_date_string <- function(time) {
+  lt <- as.POSIXlt(time, tz = "GMT")
+  weekdays <- c("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat")
+  months <- c("Jan", "Feb", "Mar", "Apr", "May", "Jun",
+              "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
+  weekday <- weekdays[lt$wday + 1]
+  month <- months[lt$mon + 1]
+  fmt <- paste0(weekday, ", %d ", month, " %Y %H:%M:%S GMT")
+  strftime(time, fmt, tz = "GMT")
+}
 
-is_available <- function (package, version = NULL) {
+is_available <- function(package, version = NULL) {
   installed <- nzchar(system.file(package = package))
   if (is.null(version)) {
     return(installed)

tests/testthat/test-static.R

@@ -47,6 +47,17 @@ test_that("root requests are routed to index.html", {
   expect_equal(trimws(rawToChar(res$body)), "<html>I am HTML</html>")
 })
 
+test_that("HEAD requests are served correctly", {
+  for (path in c("/", "/index.html", "/test.txt", "/test.txt.zip")) {
+    resg <- PlumberResponse$new()
+    resh <- PlumberResponse$new()
+    pr$route(make_req("GET", path), resg)
+    pr$route(make_req("HEAD", path), resh)
+    expect_equal(resg$headers, resh$headers)
+    expect_type(resg$headers$`Last-Modified`, "character")
+  }
+})
+
 test_that("static binary file is served", {
   res <- PlumberResponse$new()
   pr$route(make_req("GET", "/test.txt.zip"), res)