webtools: Web Server Tools

Documented in html_render

#' @title HTML Rendering Utilities
#'
#' @description
#' Tools to render HTML in support of the [`HTMLPlugin`].
#'
#' @param tags     (tgs) tags that will be rendered
#' @param libs     (pth) where the dependency files will be rendered
#' @param lang     (str) language of the document
#' @param existing (str) name-version of already existing dependencies
#' @param fragment (flg) whether or not to render a full document or fragment
#'
#' @export
html_render <- function(tags,
                        libs = "assets",
                        lang = "en",
                        existing = c(),
                        fragment = FALSE) {

  assert_multi_class(tags, c("shiny.tag", "shiny.tag.list"))
  assert_string(lang)

  tags <- renderTags(tags)
  if (fragment) return(tags$html)
  body <- str_detect(str_to_lower(tags$html), "<body>")
  deps <- html_render_dependencies(tags$dependencies, libs, existing)

  paste(
    "<!DOCTYPE html>",
    glue("<html lang={lang}>"),
    "<head>",
    "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=utf-8\"/>",
    renderDependencies(deps),
    tags$head,
    "</head>",
    if (!body) "<body>",
    tags$html,
    if (!body) "</body>",
    "</html>",
    collapse = "\n"
  ) %>%
    HTML() %>%
    add_attr(deps = names(deps))

}

html_render_dependencies <- function(deps, libs, existing) {

  assert_directory_exists(dir_create(assert_string(libs)))

  deps %>%
    set_names(map_chr(., ~paste(.$name, .$version, sep = "-"))) %>%
    imap(function(dep, name) {
      if (is.null(dep$src$file)) {
        dep
      } else if (name %in% existing) {
        dep$src$file <- normalizePath(path(libs, name), "/", TRUE)
        dep
      } else {
        html_copy_dependency(dep, libs, FALSE)
      }
    }) %>%
    map(makeDependencyRelative, path_dir(libs), FALSE)

}

html_copy_dependency <- function(dep, output_dir, must_work = TRUE) {

  dir <- dep$src$file

  if (is.null(dir)) {
    if (must_work) {
      stop("Dependency ", dep$name, " ", dep$version, " is not disk-based")
    } else {
      return(dep)
    }
  }
  if (!is.null(dep$package))
    dir <- path_package(package = dep$package, dir)

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

  dir_create(output_dir)

  target_dir <- path(output_dir, paste(dep$name, dep$version, sep = "-"))
  if (dir_exists(target_dir)) dir_delete(target_dir)
  dir_create(target_dir)

  files <- if (dep$all_files) {
    list.files(dir)
  } else {
    c(
      unlist(dep[c("stylesheet", "attachment")]),
      if (is.null(dep$script)) {
        NULL
      } else if (is.character(dep$script)) {
        dep$script
      } else if (is.list(dep$script)) {
        if (any(names(dep$script) != "")) {
          dep$script$src
        } else {
          map_chr(dep$script, ~if (is.character(.)) {
            .
          } else if (is.list(.)) {
            .$src
          })
        }
      }
    )
  }

  src_files <- path(dir, files)
  if (any(!file_exists(src_files))) {
    stop(glue(
      "Can't copy dependency files that don't exist: ",
      paste(src_files, collapse = ",")
    ))
  }

  src_isdir <- file.info(src_files)$isdir
  dst_files <-
    path(target_dir, files) %>%
    map2_chr(src_isdir, ~ifelse(.y, path_dir(.x), .x))

  pwalk(
    list(src_files, dst_files, src_isdir),
    function(src, dst, isdir) {
      if (!dir_exists(path_dir(dst)))
        dir_create(path_dir(dst)) # nocov
      if (isdir && !dir_exists(dst))
        dir_create(dst) # nocov
      file.copy(src, dst,
                overwrite = TRUE,
                recursive = isdir,
                copy.mode = FALSE)
    }
  )

  dep$src$file <- normalizePath(target_dir, "/", TRUE)

  return(dep)

}