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