1#' Define an HTML dependency
2#'
3#' Define an HTML dependency (i.e. CSS and/or JavaScript bundled in a
4#' directory). HTML dependencies make it possible to use libraries like jQuery,
5#' Bootstrap, and d3 in a more composable and portable way than simply using
6#' script, link, and style tags.
7#'
8#' @param name Library name
9#' @param version Library version
10#' @param src Unnamed single-element character vector indicating the full path
11#'   of the library directory. Alternatively, a named character string with one
12#'   or more elements, indicating different places to find the library; see
13#'   Details.
14#' @param meta Named list of meta tags to insert into document head
15#' @param script Script(s) to include within the document head (should be
16#'   specified relative to the `src` parameter).
17#' @param stylesheet Stylesheet(s) to include within the document (should be
18#'   specified relative to the `src` parameter).
19#' @param head Arbitrary lines of HTML to insert into the document head
20#' @param attachment Attachment(s) to include within the document head. See
21#'   Details.
22#' @param package An R package name to indicate where to find the `src`
23#'   directory when `src` is a relative path (see
24#'   [resolveDependencies()]).
25#' @param all_files Whether all files under the `src` directory are
26#'   dependency files. If `FALSE`, only the files specified in
27#'   `script`, `stylesheet`, and `attachment` are treated as
28#'   dependency files.
29#'
30#' @return An object that can be included in a list of dependencies passed to
31#'   [attachDependencies()].
32#'
33#' @details Each dependency can be located on the filesystem, at a relative or
34#'   absolute URL, or both. The location types are indicated using the names of
35#'   the `src` character vector: `file` for filesystem directory,
36#'   `href` for URL. For example, a dependency that was both on disk and at
37#'   a URL might use `src = c(file=filepath, href=url)`.
38#'
39#'   `script` can be given as one of the following:
40#'   \itemize{
41#'   \item a character vector specifying various scripts to include relative to the
42#'     value of `src`.
43#'     Each is expanded into its own `<script>` tag
44#'   \item A named list with any of the following fields:
45#'   \itemize{
46#'     \item `src`,
47#'     \item `integrity`, &
48#'     \item `crossorigin`,
49#'     \item any other valid `<script>` attributes.
50#'     }
51#'     allowing the use of SRI to ensure the integrity of packages downloaded from
52#'     remote servers.
53#'     Eg: `script = list(src = "min.js", integrity = "hash")`
54#'   \item An unamed list, containing a combination of named list with the fields
55#'     mentioned previously, and strings.
56#'     Eg:
57#'     \itemize{
58#'     \item `script = list(list(src = "min.js"), "util.js", list(src = "log.js"))`
59#'     \item `script = "pkg.js"` is equivalent to
60#'     \item `script = list(src = "pkg.js")`.
61#'     }
62#'   }
63#'
64#'   `attachment` can be used to make the indicated files available to the
65#'   JavaScript on the page via URL. For each element of `attachment`, an
66#'   element `<link id="DEPNAME-ATTACHINDEX-attachment" rel="attachment"
67#'   href="...">` is inserted, where `DEPNAME` is `name`. The value of
68#'   `ATTACHINDEX` depends on whether `attachment` is named or not; if
69#'   so, then it's the name of the element, and if not, it's the 1-based index
70#'   of the element. JavaScript can retrieve the URL using something like
71#'   `document.getElementById(depname + "-" + index + "-attachment").href`.
72#'   Note that depending on the rendering context, the runtime value of the href
73#'   may be an absolute, relative, or data URI.
74#'
75#'   `htmlDependency` should not be called from the top-level of a package
76#'   namespace with absolute paths (or with paths generated by
77#'   `system.file()`) and have the result stored in a variable. This is
78#'   because, when a binary package is built, R will run `htmlDependency`
79#'   and store the path from the building machine's in the package. This path is
80#'   likely to differ from the correct path on a machine that downloads and
81#'   installs the binary package. If there are any absolute paths, instead of
82#'   calling `htmlDependency` at build-time, it should be called at
83#'   run-time. This can be done by wrapping the `htmlDependency` call in a
84#'   function.
85#'
86#' @seealso Use [attachDependencies()] to associate a list of
87#'   dependencies with the HTML it belongs with.
88#'
89#' @export
90htmlDependency <- function(name,
91                           version,
92                           src,
93                           meta = NULL,
94                           script = NULL,
95                           stylesheet = NULL,
96                           head = NULL,
97                           attachment = NULL,
98                           package = NULL,
99                           all_files = TRUE) {
100
101  # This function shouldn't be called from a namespace environment with
102  # absolute paths.
103  if (isNamespace(parent.frame()) && any(substr(src, 1, 1) == "/")) {
104    warning(
105      "htmlDependency shouldn't be called from a namespace environment",
106      " with absolute paths (or paths from system.file()).",
107      " See ?htmlDependency for more information."
108    )
109  }
110
111  version <- as.character(version)
112  validateScalarName(name)
113  validateScalarName(version)
114
115  srcNames <- names(src)
116  if (is.null(srcNames))
117    srcNames <- rep.int("", length(src))
118  srcNames[!nzchar(srcNames)] <- "file"
119  names(src) <- srcNames
120  src <- as.list(src)
121
122  structure(class = "html_dependency", list(
123    name = name,
124    version = as.character(version),
125    src = src,
126    meta = meta,
127    script = script,
128    stylesheet = stylesheet,
129    head = head,
130    attachment = attachment,
131    package = package,
132    all_files = all_files
133  ))
134}
135
136validateScalarName <- function(x, name = deparse(substitute(x))) {
137  if (length(x) != 1 || x == "" || grepl("[/\\]", x)) stop(
138    "Invalid argument '", name,
139    "' (must be a non-empty character string and contain no '/' or '\\')"
140  )
141}
142
143#' HTML dependency metadata
144#'
145#' Gets or sets the HTML dependencies associated with an object (such as a tag).
146#'
147#' `attachDependencies` provides an alternate syntax for setting
148#' dependencies. It is similar to \code{local(\{htmlDependencies(x) <- value;
149#' x\})}, except that if there are any existing dependencies,
150#' `attachDependencies` will add to them, instead of replacing them.
151#'
152#' As of htmltools 0.3.4, HTML dependencies can be attached without using
153#' `attachDependencies`. Instead, they can be added inline, like a child
154#' object of a tag or [tagList()].
155#'
156#' @param x An object which has (or should have) HTML dependencies.
157#' @param value An HTML dependency, or a list of HTML dependencies.
158#' @param append If FALSE (the default), replace any existing dependencies. If
159#'   TRUE, add the new dependencies to the existing ones.
160#'
161#' @examples
162#' # Create a JavaScript dependency
163#' dep <- htmlDependency("jqueryui", "1.11.4", c(href="shared/jqueryui"),
164#'                       script = "jquery-ui.min.js")
165#'
166#' # A CSS dependency
167#' htmlDependency(
168#'   "font-awesome", "4.5.0", c(href="shared/font-awesome"),
169#'   stylesheet = "css/font-awesome.min.css"
170#' )
171#'
172#' # A few different ways to add the dependency to tag objects:
173#' # Inline as a child of the div()
174#' div("Code here", dep)
175#' # Inline in a tagList
176#' tagList(div("Code here"), dep)
177#' # With attachDependencies
178#' attachDependencies(div("Code here"), dep)
179#'
180#' @export
181htmlDependencies <- function(x) {
182  attr(x, "html_dependencies", TRUE)
183}
184
185#' @rdname htmlDependencies
186#' @export
187`htmlDependencies<-` <- function(x, value) {
188  attr(x, "html_dependencies") <- asDependencies(value)
189  x
190}
191
192#' @rdname htmlDependencies
193#' @export
194attachDependencies <- function(x, value, append = FALSE) {
195  value <- asDependencies(value)
196
197  if (append) {
198    old <- attr(x, "html_dependencies", TRUE)
199    htmlDependencies(x) <- c(old, value)
200  } else {
201    htmlDependencies(x) <- value
202  }
203
204  return(x)
205}
206
207# This will _not_ execute tagFunction(), which is important for attachDependencies()
208asDependencies <- function(x) {
209  if (!length(x)) {
210    return(x)
211  }
212  if (is_dependency_maybe(x)) {
213    return(list(x))
214  }
215  x <- dropNulls(x)
216  if (all(vapply(x, is_dependency_maybe, logical(1)))) {
217    return(x)
218  }
219  stop("Could not coerce object of class '", class(x), "' into a list of HTML dependencies")
220}
221
222is_dependency_maybe <- function(x) {
223  is_html_dependency(x) || is_tag_function(x)
224}
225
226is_html_dependency <- function(x) {
227  inherits(x, "html_dependency")
228}
229
230is_tag_function <- function(x) {
231  inherits(x, "shiny.tag.function")
232}
233
234
235
236#' Suppress web dependencies
237#'
238#' This suppresses one or more web dependencies. It is meant to be used when a
239#' dependency (like a JavaScript or CSS file) is declared in raw HTML, in an
240#' HTML template.
241#'
242#' @param ... Names of the dependencies to suppress. For example,
243#'   `"jquery"` or `"bootstrap"`.
244#'
245#' @seealso [htmlTemplate()] for more information about using HTML
246#'   templates.
247#' @seealso [htmltools::htmlDependency()]
248#' @export
249suppressDependencies <- function(...) {
250  lapply(dots_list(...), function(name) {
251    attachDependencies(
252      character(0),
253      htmlDependency(name, "9999", c(href = ""))
254    )
255  })
256}
257
258#' @export
259print.html_dependency <- function(x, ...) str(x)
260
261dir_path <- function(dependency) {
262  if ("dir" %in% names(dependency$src))
263    return(dependency$src[["dir"]])
264
265  if (length(names(dependency$src)) == 0 || all(!nzchar(dependency$src)))
266    return(dependency$src[[1]])
267
268  return(NULL)
269}
270
271href_path <- function(dependency) {
272  if ("href" %in% names(dependency$src))
273    return(dependency$src[["href"]])
274  else
275    return(NULL)
276}
277
278#' Encode a URL path
279#'
280#' Encode characters in a URL path. This is the same as
281#' [utils::URLencode()] with `reserved = TRUE` except that
282#' `/` is preserved.
283#'
284#' @param x A character vector.
285#' @export
286urlEncodePath <- function(x) {
287  vURLEncode <- Vectorize(URLencode, USE.NAMES = FALSE)
288  gsub("%2[Ff]", "/", vURLEncode(x, TRUE))
289}
290
291#' Copy an HTML dependency to a directory
292#'
293#' Copies an HTML dependency to a subdirectory of the given directory. The
294#' subdirectory name will be *name*-*version* (for example,
295#' "outputDir/jquery-1.11.0"). You may set `options(htmltools.dir.version =
296#' FALSE)` to suppress the version number in the subdirectory name.
297#'
298#' In order for disk-based dependencies to work with static HTML files, it's
299#' generally necessary to copy them to either the directory of the referencing
300#' HTML file, or to a subdirectory of that directory. This function makes it
301#' easier to perform that copy.
302#'
303#' @param dependency A single HTML dependency object.
304#' @param outputDir The directory in which a subdirectory should be created for
305#'   this dependency.
306#' @param mustWork If `TRUE` and `dependency` does not point to a
307#'   directory on disk (but rather a URL location), an error is raised. If
308#'   `FALSE` then non-disk dependencies are returned without modification.
309#'
310#' @return The dependency with its `src` value updated to the new
311#'   location's absolute path.
312#'
313#' @seealso [makeDependencyRelative()] can be used with the returned
314#'   value to make the path relative to a specific directory.
315#'
316#' @export
317copyDependencyToDir <- function(dependency, outputDir, mustWork = TRUE) {
318
319  dir <- dependency$src$file
320
321  if (is.null(dir)) {
322    if (mustWork) {
323      stop("Dependency ", dependency$name, " ", dependency$version,
324           " is not disk-based")
325    } else {
326      return(dependency)
327    }
328  }
329  # resolve the relative file path to absolute path in package
330  if (!is.null(dependency$package))
331    dir <- system.file(dir, package = dependency$package)
332
333  if (length(outputDir) != 1 || outputDir %in% c("", "/"))
334    stop('outputDir must be of length 1 and cannot be "" or "/"')
335
336  if (!dir_exists(outputDir))
337    dir.create(outputDir)
338
339  target_dir <- if (getOption('htmltools.dir.version', TRUE)) {
340    paste(dependency$name, dependency$version, sep = "-")
341  } else dependency$name
342  target_dir <- file.path(outputDir, target_dir)
343
344  # completely remove the target dir because we don't want possible leftover
345  # files in the target dir, e.g. we may have lib/foo.js last time, and it was
346  # removed from the original library, then the next time we copy the library
347  # over to the target dir, we want to remove this lib/foo.js as well;
348  # unlink(recursive = TRUE) can be dangerous, e.g. we certainly do not want 'rm
349  # -rf /' to happen; in htmlDependency() we have made sure dependency$name and
350  # dependency$version are not "" or "/" or contains no / or \; we have also
351  # made sure outputDir is not "" or "/" above, so target_dir here should be
352  # relatively safe to be removed recursively
353  if (dir_exists(target_dir)) unlink(target_dir, recursive = TRUE)
354  dir.create(target_dir)
355
356  files <- if (dependency$all_files) list.files(dir) else {
357    unlist(dependency[c('script', 'stylesheet', 'attachment')])
358  }
359  srcfiles <- file.path(dir, files)
360  if (any(!file.exists(srcfiles))) {
361    stop(
362      sprintf(
363        "Can't copy dependency files that don't exist: '%s'",
364        paste(srcfiles, collapse = "', '")
365      )
366    )
367  }
368  destfiles <- file.path(target_dir, files)
369  isdir <- file.info(srcfiles)$isdir
370  destfiles <- ifelse(isdir, dirname(destfiles), destfiles)
371
372  mapply(function(from, to, isdir) {
373    if (!dir_exists(dirname(to)))
374      dir.create(dirname(to), recursive = TRUE)
375    if (isdir && !dir_exists(to))
376      dir.create(to)
377    file.copy(from, to, overwrite = TRUE, recursive = isdir, copy.mode = FALSE)
378  }, srcfiles, destfiles, isdir)
379
380  dependency$src$file <- normalizePath(target_dir, "/", TRUE)
381
382  dependency
383}
384
385dir_exists <- function(paths) {
386  utils::file_test("-d", paths)
387}
388
389# given a directory and a file, return a relative path from the directory to the
390# file, or the unmodified file path if the file does not appear to be in the
391# directory
392relativeTo <- function(dir, file) {
393  # ensure directory ends with a /
394  if (!identical(substr(dir, nchar(dir), nchar(dir)), "/")) {
395    dir <- paste(dir, "/", sep="")
396  }
397
398  # if the file is prefixed with the directory, return a relative path
399  if (identical(substr(file, 1, nchar(dir)), dir))
400    return(substr(file, nchar(dir) + 1, nchar(file)))
401  else
402    stop("The path ", file, " does not appear to be a descendant of ", dir)
403}
404
405#' Make an absolute dependency relative
406#'
407#' Change a dependency's absolute path to be relative to one of its parent
408#' directories.
409#'
410#' @param dependency A single HTML dependency with an absolute path.
411#' @param basepath The path to the directory that `dependency` should be
412#'   made relative to.
413#' @param mustWork If `TRUE` and `dependency` does not point to a
414#'   directory on disk (but rather a URL location), an error is raised. If
415#'   `FALSE` then non-disk dependencies are returned without modification.
416#'
417#' @return The dependency with its `src` value updated to the new
418#' location's relative path.
419#'
420#' If `baspath` did not appear to be a parent directory of the dependency's
421#' directory, an error is raised (regardless of the value of `mustWork`).
422#'
423#' @seealso [copyDependencyToDir()]
424#'
425#' @export
426makeDependencyRelative <- function(dependency, basepath, mustWork = TRUE) {
427  basepath <- normalizePath(basepath, "/", TRUE)
428  dir <- dependency$src$file
429  if (is.null(dir)) {
430    if (!mustWork)
431      return(dependency)
432    else
433      stop("Could not make dependency ", dependency$name, " ",
434           dependency$version, " relative; it is not file-based")
435  }
436
437  dependency$src <- c(file=relativeTo(basepath, dir))
438
439  dependency
440}
441
442#' Create HTML for dependencies
443#'
444#' Create the appropriate HTML markup for including dependencies in an HTML
445#' document.
446#'
447#' @param dependencies A list of `htmlDependency` objects.
448#' @param srcType The type of src paths to use; valid values are `file` or
449#'   `href`.
450#' @param encodeFunc The function to use to encode the path part of a URL. The
451#'   default should generally be used.
452#' @param hrefFilter A function used to transform the final, encoded URLs of
453#'   script and stylesheet files. The default should generally be used.
454#'
455#' @return An [HTML()] object suitable for inclusion in the head of an
456#'   HTML document.
457#'
458#' @export
459renderDependencies <- function(dependencies,
460  srcType = c("href", "file"),
461  encodeFunc = urlEncodePath,
462  hrefFilter = identity) {
463
464  html <- c()
465
466  for (dep in dependencies) {
467
468    usableType <- srcType[which(srcType %in% names(dep$src))]
469    if (length(usableType) == 0)
470      stop("Dependency ", dep$name, " ", dep$version,
471        " does not have a usable source")
472
473    dir <- dep$src[head(usableType, 1)]
474
475    srcpath <- if (usableType == "file") {
476      encodeFunc(dir)
477    } else {
478      # Assume that href is already URL encoded
479      href_path(dep)
480    }
481
482    # Drop trailing /
483    srcpath <- sub("/$", "\\1", srcpath)
484
485    # add meta content
486    if (length(dep$meta) > 0) {
487      html <- c(html, paste(
488        "<meta name=\"", htmlEscape(names(dep$meta)), "\" content=\"",
489        htmlEscape(dep$meta), "\" />",
490        sep = ""
491      ))
492    }
493
494    # add stylesheets
495    if (length(dep$stylesheet) > 0) {
496      html <- c(html, paste(
497        "<link href=\"",
498        htmlEscape(hrefFilter(file.path(srcpath, encodeFunc(dep$stylesheet)))),
499        "\" rel=\"stylesheet\" />",
500        sep = ""
501      ))
502    }
503
504    # add scripts
505    if (length(dep$script) > 0) {
506      html <- c(html, renderScript(dep$script, srcpath, encodeFunc, hrefFilter))
507    }
508
509    if (length(dep$attachment) > 0) {
510      if (is.null(names(dep$attachment)))
511        names(dep$attachment) <- as.character(1:length(dep$attachment))
512      html <- c(html,
513        sprintf("<link id=\"%s-%s-attachment\" rel=\"attachment\" href=\"%s\"/>",
514          htmlEscape(dep$name),
515          htmlEscape(names(dep$attachment)),
516          htmlEscape(hrefFilter(file.path(srcpath, encodeFunc(dep$attachment))))
517        )
518      )
519    }
520
521    # add raw head content
522    html <- c(html, dep$head)
523  }
524
525  HTML(paste(html, collapse = "\n"))
526}
527
528
529
530renderScript <- function(script, srcpath, encodeFunc, hrefFilter) {
531  # If the input is a named list, transform it to an unnamed list
532  # whose only element is the input list
533  if (anyNamed(script)) {
534    if (anyUnnamed(script)) stop("script inputs cannot mix named and unnamed")
535    script <- list(script)
536  }
537
538  # For each element, if it's a scalar string, transform it to a named
539  # list with one element, "src".
540  script <- lapply(script, function(item) {
541    if (length(item) == 1 && is.character(item)) {
542      item = list(src = item)
543    }
544
545    if (length(names(item)) == 0) {
546      stop(
547        "Elements of script must be named lists, or scalar strings ",
548        "I got ", deparse(item)
549      )
550    }
551
552    return(item)
553  })
554
555  script <- vapply(
556    script, function(x) {
557      x$src <- hrefFilter(file.path(srcpath, encodeFunc(x$src)))
558      paste0(
559        "<script",
560        paste0(
561         " ",
562         htmlEscape(names(x)),
563         ifelse(is.na(x), "", paste0('="', htmlEscape(x), '"')),
564         collapse = ''
565        ),
566      "></script>",
567      collapse = ""
568      )
569    },
570    FUN.VALUE = character(1)
571  )
572
573  return(script)
574}
575
576
577# html_dependencies_as_character(list(
578#   htmlDependency("foo", "1.0",
579#     c(href="http://foo.com/bar%20baz/"),
580#     stylesheet="x y z.css"
581#   )
582# ))
583# <link href=\"http://foo.com/bar%20baz/x%20y%20z.css\" rel=\"stylesheet\" />
584
585# html_dependencies_as_character(list(
586#   htmlDependency("foo", "1.0",
587#     c(href="http://foo.com/bar%20baz"),
588#     stylesheet="x y z.css"
589#   )
590# ))
591# <link href=\"http://foo.com/bar%20baz/x%20y%20z.css\" rel=\"stylesheet\" />
592
593# html_dependencies_as_character(list(
594#   htmlDependency("foo", "1.0",
595#     "foo bar/baz",
596#     stylesheet="x y z.css"
597#   )
598# ))
599# <link href=\"foo%20bar/baz/x%20y%20z.css\" rel=\"stylesheet\" />
600
601# html_dependencies_as_character(list(
602#   htmlDependency("foo", "1.0",
603#     "foo bar/baz/",
604#     stylesheet="x y z.css"
605#   )
606# ))
607# <link href=\"foo%20bar/baz/x%20y%20z.css\" rel=\"stylesheet\" />
608