R/html_dependency.R

In rstudio/htmltools: Tools for HTML

#' Define an HTML dependency
#'
#' Define an HTML dependency (i.e. CSS and/or JavaScript bundled in a
#' directory). HTML dependencies make it possible to use libraries like jQuery,
#' Bootstrap, and d3 in a more composable and portable way than simply using
#' script, link, and style tags.
#'
#' @param name Library name
#' @param version Library version
#' @param src Unnamed single-element character vector indicating the full path
#'   of the library directory. Alternatively, a named character string with one
#'   or more elements, indicating different places to find the library; see
#'   Details.
#' @param meta Named list of meta tags to insert into document head
#' @param script Script(s) to include within the document head (should be
#'   specified relative to the `src` parameter).
#' @param stylesheet Stylesheet(s) to include within the document (should be
#'   specified relative to the `src` parameter).
#' @param head Arbitrary lines of HTML to insert into the document head
#' @param attachment Attachment(s) to include within the document head. See
#'   Details.
#' @param package An R package name to indicate where to find the `src`
#'   directory when `src` is a relative path (see
#'   [resolveDependencies()]).
#' @param all_files Whether all files under the `src` directory are
#'   dependency files. If `FALSE`, only the files specified in
#'   `script`, `stylesheet`, and `attachment` are treated as
#'   dependency files.
#'
#' @return An object that can be included in a list of dependencies passed to
#'   [attachDependencies()].
#'
#' @details Each dependency can be located on the filesystem, at a relative or
#'   absolute URL, or both. The location types are indicated using the names of
#'   the `src` character vector: `file` for filesystem directory,
#'   `href` for URL. For example, a dependency that was both on disk and at
#'   a URL might use `src = c(file=filepath, href=url)`.
#'
#'   `script` can be given as one of the following:
#'   \itemize{
#'   \item a character vector specifying various scripts to include relative to the
#'     value of `src`.
#'     Each is expanded into its own `<script>` tag
#'   \item A named list with any of the following fields:
#'   \itemize{
#'     \item `src`,
#'     \item `integrity`, &
#'     \item `crossorigin`,
#'     \item any other valid `<script>` attributes.
#'     }
#'     allowing the use of SRI to ensure the integrity of packages downloaded from
#'     remote servers.
#'     Eg: `script = list(src = "min.js", integrity = "hash")`
#'   \item An unnamed list, containing a combination of named list with the fields
#'     mentioned previously, and strings.
#'     Eg:
#'     \itemize{
#'     \item `script = list(list(src = "min.js"), "util.js", list(src = "log.js"))`
#'     \item `script = "pkg.js"` is equivalent to
#'     \item `script = list(src = "pkg.js")`.
#'     }
#'   }
#'
#'   `attachment` can be used to make the indicated files available to the
#'   JavaScript on the page via URL. For each element of `attachment`, an
#'   element `<link id="DEPNAME-ATTACHINDEX-attachment" rel="attachment"
#'   href="...">` is inserted, where `DEPNAME` is `name`. The value of
#'   `ATTACHINDEX` depends on whether `attachment` is named or not; if
#'   so, then it's the name of the element, and if not, it's the 1-based index
#'   of the element. JavaScript can retrieve the URL using something like
#'   `document.getElementById(depname + "-" + index + "-attachment").href`.
#'   Note that depending on the rendering context, the runtime value of the href
#'   may be an absolute, relative, or data URI.
#'
#'   `htmlDependency` should not be called from the top-level of a package
#'   namespace with absolute paths (or with paths generated by
#'   `system.file()`) and have the result stored in a variable. This is
#'   because, when a binary package is built, R will run `htmlDependency`
#'   and store the path from the building machine's in the package. This path is
#'   likely to differ from the correct path on a machine that downloads and
#'   installs the binary package. If there are any absolute paths, instead of
#'   calling `htmlDependency` at build-time, it should be called at
#'   run-time. This can be done by wrapping the `htmlDependency` call in a
#'   function.
#'
#' @seealso Use [attachDependencies()] to associate a list of
#'   dependencies with the HTML it belongs with.
#'   The shape of the `htmlDependency` object is described (in TypeScript code)
#'   [here](https://github.com/rstudio/shiny/blob/474f1400/srcts/src/shiny/render.ts#L79-L115).
#'
#' @export
htmlDependency <- function(name,
                           version,
                           src,
                           meta = NULL,
                           script = NULL,
                           stylesheet = NULL,
                           head = NULL,
                           attachment = NULL,
                           package = NULL,
                           all_files = TRUE) {

  # This function shouldn't be called from a namespace environment with
  # absolute paths.
  if (isNamespace(parent.frame()) && any(substr(src, 1, 1) == "/")) {
    warning(
      "htmlDependency shouldn't be called from a namespace environment",
      " with absolute paths (or paths from system.file()).",
      " See ?htmlDependency for more information."
    )
  }

  version <- as.character(version)
  validateScalarName(name)
  validateScalarName(version)

  srcNames <- names(src)
  if (is.null(srcNames))
    srcNames <- rep.int("", length(src))
  srcNames[!nzchar(srcNames)] <- "file"
  names(src) <- srcNames
  src <- as.list(src)

  structure(class = "html_dependency", list(
    name = name,
    version = as.character(version),
    src = src,
    meta = meta,
    script = script,
    stylesheet = stylesheet,
    head = head,
    attachment = attachment,
    package = package,
    all_files = all_files
  ))
}

