Merge pull request #431 from carpentries/update-404-page

Update 404 page

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: sandpaper
 Title: Create and Curate Carpentries Lessons
-Version: 0.11.14
+Version: 0.11.15
 Authors@R: c(
     person(given = "Zhian N.",
            family = "Kamvar",

NEWS.md

@@ -1,3 +1,12 @@
+# sandpaper 0.11.15 (2023-04-05)
+
+## BUG FIX
+
+* The 404 page will now have proper styling applied when the site is deployed
+  via one of the `ci_` functions (reported: @zkamvar, #430; fixed: @zkamvar,
+  #431).
+* `sandpaper::serve()` will no longer error if a different directory is used.
+
 # sandpaper 0.11.14 (2023-04-04)
 
 ## BUG FIX

R/build_404.R

@@ -1,20 +1,37 @@
 build_404 <- function(pkg, quiet) {
   page_globals <- setup_page_globals()
+  calls <- sys.calls()
+  is_prod <- in_production(calls)
+  if (is_prod) {
+    url  <- page_globals$metadata$get()$url
+    page_globals$instructor$set(c("site", "root"), url)
+    page_globals$learner$set(c("site", "root"), url)
+  }
   path  <- root_path(pkg$src_path)
+
   fof <- fs::path_package("sandpaper", "templates", "404-template.txt")
   html <- xml2::read_html(render_html(fof))
+  if (is_prod) {
+    # make sure index links back to the original root
+    lnk <- xml2::xml_find_first(html, ".//a[@href='index.html']")
+    xml2::xml_set_attr(lnk, "href", url)
+    # update navigation so that we have full URL
+    nav <- page_globals$learner$get()[c("sidebar", "more", "resources")]
+    for (item in names(nav)) {
+      new <- gsub("href='", paste0("href='", url), nav[[item]])
+      page_globals$learner$set(item, new)
+      page_globals$instructor$set(item, new)
+    }
+  }
   fix_nodes(html)
 
   this_dat <- list(
     this_page = "404.html",
-    body = use_instructor(html),
+    body = html,
     pagetitle = "Page not found"
   )
   page_globals$instructor$update(this_dat)
-
-  this_dat$body = use_learner(html)
   page_globals$learner$update(this_dat)
-
   page_globals$meta$update(this_dat)
 
   build_html(template = "extra", pkg = pkg, nodes = html,

R/build_episode.R

@@ -8,12 +8,12 @@
 #'   (usually via [build_episode_md()]).
 #' @param path_src the default is `NULL` indicating that the source file should
 #'   be determined from the `sandpaper-source` entry in the yaml header. If this
-#'   is not present, then this option allows you to specify that file. 
+#'   is not present, then this option allows you to specify that file.
 #' @param page_back the URL for the previous page
 #' @param page_forward the URL for the next page
 #' @param pkg a `pkgdown` object containing metadata for the site
 #' @param quiet if `TRUE`, messages are not produced. Defaults to `TRUE`.
-#' @param page_progress an integer between 0 and 100 indicating the rounded 
+#' @param page_progress an integer between 0 and 100 indicating the rounded
 #'   percent of the page progress. Defaults to NULL.
 #' @param sidebar a character vector of links to other episodes to use for the
 #'   sidebar. The current episode will be replaced with an index of all the
@@ -22,14 +22,14 @@
 #' @return `TRUE` if the page was successful, `FALSE` otherwise.
 #' @export
 #' @note this function is for internal use, but exported for those who know what
-#'   they are doing. 
+#'   they are doing.
 #' @keywords internal
 #' @seealso [build_episode_md()], [build_lesson()], [build_markdown()], [render_html()]
 #' @examples
 #' if (FALSE) {
 #' # 2022-04-15: this suddenly started throwing a check error
 #' # that says "connections left open: (file) and I can't figure out where the
-#' # hell its coming from, so I'm just going to not run this :( 
+#' # hell its coming from, so I'm just going to not run this :(
 #' if (.Platform$OS.type == "windows") {
 #'   options("sandpaper.use_renv" = FALSE)
 #' }
@@ -50,7 +50,7 @@
 #' fun_file <- file.path(tmp, "episodes", "files", "fun.Rmd")
 #' txt <- c(
 #'  "---\ntitle: Fun times\n---\n\n",
-#'  "# new page\n", 
+#'  "# new page\n",
 #'  "This is coming from `r R.version.string`\n",
 #'  "::: testimonial\n\n#### testimony!\n\nwhat\n:::\n"
 #' )
@@ -64,14 +64,14 @@
 #'   sandpaper:::set_globals(res)
 #'   on.exit(clear_globals(), add = TRUE)
 #'   # we can only build this if we have pandoc
-#'   build_episode_html(res, path_src = fun_file, 
+#'   build_episode_html(res, path_src = fun_file,
 #'     pkg = pkgdown::as_pkgdown(file.path(tmp, "site"))
 #'   )
 #' }
 #' }
-build_episode_html <- function(path_md, path_src = NULL, 
-                               page_back = "index.md", page_forward = "index.md", 
-                               pkg, quiet = FALSE, page_progress = NULL, 
+build_episode_html <- function(path_md, path_src = NULL,
+                               page_back = "index.md", page_forward = "index.md",
+                               pkg, quiet = FALSE, page_progress = NULL,
                                sidebar = NULL, date = NULL) {
   home <- root_path(path_md)
   this_lesson(home)
@@ -87,7 +87,7 @@ build_episode_html <- function(path_md, path_src = NULL,
 
   # setup varnish data
   this_page <- as_html(path_md)
-  nav_list <- get_nav_data(path_md, path_src, home, 
+  nav_list <- get_nav_data(path_md, path_src, home,
     this_page, page_back, page_forward)
 
   page_globals$metadata$update(c(nav_list, list(date = list(modified = date))))
@@ -109,30 +109,13 @@ build_episode_html <- function(path_md, path_src = NULL,
 
 }
 
-update_sidebar <- function(sidebar = NULL, nodes = NULL, path_md = NULL, title = NULL, instructor = TRUE) {
-  if (is.null(sidebar)) return(sidebar)
-  if (inherits(sidebar, "list-store")) {
-    # if it's a list store, then we need to get the sidebar and update itself
-    title <- if (is.null(title)) sidebar$get()[["pagetitle"]] else title
-    sb <- update_sidebar(sidebar$get()[["sidebar"]], nodes, path_md, title,
-      instructor)
-    sidebar$set("sidebar", paste(sb, collapse = "\n"))
-  }
-  this_page <- as_html(path_md)
-  to_change <- grep(paste0("[<]a href=['\"]", this_page, "['\"]"), sidebar)
-  if (length(to_change)) {
-    sidebar[to_change] <- create_sidebar_item(nodes, title, "current")
-  }
-  sidebar
-}
-
 #' Generate the navigation data for a page
 #'
 #' @inheritParams build_episode_html
 #' @param home the path to the lesson home
 #' @param this_page the current page relative html address
 #' @keywords internal
-get_nav_data <- function(path_md, path_src = NULL, home = NULL, 
+get_nav_data <- function(path_md, path_src = NULL, home = NULL,
   this_page = NULL, page_back = NULL, page_forward = NULL) {
   if (is.null(home)) {
     home <- root_path(path_md)
@@ -171,16 +154,16 @@ get_nav_data <- function(path_md, path_src = NULL, home = NULL,
 #'
 #' This uses [knitr::knit()] with custom options set for the Carpentries
 #' template. It runs in a separate process to avoid issues with user-specific
-#' options bleeding in. 
+#' options bleeding in.
 #'
 #' @param path path to the RMarkdown file
 #' @param hash hash to prepend to the output. This parameter is deprecated and
 #'   is effectively useless.
 #' @param outdir the directory to write to
 #' @param workdir the directory where the episode should be rendered
 #' @param workenv an environment to use for evaluation. Defaults to the global
-#'   environment, which evaluates to the environment from [callr::r()]. 
-#' @param quiet if `TRUE`, output is suppressed, default is `FALSE` to show 
+#'   environment, which evaluates to the environment from [callr::r()].
+#' @param quiet if `TRUE`, output is suppressed, default is `FALSE` to show
 #'   {knitr} output.
 #' @param error if `TRUE` (default) errors do not make an invalid build.
 #'   This can be set to false to cause the build to fail if an error occurs.
@@ -189,7 +172,7 @@ get_nav_data <- function(path_md, path_src = NULL, home = NULL,
 #' @keywords internal
 #' @export
 #' @note this function is for internal use, but exported for those who know what
-#'   they are doing. 
+#'   they are doing.
 #' @seealso [render_html()], [build_episode_html()]
 #' @examples
 #' if (.Platform$OS.type == "windows") {
@@ -206,23 +189,23 @@ get_nav_data <- function(path_md, path_src = NULL, home = NULL,
 #' file.create(fun_file)
 #' txt <- c(
 #'  "---\ntitle: Fun times\n---\n\n",
-#'  "# new page\n", 
+#'  "# new page\n",
 #'  "This is coming from `r R.version.string`"
 #' )
 #' writeLines(txt, fun_file)
 #' res <- build_episode_md(fun_file, outdir = fun_dir, workdir = fun_dir)
-build_episode_md <- function(path, hash = NULL, outdir = path_built(path), 
-                             workdir = path_built(path), 
-                             workenv = globalenv(), 
-                             profile = "lesson-requirements", 
+build_episode_md <- function(path, hash = NULL, outdir = path_built(path),
+                             workdir = path_built(path),
+                             workenv = globalenv(),
+                             profile = "lesson-requirements",
                              quiet = FALSE,
                              error = TRUE) {
 
   # define the output
   md <- fs::path_ext_set(fs::path_file(path), "md")
   outpath <- fs::path(outdir, md)
 
-  # Set up the arguments 
+  # Set up the arguments
   root <- root_path(path)
   prof <- fs::path(root, "renv", "profiles", profile)
   # If we have consent to use renv and the profile exists, then we can use renv,

R/serve.R

@@ -37,7 +37,7 @@
 #       it going
 serve <- function(path = ".") {
   path <- root_path(path)
-  rend <- function(file_list = ".") {
+  rend <- function(file_list = path) {
     for (f in file_list) {
       build_lesson(f, preview = FALSE)
     }

R/utils-sidebar.R

@@ -128,3 +128,23 @@ create_sidebar <- function(chapters, name = "", html = "<a href='https://carpent
   }
   res
 }
+
+update_sidebar <- function(sidebar = NULL, nodes = NULL, path_md = NULL, title = NULL, instructor = TRUE) {
+  if (is.null(sidebar)) return(sidebar)
+  # NOTE: this is the place we need to modify to address
+  # https://github.com/carpentries/workbench/issues/42
+  if (inherits(sidebar, "list-store")) {
+    # if it's a list store, then we need to get the sidebar and update itself
+    title <- if (is.null(title)) sidebar$get()[["pagetitle"]] else title
+    sb <- update_sidebar(sidebar$get()[["sidebar"]], nodes, path_md, title,
+      instructor)
+    sidebar$set("sidebar", paste(sb, collapse = "\n"))
+  }
+  this_page <- as_html(path_md)
+  to_change <- grep(paste0("[<]a href=['\"]", this_page, "['\"]"), sidebar)
+  if (length(to_change)) {
+    sidebar[to_change] <- create_sidebar_item(nodes, title, "current")
+  }
+  sidebar
+}
+

R/utils-yaml.R

@@ -17,7 +17,7 @@ politely_get_yaml <- function(path) {
     next_ten <- vector(mode = "character", length = 10)
     while (length(barriers) < 2) {
       next_ten <- scan(
-        path, 
+        path,
         what = character(),
         sep = "\n",
         skip = to_skip,
@@ -57,7 +57,7 @@ yaml_writer <- function(yaml, path) {
   # if this is null, no harm done
   header <- attr(yaml, "header")
   yaml <- yaml::as.yaml(
-    yaml, 
+    yaml,
     handlers = list(POSIXct = UTC_timestamp)
   )
   writeLines(c(header, yaml), path)
@@ -69,11 +69,11 @@ write_pkgdown_yaml <- function(yaml, path) {
 
 
 #' Create a valid, opinionated yaml list for insertion into a whisker template
-#' 
+#'
 #' @param thing a vector or list
 #' @return a character vector
 #'
-#' We want to manipulate our config file from the command line AND preserve 
+#' We want to manipulate our config file from the command line AND preserve
 #' comments. Unfortunately, the yaml C library does not parse comments and it
 #' makes things difficult to handle. At the moment we have a hack where we use
 #' whisker templates for these, but the drawback for whisker is that it does not
@@ -87,7 +87,7 @@ write_pkgdown_yaml <- function(yaml, path) {
 #' ```
 #'
 #' Moreover, we want to indicate that a yaml list is not a single key/value pair
-#' so we want to enforce that we have 
+#' so we want to enforce that we have
 #'
 #' ```
 #' key:
@@ -110,7 +110,7 @@ write_pkgdown_yaml <- function(yaml, path) {
 #'
 #' @keywords internal
 #' @note there IS a better solution than this hack, but for now, we will
-#' keep what we are doing because it's okay for our purposes: 
+#' keep what we are doing because it's okay for our purposes:
 #'   https://github.com/rstudio/blogdown/issues/560
 #' @examples
 #' x <- c("a", "b", "c")
@@ -137,7 +137,7 @@ get_information_header <- function(yaml) {
 # Returns a character vector of the yaml file with comments in tact
 get_yaml_text <- function(path, collapse = TRUE) {
   out <- scan(
-    path, 
+    path,
     what = character(),
     sep = "\n",
     encoding = "UTF-8",
@@ -159,7 +159,7 @@ create_pkgdown_yaml <- function(path) {
   # can be super-verbose here and create any logic we need on the R-side.
   usr <- yaml::read_yaml(path_config(path), eval.expr = FALSE)
   yaml <- get_yaml_text(template_pkgdown())
-  yaml <- whisker::whisker.render(yaml, 
+  yaml <- whisker::whisker.render(yaml,
     data = list(
       # Basic information
       version = siQuote(utils::packageVersion("sandpaper")),
@@ -184,18 +184,18 @@ create_pkgdown_yaml <- function(path) {
       pre_alpha  = if (usr$life_cycle == "pre-alpha") TRUE else "~",
       alpha      = if (usr$life_cycle == "alpha")     TRUE else "~",
       beta       = if (usr$life_cycle == "beta")      TRUE else "~",
-      NULL     
+      NULL
     )
   )
   rendered <- yaml::yaml.load(yaml, eval.expr = FALSE)
   items <- names(rendered$template$params)
-  rendered$template$params <- c(rendered$template$params, 
+  rendered$template$params <- c(rendered$template$params,
     c(usr[!names(usr) %in% items]))
   structure(rendered, header = get_information_header(yaml))
 }
 
 update_site_timestamp <- function(path) {
-  yaml <- get_path_site_yaml(path) 
+  yaml <- get_path_site_yaml(path)
   yaml$template$params$time <- Sys.time()
   write_pkgdown_yaml(yaml, path)
 }

R/utils.R

@@ -20,6 +20,42 @@ example_can_run <- function(need_git = FALSE, skip_cran = TRUE) {
   run_ok
 }
 
+# Search parent calls for a specific set of function signatures and return TRUE
+# if any one of them match.
+parent_calls_contain <- function(search = NULL, calls = sys.calls()) {
+  # escape early if there is no search. No search; no match.
+  if (length(search) == 0L || is.na(search)[[1L]]) {
+    return(FALSE)
+  }
+  # we assume no match
+  found <- FALSE
+  # calls will be arranged in order from user -> here, so the first call will
+  # be the call that triggered the chain of command.
+  for (call in calls) {
+    # the first part of the call will be the function name
+    fn <- as.character(call[[1L]])
+    # pkg::function is parsed as the character c("::", "pkg", "function")
+    # because "::" is a function, thus if we have 3, we take the function name
+    if (length(fn) == 3L) {
+      fn <- fn[3L]
+    } else {
+      fn <- fn[1L]
+    }
+    found <- fn %in% search || found
+    # once we find it, return early. This limits the time we spend in this loop
+    if (found) {
+      return(found)
+    }
+  }
+  # if we reach here, it should be FALSE.
+  found
+}
+
+in_production <- function(calls = sys.calls()) {
+  fns <- c("ci_deploy", "ci_build_site", "ci_build_markdown")
+  parent_calls_contain(fns, calls)
+}
+
 
 # Parse a markdown title to html
 #