Merge pull request #188 from matthewstrasiotto/extend_script_dependen…

…cies
rstudio · Oct 24, 2020 · ff2c4ea · ff2c4ea
2 parents 5d42d84 + 05e2ee7
commit ff2c4ea
Show file tree

Hide file tree

Showing 5 changed files with 255 additions and 8 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Package: htmltools
 Type: Package
 Title: Tools for HTML
-Version: 0.5.0.9001
+Version: 0.5.0.9002
 Authors@R: c(
   person("Joe", "Cheng", role = "aut", email = "[email protected]"),
   person("Carson", "Sievert", role = c("aut", "cre"), email = "[email protected]", comment = c(ORCID = "0000-0002-4958-2844")),

diff --git a/NEWS b/NEWS
@@ -1,4 +1,4 @@
-htmltools 0.5.0.9000
+htmltools 0.5.0.9002
 --------------------------------------------------------------------------------
 
 * Added a new `tagFunction()` for generating `tags` and/or `htmlDependency()`s conditional on the rendering context. For an example, see `?tagFunction`. (#180)
@@ -7,6 +7,9 @@ htmltools 0.5.0.9000
 
 * `save_html()` now has a `lang` parameter that can be used to set the lang attribute of `<html>`. (@ColinFay, #185)
 
+* `htmlDependency`, & `renderDependencies` now allow the `script` argument to be given as a named list containing the
+  elements: `src`, `integrity`, `crossorigin`.
+
 htmltools 0.5.0
 --------------------------------------------------------------------------------
 

diff --git a/R/html_dependency.R b/R/html_dependency.R
@@ -36,6 +36,31 @@
 #'   \code{href} for URL. For example, a dependency that was both on disk and at
 #'   a URL might use \code{src = c(file=filepath, href=url)}.
 #'
+#'   \code{script} can be given as one of the following:
+#'   \itemize{
+#'   \item a character vector specifying various scripts to include relative to the
+#'     value of \code{src}.
+#'     Each is expanded into its own \code{<script>} tag
+#'   \item A named list with any of the following fields:
+#'   \itemize{
+#'     \item \code{src},
+#'     \item \code{integrity}, &
+#'     \item \code{crossorigin},
+#'     \item any other valid \code{<script>} attributes.
+#'     }
+#'     allowing the use of SRI to ensure the integrity of packages downloaded from
+#'     remote servers.
+#'     Eg: \code{script = list(src = "min.js", integrity = "hash")}
+#'   \item An unamed list, containing a combination of named list with the fields
+#'     mentioned previously, and strings.
+#'     Eg:
+#'     \itemize{
+#'     \item \code{script = list(list(src = "min.js"), "util.js", list(src = "log.js"))}
+#'     \item \code{script = "pkg.js"} is equivalent to
+#'     \item \code{script = list(src = "pkg.js")}.
+#'     }
+#'   }
+#'
 #'   \code{attachment} can be used to make the indicated files available to the
 #'   JavaScript on the page via URL. For each element of \code{attachment}, an
 #'   element \code{<link id="DEPNAME-ATTACHINDEX-attachment" rel="attachment"
@@ -478,12 +503,7 @@ renderDependencies <- function(dependencies,
 
     # add scripts
     if (length(dep$script) > 0) {
-      html <- c(html, paste(
-        "<script src=\"",
-        htmlEscape(hrefFilter(file.path(srcpath, encodeFunc(dep$script)))),
-        "\"></script>",
-        sep = ""
-      ))
+      html <- c(html, renderScript(dep$script, srcpath, encodeFunc, hrefFilter))
     }
 
     if (length(dep$attachment) > 0) {
@@ -505,6 +525,57 @@ renderDependencies <- function(dependencies,
   HTML(paste(html, collapse = "\n"))
 }
 
+
+
+renderScript <- function(script, srcpath, encodeFunc, hrefFilter) {
+  # If the input is a named list, transform it to an unnamed list
+  # whose only element is the input list
+  if (anyNamed(script)) {
+    if (anyUnnamed(script)) stop("script inputs cannot mix named and unnamed")
+    script <- list(script)
+  }
+
+  # For each element, if it's a scalar string, transform it to a named
+  # list with one element, "src".
+  script <- lapply(script, function(item) {
+    if (length(item) == 1 && is.character(item)) {
+      item = list(src = item)
+    }
+
+    if (length(names(item)) == 0) {
+      stop(
+        "Elements of script must be named lists, or scalar strings ",
+        "I got ", deparse(item)
+      )
+    }
+
+    return(item)
+  })
+
+  script <- vapply(
+    script, function(x) {
+      x$src <- hrefFilter(file.path(srcpath, encodeFunc(x$src)))
+      paste0(
+        "<script", 
+        paste0(
+         " ", 
+         htmlEscape(names(x)),
+         '="', 
+         htmlEscape(x), 
+         '"', 
+         collapse = ''
+        ),
+      "></script>",
+      collapse = ""
+      )
+    },
+    FUN.VALUE = character(1)
+  )
+
+  return(script)
+}
+
+
 # html_dependencies_as_character(list(
 #   htmlDependency("foo", "1.0",
 #     c(href="http://foo.com/bar%20baz/"),

diff --git a/R/utils.R b/R/utils.R
@@ -120,3 +120,31 @@ WSTextWriter <- function(bufferSize=1024) {
     }
   )
 }
+
+# Given a vector/list, return TRUE if any elements are named, FALSE otherwise.
+anyNamed <- function(x) {
+  # Zero-length vector
+  if (length(x) == 0) return(FALSE)
+
+  nms <- names(x)
+
+  # List with no name attribute
+  if (is.null(nms)) return(FALSE)
+
+  # List with name attribute; check for any ""
+  any(nzchar(nms))
+}
+
+# Given a vector/list, return TRUE if any elements are unnamed, FALSE otherwise.
+anyUnnamed <- function(x) {
+  # Zero-length vector
+  if (length(x) == 0) return(FALSE)
+
+  nms <- names(x)
+
+  # List with no name attribute
+  if (is.null(nms)) return(TRUE)
+
+  # List with name attribute; check for any ""
+  any(!nzchar(nms))
+}
diff --git a/tests/testthat/test-deps.r b/tests/testthat/test-deps.r
@@ -186,3 +186,148 @@ test_that("Modifying children using dependencies", {
   x <- tagSetChildren(div("foo", a1.1), tagFunction(function() { a1.2 }))
   expect_identical(findDependencies(x), list(a1.2))
 })
+
+
+test_that("able to resolve HTML scripts supplied with & without integrity", {
+  src1 <- "https://cdn.com/libs/p1/0.1/"
+  src2 <- "https://cdn/libs/p2/0.2/"
+  deps <- list(
+    htmlDependency(
+      name = "p1",
+      version = "0.1",
+      src = list(href = src1),
+      script = list(
+        src = "p1.min.js",
+        integrity = "longhash",
+        crossorigin = "anonymous"
+      )
+    ),
+    htmlDependency(
+      "p2", version = "0.2",
+      src = list(href = src2),
+      script = "p2.min.js"
+    )
+  )
+
+  expect1 <- paste(
+    '<script src="', src1, 'p1.min.js','" ',
+    'integrity="longhash" ',
+    'crossorigin="anonymous"></script>',
+    sep = ''
+  )
+  expect2 <- paste(
+    '<script src="', src2, 'p2.min.js','"></script>',
+    sep = ''
+  )
+
+  expect <- paste(expect1, expect2, sep = '\n')
+
+  class(expect) <- c("html", "character")
+
+  actual <- renderDependencies(deps)
+
+
+
+  expect_equal(!!strsplit(actual, "\n"), !!strsplit(expect, "\n"))
+})
+
+test_that(
+  "can render scripts given as lists of nested lists + scalar strings", {
+    src = "https://cdn.com/libs/p1/0.1"
+    nm <- "p1.js"
+
+    d1 <- htmlDependency(
+      "p1", "0.1", src = list(href = src),
+      script = list(src = nm)
+    )
+
+    deps1 <- list(
+      d1,
+      htmlDependency(
+        "p1", "0.2", src = list(href = src),
+        script = nm
+      ),
+      htmlDependency(
+        "p1", "0.3", src = list(href = src),
+        script = list(list(src = nm))
+      )
+    )
+
+    out <- renderDependencies(deps1)
+
+    deps2 <- list(
+      d1,
+      d1,
+      d1
+    )
+
+    expect_length(unique(unlist(strsplit(out, "\n"))), 1)
+
+    expect_equal(renderDependencies(deps1), renderDependencies(deps2))
+
+    nm2 <- "p1-0.1.js"
+
+    deps3 <- list(
+      htmlDependency(
+        "p1", "0.1", src = list(href = src),
+        script = c(nm, nm2)
+      )
+    )
+
+    out <- renderDependencies(deps3)
+
+    src_urls <- c(
+      file.path(src, nm),
+      file.path(src, nm2)
+      )
+
+    expect <- paste(
+      '<script src="', src_urls[[1]],'"></script>\n',
+      '<script src="', src_urls[[2]],'"></script>',
+      sep = "")
+
+    expect_equal(!!as.character(out), !!expect)
+
+    deps4 <- list(
+      htmlDependency(
+        "p1", "0.1", src = list(href = src),
+        script = list(list(src = nm, integrity = "hash"), nm2)
+      )
+    )
+
+    out <- renderDependencies(deps4)
+
+    expect <- paste(
+      '<script src="', src_urls[[1]], '" integrity="hash"></script>\n',
+      '<script src="', src_urls[[2]], '"></script>',
+      sep = "")
+
+    expect_equal(!!as.character(out), !!expect)
+  })
+
+test_that("html escaping is carried out correctly in script rendering", {
+  src = "https://cdn.com/libs/p1/0.1"
+  nm <- "p1.js"
+  funky_hash <- "<hash>"
+
+  deps <- list(
+    htmlDependency(
+      "p1", "0.1", src = list(href = src),
+      script = list(src = nm, integrity = funky_hash)
+    )
+  )
+
+  src_url <- file.path(src, nm)
+
+  expect <- paste(
+    '<script',
+    ' src="', src_url, '"',
+    ' integrity="', htmlEscape(funky_hash), '"',
+    '></script>',
+    sep = ""
+  )
+
+  out <- renderDependencies(deps)
+  expect_equal(!!as.character(out), !!expect)
+
+})