validateScalarName <- function(x, name = deparse(substitute(x))) {
  if (length(x) != 1 || x == "" || grepl("[/\\]", x)) stop(
    "Invalid argument '", name,
    "' (must be a non-empty character string and contain no '/' or '\\')"
  )
}

#' HTML dependency metadata
#'
#' Gets or sets the HTML dependencies associated with an object (such as a tag).
#'
#' `attachDependencies` provides an alternate syntax for setting
#' dependencies. It is similar to \code{local(\{htmlDependencies(x) <- value;
#' x\})}, except that if there are any existing dependencies,
#' `attachDependencies` will add to them, instead of replacing them.
#'
#' As of htmltools 0.3.4, HTML dependencies can be attached without using
#' `attachDependencies`. Instead, they can be added inline, like a child
#' object of a tag or [tagList()].
#'
#' @param x An object which has (or should have) HTML dependencies.
#' @param value An HTML dependency, or a list of HTML dependencies.
#' @param append If FALSE (the default), replace any existing dependencies. If
#'   TRUE, add the new dependencies to the existing ones.
#'
#' @examples
#' # Create a JavaScript dependency
#' dep <- htmlDependency("jqueryui", "1.11.4", c(href="shared/jqueryui"),
#'                       script = "jquery-ui.min.js")
#'
#' # A CSS dependency
#' htmlDependency(
#'   "font-awesome", "4.5.0", c(href="shared/font-awesome"),
#'   stylesheet = "css/font-awesome.min.css"
#' )
#'
#' # A few different ways to add the dependency to tag objects:
#' # Inline as a child of the div()
#' div("Code here", dep)
#' # Inline in a tagList
#' tagList(div("Code here"), dep)
#' # With attachDependencies
#' attachDependencies(div("Code here"), dep)
#'
#' @export
htmlDependencies <- function(x) {
  attr(x, "html_dependencies", TRUE)
}

#' @rdname htmlDependencies
#' @export
`htmlDependencies<-` <- function(x, value) {
  attr(x, "html_dependencies") <- asDependencies(value)
  x
}

#' @rdname htmlDependencies
#' @export
attachDependencies <- function(x, value, append = FALSE) {
  value <- asDependencies(value)

  if (append) {
    old <- attr(x, "html_dependencies", TRUE)
    htmlDependencies(x) <- c(old, value)
  } else {
    htmlDependencies(x) <- value
  }

  return(x)
}

