From abde5ae3de6527d4b6c1be15517db1860278bdfb Mon Sep 17 00:00:00 2001 From: Ryan Patrick Kyle Date: Wed, 26 Aug 2020 01:14:04 -0400 Subject: [PATCH 1/9] :sparkles: initial support for attributes --- R/dash.R | 12 ++++--- R/utils.R | 95 +++++++++++++++++++++++++++++++++++++++-------------- man/Dash.Rd | 8 +++-- 3 files changed, 85 insertions(+), 30 deletions(-) diff --git a/R/dash.R b/R/dash.R index 8be1d382..1a80c93e 100644 --- a/R/dash.R +++ b/R/dash.R @@ -45,9 +45,13 @@ Dash <- R6::R6Class( #' @param requests_pathname_prefix Character. A prefix applied to request endpoints #' made by Dash's front-end. Environment variable is `DASH_REQUESTS_PATHNAME_PREFIX`. #' @param external_scripts List. An optional list of valid URLs from which - #' to serve JavaScript source for rendered pages. + #' to serve JavaScript source for rendered pages. Each entry can be a string (the URL) + #' or a list with `src` (the URL) and optionally other `", href) - } + if (any(grepl("^(?:http(s)?:\\/\\/)?[\\w.-]+(?:\\.[\\w\\.-]+)+[\\w\\-\\._~:/?#[\\]@!\\$&'\\(\\)\\*\\+,;=.]+$", + tagdata, + perl=TRUE)) || as_is) { + if (is.list(tagdata)) + glue::glue('') + else + glue::glue('') + } else stop(sprintf("Invalid URL supplied. Please check the syntax used for this parameter."), call. = FALSE) } else { # strip leading slash from href if present + if (is.list(tagdata)) + href <- tagdata$src + else + href <- tagdata href <- sub("^/", "", href) modified <- as.integer(file.mtime(local_path)) - sprintf("", - prefix, - href, - modified) + glue::glue('') } } diff --git a/man/Dash.Rd b/man/Dash.Rd index d9e57875..8f8ac2d9 100644 --- a/man/Dash.Rd +++ b/man/Dash.Rd @@ -174,10 +174,14 @@ Environment variable is \code{DASH_ROUTES_PATHNAME_PREFIX}.} made by Dash's front-end. Environment variable is \code{DASH_REQUESTS_PATHNAME_PREFIX}.} \item{\code{external_scripts}}{List. An optional list of valid URLs from which -to serve JavaScript source for rendered pages.} +to serve JavaScript source for rendered pages. Each entry can be a string (the URL) +or a list with \code{src} (the URL) and optionally other \verb{') + glue::glue('') else - glue::glue('') + glue::glue('') } else stop(sprintf("Invalid URL supplied. Please check the syntax used for this parameter."), call. = FALSE) @@ -627,7 +627,7 @@ generate_js_dist_html <- function(tagdata, href <- tagdata href <- sub("^/", "", href) modified <- as.integer(file.mtime(local_path)) - glue::glue('') + glue::glue('') } } From b2ff7a1e3ac3b3288dc2a56219cc513770bd86a6 Mon Sep 17 00:00:00 2001 From: Ryan Patrick Kyle Date: Fri, 28 Aug 2020 02:41:24 -0400 Subject: [PATCH 3/9] refactor following comments --- R/dash.R | 3 ++ R/utils.R | 134 +++++++++++++++++++++++++++++++++--------------------- 2 files changed, 86 insertions(+), 51 deletions(-) diff --git a/R/dash.R b/R/dash.R index 1a80c93e..60e9d89b 100644 --- a/R/dash.R +++ b/R/dash.R @@ -108,6 +108,9 @@ Dash <- R6::R6Class( self$config$show_undo_redo <- show_undo_redo self$config$update_title <- update_title + # ensure attributes are valid, if using a list within a list, elements are all named + assertValidExternals(scripts = external_scripts, stylesheets = external_stylesheets) + # ------------------------------------------------------------ # Initialize a route stack and register a static resource route # ------------------------------------------------------------ diff --git a/R/utils.R b/R/utils.R index 540d1780..1d62c0e9 100644 --- a/R/utils.R +++ b/R/utils.R @@ -542,28 +542,6 @@ generate_css_dist_html <- function(tagdata, prefix = NULL, as_is = FALSE) { attribs <- names(tagdata) - allowed_attribs <- c("as", - "crossorigin", - "disabled", - "href", - "hreflang", - "importance", - "integrity", - "media", - "referrerpolicy", - "rel", - "sizes", - "title", - "type", - "methods", - "prefetch", - "target", - "charset", - "rev") - if (!all(attribs %in% allowed_attribs)) { - stop(sprintf("The following specified stylesheet attributes are invalid: ", - paste0(setdiff(attribs, allowed_attribs), collapse=", ")), call. = FALSE) - } if (!(local)) { if (any(grepl("^(?:http(s)?:\\/\\/)?[\\w.-]+(?:\\.[\\w\\.-]+)+[\\w\\-\\._~:/?#[\\]@!\\$&'\\(\\)\\*\\+,;=.]+$", tagdata, @@ -576,38 +554,26 @@ generate_css_dist_html <- function(tagdata, else stop(sprintf("Invalid URL supplied in external_stylesheets. Please check the syntax used for this parameter."), call. = FALSE) } else { - # strip leading slash from href if present - if (is.list(tagdata)) - href <- tagdata$src - else - href <- tagdata - href <- sub("^/", "", href) modified <- as.integer(file.mtime(local_path)) - glue::glue('') + # strip leading slash from href if present + if (is.list(tagdata)) { + tagdata$href <- paste0(prefix, sub("^/", "", tagdata$href)) + glue::glue('') + } + else { + tagdata <- sub("^/", "", tagdata) + glue::glue('') + } } } + generate_js_dist_html <- function(tagdata, local = FALSE, local_path = NULL, prefix = NULL, as_is = FALSE) { attribs <- names(tagdata) - allowed_attribs <- c("async", - "crossorigin", - "defer", - "integrity", - "nomodule", - "nonce", - "referrerpolicy", - "src", - "type", - "charset", - "language") - if (!all(attribs %in% allowed_attribs)) { - stop(sprintf("The following specified script attributes are invalid: ", - paste0(setdiff(attribs, allowed_attribs), collapse=", ")), call. = FALSE) - } if (!(local)) { if (any(grepl("^(?:http(s)?:\\/\\/)?[\\w.-]+(?:\\.[\\w\\.-]+)+[\\w\\-\\._~:/?#[\\]@!\\$&'\\(\\)\\*\\+,;=.]+$", tagdata, @@ -620,17 +586,83 @@ generate_js_dist_html <- function(tagdata, else stop(sprintf("Invalid URL supplied. Please check the syntax used for this parameter."), call. = FALSE) } else { - # strip leading slash from href if present - if (is.list(tagdata)) - href <- tagdata$src - else - href <- tagdata - href <- sub("^/", "", href) modified <- as.integer(file.mtime(local_path)) - glue::glue('') + # strip leading slash from href if present + if (is.list(tagdata)) { + tagdata$src <- paste0(prefix, sub("^/", "", tagdata$src)) + glue::glue('') + } + else { + tagdata <- sub("^/", "", tagdata) + glue::glue('') + } } } +assertValidExternals <- function(scripts, stylesheets) { + allowed_js_attribs <- c("async", + "crossorigin", + "defer", + "integrity", + "nomodule", + "nonce", + "referrerpolicy", + "src", + "type", + "charset", + "language") + + allowed_css_attribs <- c("as", + "crossorigin", + "disabled", + "href", + "hreflang", + "importance", + "integrity", + "media", + "referrerpolicy", + "rel", + "sizes", + "title", + "type", + "methods", + "prefetch", + "target", + "charset", + "rev") + script_attributes <- character() + stylesheet_attributes <- character() + + for (item in scripts) { + if (is.list(item)) { + if (any(names(item) == "")) + stop("Please verify that all attributes are named elements when specifying URLs for scripts and stylesheets.", call. = FALSE) + script_attributes <- c(script_attributes, names(item)) + } + else + script_attributes <- c(script_attributes, character(0)) + } + + for (item in stylesheets) { + if (is.list(item)) { + if (any(names(item) == "")) + stop("Please verify that all attributes are named elements when specifying URLs for scripts and stylesheets.", call. = FALSE) + stylesheet_attributes <- c(stylesheet_attributes, names(item)) + } + else + stylesheet_attributes <- c(stylesheet_attributes, character(0)) + } + + invalid_script_attributes <- setdiff(script_attributes, allowed_js_attribs) + invalid_stylesheet_attributes <- setdiff(stylesheet_attributes, allowed_css_attribs) + + if (length(invalid_script_attributes) > 0 || length(invalid_stylesheet_attributes) > 0) { + stop(sprintf("The following script or stylesheet attributes are invalid: %s.", + paste0(c(invalid_script_attributes, invalid_stylesheet_attributes), collapse=", ")), call. = FALSE) + } + invisible(TRUE) + } + generate_meta_tags <- function(metas) { has_ie_compat <- any(vapply(metas, function(x) x$name == "http-equiv" && x$content == "X-UA-Compatible", From aa63335c273c5538069ed09f3536b1b5dbc11458 Mon Sep 17 00:00:00 2001 From: Ryan Patrick Kyle Date: Fri, 28 Aug 2020 02:43:18 -0400 Subject: [PATCH 4/9] :rotating_light: add tests --- tests/testthat/test-attributes.R | 103 +++++++++++++++++++++++++++++++ 1 file changed, 103 insertions(+) create mode 100644 tests/testthat/test-attributes.R diff --git a/tests/testthat/test-attributes.R b/tests/testthat/test-attributes.R new file mode 100644 index 00000000..b895bf53 --- /dev/null +++ b/tests/testthat/test-attributes.R @@ -0,0 +1,103 @@ +context("attributes") + +test_that("stylesheets can be added with or without attributes", { + library(dashHtmlComponents) + stylesheet_pattern <- '^.*.*$' + script_pattern <- '^.*", + "", + "" + ) + ) + +}) + +test_that("invalid attributes trigger a warning", { + library(dashHtmlComponents) + + external_stylesheets <- list( + list( + href="https://codepen.io/chriddyp/pen/bWLwgP.css", + foo="somedata", + bar="moredata" + ) + ) + + external_scripts <- list( + "https://www.google-analytics.com/analytics.js", + list( + src = "https://cdn.polyfill.io/v2/polyfill.min.js" + ), + list( + src = "https://cdnjs.cloudflare.com/ajax/libs/lodash.js/4.17.10/lodash.core.js", + integrity = "sha256-Qqd/EfdABZUcAxjOkMi8eGEivtdTkh3b65xCZL4qAQA=", + baz = "anonymous" + ) + ) + + expect_error(dash:::assertValidExternals(external_scripts, external_stylesheets), + "The following script or stylesheet attributes are invalid: baz, foo, bar.") +}) + +test_that("not passing named attributes triggers an error", { + library(dashHtmlComponents) + + external_stylesheets <- list( + list( + href="https://codepen.io/chriddyp/pen/bWLwgP.css", + foo="somedata", + "moredata" + ) + ) + + external_scripts <- list() + + expect_error(dash:::assertValidExternals(external_scripts, external_stylesheets), + "Please verify that all attributes are named elements when specifying URLs for scripts and stylesheets.") +}) + From 5f409ea6278db853eb980e43c694ce01e16c0428 Mon Sep 17 00:00:00 2001 From: Ryan Patrick Kyle Date: Fri, 28 Aug 2020 15:19:15 -0400 Subject: [PATCH 5/9] update CHANGELOG.md --- CHANGELOG.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 710a336d..f375bfe5 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,10 @@ All notable changes to `dash` will be documented in this file. This project adheres to [Semantic Versioning](http://semver.org/). +## [Unreleased] +### Added +- Support for setting attributes on `external_scripts` and `external_stylesheets`, and validation for the parameters passed (attributes are verified, and elements that are lists themselves must be named). [#226](https://github.com/plotly/dashR/pull/226) + ## [0.7.1] - 2020-07-30 ### Fixed - Fixes a minor bug in debug mode that prevented display of user-defined error messages when induced by invoking the `stop` function. [#220](https://github.com/plotly/dashR/pull/220). From 3f4296ab16a5558ca41c2a6fbc14a3337856338f Mon Sep 17 00:00:00 2001 From: Ryan Patrick Kyle Date: Fri, 28 Aug 2020 21:25:34 -0400 Subject: [PATCH 6/9] :rotating_light: more tests --- tests/testthat/test-attributes.R | 149 ++++++++++++++++++++++++++++++- 1 file changed, 146 insertions(+), 3 deletions(-) diff --git a/tests/testthat/test-attributes.R b/tests/testthat/test-attributes.R index b895bf53..a3733031 100644 --- a/tests/testthat/test-attributes.R +++ b/tests/testthat/test-attributes.R @@ -11,7 +11,7 @@ test_that("stylesheets can be added with or without attributes", { hreflang="en-us") ), external_scripts = list( - "https://www.google-analytics.com/analytics.js", + src="https://www.google-analytics.com/analytics.js", list( src = "https://cdn.polyfill.io/v2/polyfill.min.js" ), @@ -55,9 +55,60 @@ test_that("stylesheets can be added with or without attributes", { ) ) + app <- Dash$new(serve_locally=FALSE, external_stylesheets = list( + list( + href="https://codepen.io/chriddyp/pen/bWLwgP.css", + hreflang="en-us") + ), + external_scripts = list( + src="https://www.google-analytics.com/analytics.js", + list( + src = "https://cdn.polyfill.io/v2/polyfill.min.js" + ), + list( + src = "https://cdnjs.cloudflare.com/ajax/libs/lodash.js/4.17.10/lodash.core.js", + integrity = "sha256-Qqd/EfdABZUcAxjOkMi8eGEivtdTkh3b65xCZL4qAQA=", + crossorigin = "anonymous" + ) + ) + ) + + app$layout(htmlDiv( + "Hello world!" + ) + ) + + request_with_attributes <- fiery::fake_request( + "http://127.0.0.1:8050" + ) + + # start up Dash briefly to generate the index + app$run_server(block=FALSE) + app$server$stop() + + response_with_attributes <- app$server$test_request(request_with_attributes) + + tags_by_line <- lapply(strsplit(response_with_attributes$body, "\n "), function(x) trimws(x))[[1]] + stylesheet_hrefs <- grep(stylesheet_pattern, tags_by_line, value = TRUE) + script_hrefs <- grep(script_pattern, tags_by_line, value = TRUE) + + expect_equal( + stylesheet_hrefs, + "" + ) + + expect_equal( + script_hrefs, + c("\n\n\n\n\n", + "", + "", + "" + ) + ) + }) -test_that("invalid attributes trigger a warning", { +test_that("invalid attributes trigger an error", { library(dashHtmlComponents) external_stylesheets <- list( @@ -67,7 +118,7 @@ test_that("invalid attributes trigger a warning", { bar="moredata" ) ) - + external_scripts <- list( "https://www.google-analytics.com/analytics.js", list( @@ -101,3 +152,95 @@ test_that("not passing named attributes triggers an error", { "Please verify that all attributes are named elements when specifying URLs for scripts and stylesheets.") }) +test_that("stylesheet can be passed as a simple list", { + library(dashHtmlComponents) + stylesheet_pattern <- '^.*.*$' + script_pattern <- '^.*\n\n\n\n\n", - "", + script_hrefs[2:4], + c("", "", "" ) @@ -243,4 +242,4 @@ test_that("passing a list with no href/src fails", { ) ), "A valid URL must be included with every entry in external_scripts. Please sure no 'src' entries are missing or malformed.") -}) \ No newline at end of file +}) From 9d6851e7f613e922a0785795bcc34ea6cae06bc4 Mon Sep 17 00:00:00 2001 From: Ryan Patrick Kyle Date: Wed, 2 Sep 2020 23:18:00 -0400 Subject: [PATCH 9/9] handle internal script tags in test --- tests/testthat/test-attributes.R | 32 +++++++++++++++++++++++++++++--- 1 file changed, 29 insertions(+), 3 deletions(-) diff --git a/tests/testthat/test-attributes.R b/tests/testthat/test-attributes.R index dcf5134d..11978254 100644 --- a/tests/testthat/test-attributes.R +++ b/tests/testthat/test-attributes.R @@ -91,15 +91,41 @@ test_that("stylesheets can be added with or without attributes", { tags_by_line <- lapply(strsplit(response_with_attributes$body, "\n "), function(x) trimws(x))[[1]] stylesheet_hrefs <- grep(stylesheet_pattern, tags_by_line, value = TRUE) script_hrefs <- grep(script_pattern, tags_by_line, value = TRUE) - + + # construct the script tags as they should be generated within + # Dash for R this way the mod times and version numbers will + # always be in sync with those used by the backend + internal_hrefs <- vapply(dash:::.dash_js_metadata(), function(x) x$src$href, character(1)) + dhc <- dashHtmlComponents:::.dashHtmlComponents_js_metadata()[[1]] + dhc_path <- dash:::getDependencyPath(dhc) + modtime <- as.integer(file.mtime(dhc_path)) + filename <- basename(dash:::buildFingerprint(dhc$script, dhc$version, modtime)) + dhc_ref <- paste0("/", + "_dash-component-suites/", + dhc$name, + "/", + filename, + "?v=", + dhc$version, + "&m=", + modtime) + + all_tags <- glue::glue("\n") + expect_equal( stylesheet_hrefs, "" ) expect_equal( - script_hrefs[2:4], - c("", + script_hrefs, + c(glue::glue_collapse(all_tags, sep="\n"), + "", "", "" )