1# This file contains a general toolkit for routing and combining bits of
2# HTTP-handling logic. It is similar in spirit to Rook (and Rack, and WSGI, and
3# Connect, and...) but adds cascading and routing.
4#
5# This file is called "middleware" because that's the term used for these bits
6# of logic in these other frameworks. However, our code uses the word "handler"
7# so we'll stick to that for the rest of this document; just know that they're
8# basically the same concept.
9#
10# ## Intro to handlers
11#
12# A **handler** (or sometimes, **httpHandler**) is a function that takes a
13# `req` parameter--a request object as described in the Rook specification--and
14# returns `NULL`, or an `httpResponse`.
15#
16## ------------------------------------------------------------------------
17
18#' Create an HTTP response object
19#'
20#' @param status HTTP status code for the response.
21#' @param content_type The value for the `Content-Type` header.
22#' @param content The body of the response, given as a single-element character
23#'   vector (will be encoded as UTF-8) or a raw vector.
24#' @param headers A named list of additional headers to include. Do not include
25#'   `Content-Length` (as it is automatically calculated) or `Content-Type` (the
26#'   `content_type` argument is used instead).
27#'
28#' @examples
29#' httpResponse(status = 405L,
30#'   content_type = "text/plain",
31#'   content = "The requested method was not allowed"
32#' )
33#'
34#' @keywords internal
35#' @export
36httpResponse <- function(status = 200L,
37                         content_type = "text/html; charset=UTF-8",
38                         content = "",
39                         headers = list()) {
40  # Make sure it's a list, not a vector
41  headers <- as.list(headers)
42  if (is.null(headers$`X-UA-Compatible`))
43    headers$`X-UA-Compatible` <- "IE=edge,chrome=1"
44  resp <- list(status = status, content_type = content_type, content = content,
45               headers = headers)
46  class(resp) <- 'httpResponse'
47  return(resp)
48}
49
50#
51# You can think of a web application as being simply an aggregation of these
52# functions, each of which performs one kind of duty. Each handler in turn gets
53# a look at the request and can decide whether it knows how to handle it. If
54# so, it returns an `httpResponse` and processing terminates; if not, it
55# returns `NULL` and the next handler gets to execute. If the final handler
56# returns `NULL`, a 404 response should be returned.
57#
58# We have a similar construct for websockets: **websocket handlers** or
59# **wsHandlers**. These take a single `ws` argument which is the websocket
60# connection that was just opened, and they can either return `TRUE` if they
61# are handling the connection, and `NULL` to pass responsibility on to the next
62# wsHandler.
63#
64# ### Combining handlers
65#
66# Since it's so common for httpHandlers to be invoked in this "cascading"
67# fashion, we'll introduce a function that takes zero or more handlers and
68# returns a single handler. And while we're at it, making a directory of static
69# content available is such a common thing to do, we'll allow strings
70# representing paths to be used instead of handlers; any such strings we
71# encounter will be converted into `staticHandler` objects.
72#
73## ------------------------------------------------------------------------
74joinHandlers <- function(handlers) {
75  # Zero handlers; return a null handler
76  if (length(handlers) == 0)
77    return(function(req) NULL)
78
79  # Just one handler (function)? Return it.
80  if (is.function(handlers))
81    return(handlers)
82
83  handlers <- lapply(handlers, function(h) {
84    if (is.character(h))
85      return(staticHandler(h))
86    else
87      return(h)
88  })
89
90  # Filter out NULL
91  handlers <- handlers[!sapply(handlers, is.null)]
92
93  if (length(handlers) == 0)
94    return(function(req) NULL)
95  if (length(handlers) == 1)
96    return(handlers[[1]])
97
98  function(req) {
99    for (handler in handlers) {
100      response <- handler(req)
101      if (!is.null(response))
102        return(response)
103    }
104    return(NULL)
105  }
106}
107
108#
109# Note that we don't have an equivalent of `joinHandlers` for wsHandlers. It's
110# easy to imagine it, we just haven't needed one.
111#
112# ### Handler routing
113#
114# Handlers do not have a built-in notion of routing. Conceptually, given a list
115# of handlers, all the handlers are peers and they all get to see every request
116# (well, up until the point that a handler returns a response).
117#
118# You could implement routing in each handler by checking the request's
119# `PATH_INFO` field, but since it's such a common need, let's make it simple by
120# introducing a `routeHandler` function. This is a handler
121# [decorator](http://en.wikipedia.org/wiki/Decorator_pattern) and it's
122# responsible for 1) filtering out requests that don't match the given route,
123# and 2) temporarily modifying the request object to take the matched part of
124# the route off of the `PATH_INFO` (and add it to the end of `SCRIPT_NAME`).
125# This way, the handler doesn't need to figure out about what part of its URL
126# path has already been matched via routing.
127#
128# (BTW, it's safe for `routeHandler` calls to nest.)
129#
130## ------------------------------------------------------------------------
131routeHandler <- function(prefix, handler) {
132  force(prefix)
133  force(handler)
134
135  if (identical("", prefix))
136    return(handler)
137
138  if (length(prefix) != 1 || !isTRUE(grepl("^/[^\\]+$", prefix))) {
139    stop("Invalid URL prefix \"", prefix, "\"")
140  }
141
142  pathPattern <- paste("^\\Q", prefix, "\\E/", sep = "")
143  function(req) {
144    if (isTRUE(grepl(pathPattern, req$PATH_INFO))) {
145      origScript <- req$SCRIPT_NAME
146      origPath <- req$PATH_INFO
147      on.exit({
148        req$SCRIPT_NAME <- origScript
149        req$PATH_INFO <- origPath
150      }, add = TRUE)
151      pathInfo <- substr(req$PATH_INFO, nchar(prefix)+1, nchar(req$PATH_INFO))
152      req$SCRIPT_NAME <- paste(req$SCRIPT_NAME, prefix, sep = "")
153      req$PATH_INFO <- pathInfo
154      return(handler(req))
155    } else {
156      return(NULL)
157    }
158  }
159}
160
161#
162# We have a version for websocket handlers as well. Pity about the copy/paste
163# job.
164#
165## ------------------------------------------------------------------------
166routeWSHandler <- function(prefix, wshandler) {
167  force(prefix)
168  force(wshandler)
169
170  if (identical("", prefix))
171    return(wshandler)
172
173  if (length(prefix) != 1 || !isTRUE(grepl("^/[^\\]+$", prefix))) {
174    stop("Invalid URL prefix \"", prefix, "\"")
175  }
176
177  pathPattern <- paste("^\\Q", prefix, "\\E/", sep = "")
178  function(ws) {
179    req <- ws$request
180    if (isTRUE(grepl(pathPattern, req$PATH_INFO))) {
181      origScript <- req$SCRIPT_NAME
182      origPath <- req$PATH_INFO
183      on.exit({
184        req$SCRIPT_NAME <- origScript
185        req$PATH_INFO <- origPath
186      }, add = TRUE)
187      pathInfo <- substr(req$PATH_INFO, nchar(prefix)+1, nchar(req$PATH_INFO))
188      req$SCRIPT_NAME <- paste(req$SCRIPT_NAME, prefix, sep = "")
189      req$PATH_INFO <- pathInfo
190      return(wshandler(ws))
191    } else {
192      return(NULL)
193    }
194  }
195}
196
197#
198# ### Handler implementations
199#
200# Now let's actually write some handlers. Note that these functions aren't
201# *themselves* handlers, you call them and they *return* a handler. Handler
202# factory functions, if you will.
203#
204# Here's one that serves up static assets from a directory.
205#
206## ------------------------------------------------------------------------
207staticHandler <- function(root) {
208  force(root)
209  return(function(req) {
210    if (!identical(req$REQUEST_METHOD, 'GET'))
211      return(NULL)
212
213    path <- URLdecode(req$PATH_INFO)
214
215    if (is.null(path))
216      return(httpResponse(400, content="<h1>Bad Request</h1>"))
217
218    if (path == '/')
219      path <- '/index.html'
220
221    if (grepl('\\', path, fixed = TRUE))
222      return(NULL)
223
224    abs.path <- resolve(root, path)
225    if (is.null(abs.path))
226      return(NULL)
227
228    content.type <- getContentType(abs.path)
229    response.content <- readBin(abs.path, 'raw', n=file.info(abs.path)$size)
230    return(httpResponse(200, content.type, response.content))
231  })
232}
233
234#
235# ## Handler manager
236#
237# The handler manager gives you a place to register handlers (of both http and
238# websocket varieties) and provides an httpuv-compatible set of callbacks for
239# invoking them.
240#
241# Create one of these, make zero or more calls to `addHandler` and
242# `addWSHandler` methods (order matters--first one wins!), and then pass the
243# return value of `createHttpuvApp` to httpuv's `startServer` function.
244#
245## ------------------------------------------------------------------------
246HandlerList <- R6Class("HandlerList",
247  portable = FALSE,
248  class = FALSE,
249  public = list(
250    handlers = list(),
251
252    add = function(handler, key, tail = FALSE) {
253      if (!is.null(handlers[[key]]))
254        stop("Key ", key, " already in use")
255      newList <- structure(names=key, list(handler))
256
257      if (length(handlers) == 0)
258        handlers <<- newList
259      else if (tail)
260        handlers <<- c(handlers, newList)
261      else
262        handlers <<- c(newList, handlers)
263    },
264    remove = function(key) {
265      handlers[key] <<- NULL
266    },
267    clear = function() {
268      handlers <<- list()
269    },
270    invoke = function(...) {
271      for (handler in handlers) {
272        result <- handler(...)
273        if (!is.null(result))
274          return(result)
275      }
276      return(NULL)
277    }
278  )
279)
280
281HandlerManager <- R6Class("HandlerManager",
282  portable = FALSE,
283  class = FALSE,
284  public = list(
285    handlers = "HandlerList",
286    wsHandlers = "HandlerList",
287
288    initialize = function() {
289      handlers <<- HandlerList$new()
290      wsHandlers <<- HandlerList$new()
291    },
292
293    addHandler = function(handler, key, tail = FALSE) {
294      handlers$add(handler, key, tail)
295    },
296    removeHandler = function(key) {
297      handlers$remove(key)
298    },
299    addWSHandler = function(wsHandler, key, tail = FALSE) {
300      wsHandlers$add(wsHandler, key, tail)
301    },
302    removeWSHandler = function(key) {
303      wsHandlers$remove(key)
304    },
305    clear = function() {
306      handlers$clear()
307      wsHandlers$clear()
308    },
309    createHttpuvApp = function() {
310      list(
311        onHeaders = function(req) {
312          maxSize <- getOption('shiny.maxRequestSize') %||% (5 * 1024 * 1024)
313          if (maxSize <= 0)
314            return(NULL)
315
316          reqSize <- 0
317          if (length(req$CONTENT_LENGTH) > 0)
318            reqSize <- as.numeric(req$CONTENT_LENGTH)
319          else if (length(req$HTTP_TRANSFER_ENCODING) > 0)
320            reqSize <- Inf
321
322          if (reqSize > maxSize) {
323            return(list(status = 413L,
324              headers = list('Content-Type' = 'text/plain'),
325              body = 'Maximum upload size exceeded'))
326          }
327          else {
328            return(NULL)
329          }
330        },
331        call = .httpServer(
332          function (req) {
333            hybrid_chain(
334              hybrid_chain(
335                withCallingHandlers(withLogErrors(handlers$invoke(req)),
336                  error = function(cond) {
337                    sanitizeErrors <- getOption('shiny.sanitize.errors', FALSE)
338                    if (inherits(cond, 'shiny.custom.error') || !sanitizeErrors) {
339                      stop(cond$message, call. = FALSE)
340                    } else {
341                      stop(paste("An error has occurred. Check your logs or",
342                                 "contact the app author for clarification."),
343                           call. = FALSE)
344                    }
345                  }
346                ),
347                catch = function(err) {
348                  httpResponse(status = 500L,
349                    content_type = "text/html; charset=UTF-8",
350                    content = as.character(htmltools::htmlTemplate(
351                      system.file("template", "error.html", package = "shiny"),
352                      message = conditionMessage(err)
353                    ))
354                  )
355                }
356              ),
357              function(resp) {
358                maybeInjectAutoreload(resp)
359              }
360            )
361          },
362          loadSharedSecret()
363        ),
364        onWSOpen = function(ws) {
365          return(wsHandlers$invoke(ws))
366        }
367      )
368    },
369    .httpServer = function(handler, checkSharedSecret) {
370      filter <- getOption('shiny.http.response.filter')
371      if (is.null(filter))
372        filter <- function(req, response) response
373
374      function(req) {
375        if (!checkSharedSecret(req$HTTP_SHINY_SHARED_SECRET)) {
376          return(list(status=403,
377            body='<h1>403 Forbidden</h1><p>Shared secret mismatch</p>',
378            headers=list('Content-Type' = 'text/html')))
379        }
380
381        # Catch HEAD requests. For the purposes of handler functions, they
382        # should be treated like GET. The difference is that they shouldn't
383        # return a body in the http response.
384        head_request <- FALSE
385        if (identical(req$REQUEST_METHOD, "HEAD")) {
386          head_request <- TRUE
387          req$REQUEST_METHOD <- "GET"
388        }
389
390        response <- handler(req)
391
392        res <- hybrid_chain(response, function(response) {
393          if (is.null(response))
394            response <- httpResponse(404, content="<h1>Not Found</h1>")
395
396          if (inherits(response, "httpResponse")) {
397            headers <- as.list(response$headers)
398            headers$'Content-Type' <- response$content_type
399
400            response <- filter(req, response)
401            if (head_request) {
402
403              headers$`Content-Length` <- getResponseContentLength(response, deleteOwnedContent = TRUE)
404
405              return(list(
406                status = response$status,
407                body = "",
408                headers = headers
409              ))
410            } else {
411              return(list(
412                status = response$status,
413                body = response$content,
414                headers = headers
415              ))
416            }
417
418          } else {
419            # Assume it's a Rook-compatible response
420            return(response)
421          }
422        })
423      }
424    }
425  )
426)
427
428maybeInjectAutoreload <- function(resp) {
429  if (get_devmode_option("shiny.autoreload", FALSE) &&
430      isTRUE(grepl("^text/html($|;)", resp$content_type)) &&
431      is.character(resp$content)) {
432
433    resp$content <- gsub(
434      "</head>",
435      "<script src=\"shared/shiny-autoreload.js\"></script>\n</head>",
436      resp$content,
437      fixed = TRUE
438    )
439  }
440
441  resp
442}
443
444# Safely get the Content-Length of a Rook response, or NULL if the length cannot
445# be determined for whatever reason (probably malformed response$content).
446# If deleteOwnedContent is TRUE, then the function should delete response
447# content that is of the form list(file=..., owned=TRUE).
448getResponseContentLength <- function(response, deleteOwnedContent) {
449  force(deleteOwnedContent)
450
451  result <- if (is.character(response$content) && length(response$content) == 1) {
452    nchar(response$content, type = "bytes")
453  } else if (is.raw(response$content)) {
454    length(response$content)
455  } else if (is.list(response$content) && !is.null(response$content$file)) {
456    if (deleteOwnedContent && isTRUE(response$content$owned)) {
457      on.exit(unlink(response$content$file, recursive = FALSE, force = FALSE), add = TRUE)
458    }
459    file.info(response$content$file)$size
460  } else {
461    warning("HEAD request for unexpected content class ", class(response$content)[[1]])
462    NULL
463  }
464
465  if (is.na(result)) {
466    # Mostly for missing file case
467    return(NULL)
468  } else {
469    return(result)
470  }
471}
472
473#
474# ## Next steps
475#
476# See server.R and middleware-shiny.R to see actual implementation and usage of
477# handlers in the context of Shiny.
478