# This will _not_ execute tagFunction(), which is important for attachDependencies()
asDependencies <- function(x) {
  if (!length(x)) {
    return(x)
  }
  if (is_dependency_maybe(x)) {
    return(list(x))
  }
  x <- dropNulls(x)
  if (all(vapply(x, is_dependency_maybe, logical(1)))) {
    return(x)
  }
  stop("Could not coerce object of class '", class(x), "' into a list of HTML dependencies")
}

is_dependency_maybe <- function(x) {
  is_html_dependency(x) || is_tag_function(x)
}

is_html_dependency <- function(x) {
  inherits(x, "html_dependency")
}

is_tag_function <- function(x) {
  inherits(x, "shiny.tag.function")
}



#' Suppress web dependencies
#'
#' This suppresses one or more web dependencies. It is meant to be used when a
#' dependency (like a JavaScript or CSS file) is declared in raw HTML, in an
#' HTML template.
#'
#' @param ... Names of the dependencies to suppress. For example,
#'   `"jquery"` or `"bootstrap"`.
#'
#' @seealso [htmlTemplate()] for more information about using HTML
#'   templates.
#' @seealso [htmltools::htmlDependency()]
#' @export
suppressDependencies <- function(...) {
  lapply(dots_list(...), function(name) {
    attachDependencies(
      character(0),
      htmlDependency(name, "9999", c(href = ""))
    )
  })
}

#' @export
print.html_dependency <- function(x, ...) str(x)

dir_path <- function(dependency) {
  if ("dir" %in% names(dependency$src))
    return(dependency$src[["dir"]])

  if (length(names(dependency$src)) == 0 || all(!nzchar(dependency$src)))
    return(dependency$src[[1]])

  return(NULL)
}

href_path <- function(dependency) {
  if ("href" %in% names(dependency$src))
    return(dependency$src[["href"]])
  else
    return(NULL)
}

#' Encode a URL path
#'
#' Encode characters in a URL path. This is the same as
#' [utils::URLencode()] with `reserved = TRUE` except that
#' `/` is preserved.
#'
#' @param x A character vector.
#' @export
urlEncodePath <- function(x) {
  vURLEncode <- Vectorize(URLencode, USE.NAMES = FALSE)
  gsub("%2[Ff]", "/", vURLEncode(x, TRUE))
}

