Improve check_opengraph() (#2552)

R/build-articles.R

@@ -248,10 +248,8 @@ build_article <- function(name,
 
   front <- rmarkdown::yaml_front_matter(input_path)
   # Take opengraph from article's yaml front matter
-  front_opengraph <- check_open_graph(front$opengraph %||% list())
-  data$opengraph <- utils::modifyList(
-    data$opengraph %||% list(), front_opengraph
-  )
+  front_opengraph <- check_open_graph(front$opengraph, input)
+  data$opengraph <- modify_list(data$opengraph, front_opengraph)
 
   # Allow users to opt-in to their own template
   ext <- purrr::pluck(front, "pkgdown", "extension", .default = "html")

R/config.R

@@ -129,6 +129,6 @@ config_abort <- function(pkg,
 
 config_path <- function(pkg) {
   # Not all projects necessary have a _pkgdown.yml (#2542)
-  config <- pkgdown_config_path(pkg$src_path) %||% "_pkgdown.yml"
+  config <- pkgdown_config_path(pkg) %||% "_pkgdown.yml"
   cli::style_hyperlink(path_file(config), paste0("file://", config))  
 }

R/package.R

@@ -168,6 +168,10 @@ check_bootstrap_version <- function(version, pkg) {
 # Metadata ----------------------------------------------------------------
 
 pkgdown_config_path <- function(path) {
+  if (is_pkgdown(path)) {
+    path <- path$src_path
+  }
+
   path_first_existing(
     path,
     c(

R/render.R

@@ -132,10 +132,10 @@ data_template <- function(pkg = ".", depth = 0L) {
   print_yaml(out)
 }
 
-data_open_graph <- function(pkg = ".") {
+data_open_graph <- function(pkg = ".", call = caller_env()) {
   pkg <- as_pkgdown(pkg)
-  og <- pkg$meta$template$opengraph %||% list()
-  og <- check_open_graph(og)
+  og <- pkg$meta$template$opengraph
+  og <- check_open_graph(og, pkgdown_config_path(pkg), call = call)
   if (is.null(og$image) && !is.null(find_logo(pkg$src_path))) {
     og$image <- list(src = path_file(find_logo(pkg$src_path)))
   }
@@ -153,55 +153,47 @@ data_open_graph <- function(pkg = ".") {
   og
 }
 
-check_open_graph <- function(og) {
-  if (!is.list(og)) {
-    fog <- friendly_type_of(og)
-    cli::cli_abort(
-      "{.var opengraph} must be a list, not {.val fog}.",
-      call = caller_env()
-    )
+check_open_graph <- function(og, path, call = caller_env()) {
+  if (is.null(og)) {
+    return()
   }
+
+  is_yaml <- path_ext(path) %in% c("yml", "yaml")
+  base_path <- if (is_yaml) "template.opengraph" else "opengraph"
+
+  check_open_graph_list(
+    og,
+    file_path = path,
+    error_path = base_path,
+    error_call = call
+  )
+
   supported_fields <- c("image", "twitter")
   unsupported_fields <- setdiff(names(og), supported_fields)
   if (length(unsupported_fields)) {
     cli::cli_warn(
-      "Unsupported {.var opengraph} field{?s}: {.val unsupported_fields}."
+      "{.file {path}}: Unsupported {.field {base_path}} {cli::qty(unsupported_fields)} field{?s}: {.val {unsupported_fields}}.",
+      call = call
     )
   }
-  if ("twitter" %in% names(og)) {
-    if (is.character(og$twitter) && length(og$twitter) == 1 && grepl("^@", og$twitter)) {
-      cli::cli_abort(
-        "The {.var opengraph: twitter} option must be a list.",
-        call = caller_env()
-      )
-    }
-    if (!is.list(og$twitter)) {
-      cli::cli_abort(
-        "The {.var opengraph: twitter} option must be a list.",
-        call = caller_env()
-      )
-    }
-    if (is.null(og$twitter$creator) && is.null(og$twitter$site)) {
-      cli::cli_abort(
-        "{.var opengraph: twitter} must include either {.val creator} or {.val site}.",
-        call = caller_env()
-      )
-    }
-  }
-  if ("image" %in% names(og)) {
-    if (is.character(og$image) && length(og$image) == 1) {
-      cli::cli_abort(
-        "The {.var opengraph: image} option must be a list.",
-        call = caller_env()
-      )
-    }
-    if (!is.list(og$image)) {
-      cli::cli_abort(
-        "The {.var opengraph: image} option must be a list.",
-        call = caller_env()
-      )
-    }
+  check_open_graph_list(
+    og$twitter,
+    file_path = path,
+    error_path = paste0(base_path, ".twitter"),
+    error_call = call
+  )
+  if (!is.null(og$twitter) && is.null(og$twitter$creator) && is.null(og$twitter$site)) {
+    cli::cli_abort(
+      "{.file {path}}: {.field opengraph.twitter} must include either {.field creator} or {.field site}.",
+      call = call
+    )
   }
+  check_open_graph_list(
+    og$image,
+    file_path = path,
+    error_path = paste0(base_path, ".image"),
+    error_call = call
+  )
   og[intersect(supported_fields, names(og))]
 }
 
@@ -213,6 +205,20 @@ render_template <- function(path, data) {
   whisker::whisker.render(template, data)
 }
 
+check_open_graph_list <- function(x,
+                                  file_path,
+                                  error_path,
+                                  error_call = caller_env()) {
+  if (is.list(x) || is.null(x)) {
+    return()
+  }
+  not <- friendly_type_of(x)
+  cli::cli_abort(
+    "{.file {file_path}}: {.field {error_path}} must be a list, not {not}.",
+    call = error_call
+  )
+}
+
 write_if_different <- function(pkg, contents, path, quiet = FALSE, check = TRUE) {
   # Almost all uses are relative to destination, except for rmarkdown templates
   full_path <- path_abs(path, start = pkg$dst_path)

R/utils-fs.R

@@ -127,10 +127,3 @@ path_package_pkgdown <- function(path,
 path_pkgdown <- function(...) {
   system_file(..., package = "pkgdown")
 }
-
-pkgdown_config_relpath <- function(pkg) {
-  pkg <- as_pkgdown(pkg)
-  config_path <- pkgdown_config_path(pkg$src_path)
-
-  path_rel(config_path, pkg$src_path)
-}

tests/testthat/_snaps/build-articles.md

@@ -54,3 +54,11 @@
     Output
       ## [1] 0.080750138 0.834333037 0.600760886 0.157208442 0.007399441
 
+# reports on bad open graph meta-data
+
+    Code
+      build_article(pkg = pkg, name = "bad-opengraph")
+    Condition
+      Error in `build_article()`:
+      ! 'vignettes/bad-opengraph.Rmd': opengraph.twitter must be a list, not an integer vector.
+

tests/testthat/_snaps/render.md

@@ -39,7 +39,6 @@
       toc: Table of contents
       site_nav: Site navigation
     has_favicons: no
-    opengraph: []
     extra:
       css: ~
       js: ~
@@ -63,3 +62,35 @@
       right: <p>Site built with <a href="https://pkgdown.r-lib.org/">pkgdown</a> {version}.</p>
 
 
+# check_opengraph validates inputs
+
+    Code
+      check_open_graph_(list(foo = list()), )
+    Condition
+      Warning in `check_open_graph_()`:
+      '_pkgdown.yml': Unsupported template.opengraph field: "foo".
+    Output
+      named list()
+    Code
+      check_open_graph_(list(foo = list(), bar = list()))
+    Condition
+      Warning in `check_open_graph_()`:
+      '_pkgdown.yml': Unsupported template.opengraph fields: "foo" and "bar".
+    Output
+      named list()
+    Code
+      check_open_graph_(list(twitter = 1))
+    Condition
+      Error in `check_open_graph_()`:
+      ! '_pkgdown.yml': template.opengraph.twitter must be a list, not a double vector.
+    Code
+      check_open_graph_(list(twitter = list()))
+    Condition
+      Error in `check_open_graph_()`:
+      ! '_pkgdown.yml': opengraph.twitter must include either creator or site.
+    Code
+      check_open_graph_(list(image = 1))
+    Condition
+      Error in `check_open_graph_()`:
+      ! '_pkgdown.yml': template.opengraph.image must be a list, not a double vector.
+

tests/testthat/assets/articles/vignettes/bad-opengraph.Rmd

@@ -0,0 +1,7 @@
+---
+title: "Introduction to poolnoodlr"
+description: "A brief introduction to pool noodles in R."
+author: "Mara Averick"
+opengraph:
+  twitter: 1
+---

tests/testthat/test-build-articles.R

@@ -292,3 +292,9 @@ test_that("output is reproducible by default, i.e. 'seed' is respected", {
 
   expect_snapshot(cat(output))
 })
+
+test_that("reports on bad open graph meta-data", {
+  pkg <- local_pkgdown_site(test_path("assets/articles"))
+  suppressMessages(init_site(pkg))
+  expect_snapshot(build_article(pkg = pkg, name = "bad-opengraph"), error = TRUE)
+})

tests/testthat/test-render.R

@@ -69,3 +69,17 @@ test_that("can include text in header, before body, and after body", {
     c("in header", "before body", "after body")
   )
 })
+
+test_that("check_opengraph validates inputs", {
+  check_open_graph_ <- function(...) {
+    check_open_graph(..., path = "_pkgdown.yml")
+  }
+
+  expect_snapshot(error = TRUE, {
+    check_open_graph_(list(foo = list()), )
+    check_open_graph_(list(foo = list(), bar = list()))
+    check_open_graph_(list(twitter = 1))
+    check_open_graph_(list(twitter = list()))
+    check_open_graph_(list(image = 1))
+  })
+})