Merge pull request rstudio#2386 from rstudio/joe/bugfix/subapp-routing

Fix rstudio#2385: R Markdown documents containing subapps not rendering properly

Author: jcheng5

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: shiny
 Type: Package
 Title: Web Application Framework for R
-Version: 1.3.1
+Version: 1.3.1.9000
 Authors@R: c(
     person("Winston", "Chang", role = c("aut", "cre"), email = "[email protected]"),
     person("Joe", "Cheng", role = "aut", email = "[email protected]"),

NEWS.md

@@ -1,20 +1,18 @@
-shiny 1.3.1
-===========
+shiny 1.3.1.9000
+================
 
-## Full changelog
+### Bug fixes
 
-### Breaking changes
+* Static CSS/JS resources in subapps in R Markdown documents did not render properly. ([#2386](https://github.com/rstudio/shiny/pull/2386))
 
-### New features
 
-### Minor new features and improvements
+shiny 1.3.1
+===========
 
 ### Bug fixes
 
 * Fixed a performance issue introduced in v1.3.0 when using large nested lists within Shiny. ([#2377](https://github.com/rstudio/shiny/pull/2377))
 
-### Documentation Updates
-
 
 shiny 1.3.0
 ===========

R/server.R

@@ -23,6 +23,7 @@ registerClient <- function(client) {
 
 
 .globals$resourcePaths <- list()
+.globals$resources <- list()
 
 .globals$showcaseDefault <- 0
 
@@ -69,8 +70,62 @@ addResourcePath <- function(prefix, directoryPath) {
     getShinyOption("server")$setStaticPath(.list = stats::setNames(normalizedPath, prefix))
   }
 
-  # .globals$resourcePaths persists across runs of applications.
+  # .globals$resourcePaths and .globals$resources persist across runs of applications.
   .globals$resourcePaths[[prefix]] <- staticPath(normalizedPath)
+  # This is necessary because resourcePaths is only for serving assets out of C++;
+  # to support subapps, we also need assets to be served out of R, because those
+  # URLs are rewritten by R code (i.e. routeHandler) before they can be matched to
+  # a resource path.
+  .globals$resources[[prefix]] <- list(
+    directoryPath = normalizedPath,
+    func = staticHandler(normalizedPath)
+  )
+}
+
+# This function handles any GET request with two or more path elements where the
+# first path element matches a prefix that was previously added using
+# addResourcePath().
+#
+# For example, if `addResourcePath("foo", "~/bar")` was called, then a GET
+# request for /foo/one/two.html would rewrite the PATH_INFO as /one/two.html and
+# send it to the resource path function for "foo". As of this writing, that
+# function will always be a staticHandler, which serves up a file if it exists
+# and NULL if it does not.
+#
+# Since Shiny 1.3.x, assets registered via addResourcePath should mostly be
+# served out of httpuv's native static file serving features. However, in the
+# specific case of subapps, the R code path must be used, because subapps insert
+# a giant random ID into the beginning of the URL that must be stripped off by
+# an R route handler (see addSubApp()).
+resourcePathHandler <- function(req) {
+  if (!identical(req$REQUEST_METHOD, 'GET'))
+    return(NULL)
+
+  # e.g. "/foo/one/two.html"
+  path <- req$PATH_INFO
+
+  match <- regexpr('^/([^/]+)/', path, perl=TRUE)
+  if (match == -1)
+    return(NULL)
+  len <- attr(match, 'capture.length')
+  # e.g. "foo"
+  prefix <- substr(path, 2, 2 + len - 1)
+
+  resInfo <- .globals$resources[[prefix]]
+  if (is.null(resInfo))
+    return(NULL)
+
+  # e.g. "/one/two.html"
+  suffix <- substr(path, 2 + len, nchar(path))
+
+  # Create a new request that's a clone of the current request, but adjust
+  # PATH_INFO and SCRIPT_NAME to reflect that we have already matched the first
+  # path element (e.g. "/foo"). See routeHandler() for more info.
+  subreq <- as.environment(as.list(req, all.names=TRUE))
+  subreq$PATH_INFO <- suffix
+  subreq$SCRIPT_NAME <- paste(subreq$SCRIPT_NAME, substr(path, 1, 2 + len), sep='')
+
+  return(resInfo$func(subreq))
 }
 
 #' Define Server Functionality
@@ -158,6 +213,8 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
   appvars <- new.env()
   appvars$server <- NULL
 
+  sys.www.root <- system.file('www', package='shiny')
+
   # This value, if non-NULL, must be present on all HTTP and WebSocket
   # requests as the Shiny-Shared-Secret header or else access will be
   # denied (403 response for HTTP, and instant close for websocket).
@@ -167,6 +224,8 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
     http = joinHandlers(c(
       sessionHandler,
       httpHandlers,
+      sys.www.root,
+      resourcePathHandler,
       reactLogHandler
     )),
     ws = function(ws) {