#' Copy an HTML dependency to a directory
#'
#' Copies an HTML dependency to a subdirectory of the given directory. The
#' subdirectory name will be *name*-*version* (for example,
#' "outputDir/jquery-1.11.0"). You may set `options(htmltools.dir.version =
#' FALSE)` to suppress the version number in the subdirectory name.
#'
#' In order for disk-based dependencies to work with static HTML files, it's
#' generally necessary to copy them to either the directory of the referencing
#' HTML file, or to a subdirectory of that directory. This function makes it
#' easier to perform that copy.
#'
#' @param dependency A single HTML dependency object.
#' @param outputDir The directory in which a subdirectory should be created for
#'   this dependency.
#' @param mustWork If `TRUE` and `dependency` does not point to a
#'   directory on disk (but rather a URL location), an error is raised. If
#'   `FALSE` then non-disk dependencies are returned without modification.
#'
#' @return The dependency with its `src` value updated to the new
#'   location's absolute path.
#'
#' @seealso [makeDependencyRelative()] can be used with the returned
#'   value to make the path relative to a specific directory.
#'
#' @export
copyDependencyToDir <- function(dependency, outputDir, mustWork = TRUE) {

  dir <- dependency$src$file

  if (is.null(dir)) {
    if (mustWork) {
      stop("Dependency ", dependency$name, " ", dependency$version,
           " is not disk-based")
    } else {
      return(dependency)
    }
  }
  # resolve the relative file path to absolute path in package
  if (!is.null(dependency$package))
    dir <- system_file(dir, package = dependency$package)

  if (length(outputDir) != 1 || outputDir %in% c("", "/"))
    stop('outputDir must be of length 1 and cannot be "" or "/"')

  if (!dir_exists(outputDir))
    dir.create(outputDir, recursive = TRUE)

  target_dir <- if (getOption('htmltools.dir.version', TRUE)) {
    paste(dependency$name, dependency$version, sep = "-")
  } else dependency$name
  target_dir <- file.path(outputDir, target_dir)

  # completely remove the target dir because we don't want possible leftover
  # files in the target dir, e.g. we may have lib/foo.js last time, and it was
  # removed from the original library, then the next time we copy the library
  # over to the target dir, we want to remove this lib/foo.js as well;
  # unlink(recursive = TRUE) can be dangerous, e.g. we certainly do not want 'rm
  # -rf /' to happen; in htmlDependency() we have made sure dependency$name and
  # dependency$version are not "" or "/" or contains no / or \; we have also
  # made sure outputDir is not "" or "/" above, so target_dir here should be
  # relatively safe to be removed recursively
  if (dir_exists(target_dir)) unlink(target_dir, recursive = TRUE)
  dir.create(target_dir)
  dependency$src$file <- normalizePath(target_dir, "/", TRUE)

  if (dependency$all_files)
    files <- list.files(dir)
  else
    files <- c(find_dep_filenames(dependency$script, "src"),
               find_dep_filenames(dependency$stylesheet, "href"),
               find_dep_filenames(dependency$attachment, "href"))

  if (length(files) == 0) {
    # This dependency doesn't include any files
    # no need to copy and we can clean up the target directory
    unlink(target_dir, recursive = TRUE)
    return(dependency)
  }

  srcfiles <- file.path(dir, files)
  missing_srcfiles <- !file.exists(srcfiles)
  if (any(missing_srcfiles)) {
    stop(
      sprintf(
        "Can't copy dependency files that don't exist: '%s'",
        paste(srcfiles[missing_srcfiles], collapse = "', '")
      )
    )
  }
  destfiles <- file.path(target_dir, files)
  isdir <- file.info(srcfiles)$isdir
  destfiles <- ifelse(isdir, dirname(destfiles), destfiles)

  mapply(function(from, to, isdir) {
    if (!dir_exists(dirname(to)))
      dir.create(dirname(to), recursive = TRUE)
    if (isdir && !dir_exists(to))
      dir.create(to)
    file.copy(from, to, overwrite = TRUE, recursive = isdir, copy.mode = FALSE)
  }, srcfiles, destfiles, isdir)

  dependency
}

dir_exists <- function(paths) {
  utils::file_test("-d", paths)
}

# given a directory and a file, return a relative path from the directory to the
# file, or the unmodified file path if the file does not appear to be in the
# directory
relativeTo <- function(dir, file) {
  # ensure directory ends with a /
  if (!identical(substr(dir, nchar(dir), nchar(dir)), "/")) {
    dir <- paste(dir, "/", sep="")
  }

  # if the file is prefixed with the directory, return a relative path
  if (identical(substr(file, 1, nchar(dir)), dir))
    return(substr(file, nchar(dir) + 1, nchar(file)))
  else
    stop("The path ", file, " does not appear to be a descendant of ", dir)
}

#' Make an absolute dependency relative
#'
#' Change a dependency's absolute path to be relative to one of its parent
#' directories.
#'
#' @param dependency A single HTML dependency with an absolute path.
#' @param basepath The path to the directory that `dependency` should be
#'   made relative to.
#' @param mustWork If `TRUE` and `dependency` does not point to a
#'   directory on disk (but rather a URL location), an error is raised. If
#'   `FALSE` then non-disk dependencies are returned without modification.
#'
#' @return The dependency with its `src` value updated to the new
#' location's relative path.
#'
#' If `baspath` did not appear to be a parent directory of the dependency's
#' directory, an error is raised (regardless of the value of `mustWork`).
#'
#' @seealso [copyDependencyToDir()]
#'
#' @export
makeDependencyRelative <- function(dependency, basepath, mustWork = TRUE) {
  basepath <- normalizePath(basepath, "/", TRUE)
  dir <- dependency$src$file
  if (is.null(dir)) {
    if (!mustWork)
      return(dependency)
    else
      stop("Could not make dependency ", dependency$name, " ",
           dependency$version, " relative; it is not file-based")
  }

  dependency$src <- c(file=relativeTo(basepath, dir))

  dependency
}

#' Create HTML for dependencies
#'
#' Create the appropriate HTML markup for including dependencies in an HTML
#' document.
#'
#' @param dependencies A list of `htmlDependency` objects.
#' @param srcType The type of src paths to use; valid values are `file` or
#'   `href`.
#' @param encodeFunc The function to use to encode the path part of a URL. The
#'   default should generally be used.
#' @param hrefFilter A function used to transform the final, encoded URLs of
#'   script and stylesheet files. The default should generally be used.
#'
#' @return An [HTML()] object suitable for inclusion in the head of an
#'   HTML document.
#'
#' @export
renderDependencies <- function(dependencies,
  srcType = c("href", "file"),
  encodeFunc = urlEncodePath,
  hrefFilter = identity) {

  html <- c()

  for (dep in dependencies) {

    usableType <- srcType[which(srcType %in% names(dep$src))]
    if (length(usableType) == 0)
      stop("Dependency ", dep$name, " ", dep$version,
        " does not have a usable source")

    dir <- dep$src[head(usableType, 1)]

    srcpath <- if (usableType == "file") {
      encodeFunc(dir)
    } else {
      # Assume that href is already URL encoded
      href_path(dep)
    }

    # Drop trailing /
    srcpath <- sub("/$", "\\1", srcpath)

    # add meta content
    if (length(dep$meta) > 0) {
      html <- c(html, paste(
        "<meta name=\"", htmlEscape(names(dep$meta)), "\" content=\"",
        htmlEscape(dep$meta), "\" />",
        sep = ""
      ))
    }

    # add stylesheets
    if (length(dep$stylesheet) > 0) {
      html <- c(html, paste(
        "<link href=\"",
        htmlEscape(hrefFilter(file.path(srcpath, encodeFunc(dep$stylesheet)))),
        "\" rel=\"stylesheet\" />",
        sep = ""
      ))
    }

    # add scripts
    if (length(dep$script) > 0) {
      html <- c(html, renderScript(dep$script, srcpath, encodeFunc, hrefFilter))
    }

    if (length(dep$attachment) > 0) {
      if (is.null(names(dep$attachment)))
        names(dep$attachment) <- as.character(1:length(dep$attachment))
      html <- c(html,
        sprintf("<link id=\"%s-%s-attachment\" rel=\"attachment\" href=\"%s\"/>",
          htmlEscape(dep$name),
          htmlEscape(names(dep$attachment)),
          htmlEscape(hrefFilter(file.path(srcpath, encodeFunc(dep$attachment))))
        )
      )
    }

    # add raw head content
    html <- c(html, dep$head)
  }

  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)),
         ifelse(is.na(x), "", paste0('="', 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/"),
#     stylesheet="x y z.css"
#   )
# ))
# <link href=\"http://foo.com/bar%20baz/x%20y%20z.css\" rel=\"stylesheet\" />

# html_dependencies_as_character(list(
#   htmlDependency("foo", "1.0",
#     c(href="http://foo.com/bar%20baz"),
#     stylesheet="x y z.css"
#   )
# ))
# <link href=\"http://foo.com/bar%20baz/x%20y%20z.css\" rel=\"stylesheet\" />

# html_dependencies_as_character(list(
#   htmlDependency("foo", "1.0",
#     "foo bar/baz",
#     stylesheet="x y z.css"
#   )
# ))
# <link href=\"foo%20bar/baz/x%20y%20z.css\" rel=\"stylesheet\" />

# html_dependencies_as_character(list(
#   htmlDependency("foo", "1.0",
#     "foo bar/baz/",
#     stylesheet="x y z.css"
#   )
# ))
# <link href=\"foo%20bar/baz/x%20y%20z.css\" rel=\"stylesheet\" />