Include the file path when a JSON decoding error happens.

If the metadata store is corrupted for some reason, jsonlite throws an
error with details of the syntax error, but does not include any mention
of the file path.

This adds a wrapper around `jsonlite::parse_json` which catches the
error and includes the file path. It still preserves the original error
message, using [{rlang} error chaining][error-chain].

[error-chain]: https://rlang.r-lib.org/reference/topic-error-chaining.html

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: orderly2
 Title: Orderly Next Generation
-Version: 1.99.37
+Version: 1.99.38
 Authors@R: c(person("Rich", "FitzJohn", role = c("aut", "cre"),
                     email = "[email protected]"),
              person("Robert", "Ashton", role = "aut"),

R/location_path.R

@@ -69,7 +69,7 @@ orderly_location_path <- R6::R6Class(
 ## This split just acts to make the http one easier to think about -
 ## it's not the job of the driver to do validation, but the server.
 location_path_import_metadata <- function(str, hash, root) {
-  meta <- outpack_metadata_core_load(as_json(str))
+  meta <- outpack_metadata_core_load(str)
   id <- meta$id
   hash_validate_data(str, hash, sprintf("metadata for '%s'", id))
 

R/outpack_config.R

@@ -285,7 +285,7 @@ config_write <- function(config, root_path) {
 
 
 config_read <- function(root_path) {
-  config <- jsonlite::read_json(file.path(root_path, ".outpack/config.json"))
+  config <- read_json(file.path(root_path, ".outpack/config.json"))
   ## NOTE: make sure that this matches the order in new_location_entry
   config$location <- data_frame(
     name = vcapply(config$location, "[[", "name"),

R/outpack_index.R

@@ -95,7 +95,7 @@ read_metadata <- function(root_path, prev, progress) {
   files <- file.path(path, id_new)
   new <- vector("list", length(id_new))
   for (i in seq_along(id_new)) {
-    new[[i]] <- outpack_metadata_core_read(files[[i]])
+    new[[i]] <- outpack_metadata_core_load(file(files[[i]]))
     if (progress) {
       cli::cli_progress_update()
     }
@@ -147,7 +147,7 @@ read_location <- function(location_name, root_path, prev, progress) {
                           total = length(id_new))
   }
   for (i in seq_along(id_new)) {
-    dat[[i]] <- jsonlite::read_json(files[[i]])
+    dat[[i]] <- read_json(files[[i]])
     if (progress) {
       cli::cli_progress_update()
     }

R/outpack_metadata.R

@@ -31,7 +31,7 @@ orderly_metadata <- function(id, root = NULL, locate = FALSE) {
   if (!file.exists(path_metadata)) {
     cli::cli_abort("Packet '{id}' not found in outpack index")
   }
-  outpack_metadata_load(path_metadata, root$config$orderly$plugins)
+  outpack_metadata_load(file(path_metadata), root$config$orderly$plugins)
 }
 
 
@@ -66,7 +66,7 @@ orderly_metadata <- function(id, root = NULL, locate = FALSE) {
 ##' @export
 orderly_metadata_read <- function(path, plugins = TRUE) {
   assert_file_exists(path, call = environment())
-  outpack_metadata_load(path, if (plugins) .plugins else NULL)
+  outpack_metadata_load(file(path), if (plugins) .plugins else NULL)
 }
 
 outpack_metadata_create <- function(path, name, id, time, files,
@@ -179,14 +179,9 @@ outpack_metadata_core <- function(id, root, call = NULL) {
 }
 
 
-outpack_metadata_core_read <- function(path) {
-  outpack_metadata_core_load(read_string(path))
-}
-
-
 metadata_core_names <- c("id", "name", "parameters", "time", "files", "depends")
 outpack_metadata_core_load <- function(json) {
-  data <- jsonlite::parse_json(json)[metadata_core_names]
+  data <- parse_json(json)[metadata_core_names]
   outpack_metadata_core_deserialise(data)
 }
 
@@ -211,10 +206,7 @@ outpack_metadata_core_deserialise <- function(data) {
 
 
 outpack_metadata_load <- function(json, plugins) {
-  if (!inherits(json, "json")) { # could use starts with "{"
-    json <- read_string(json)
-  }
-  data <- jsonlite::parse_json(json)
+  data <- parse_json(json)
   data <- outpack_metadata_core_deserialise(data)
   if (!is.null(data$custom$orderly)) {
     data$custom$orderly <- custom_metadata_deserialise(data$custom$orderly)

R/outpack_packet.R

@@ -282,11 +282,7 @@ outpack_packet_add_custom <- function(packet, application, data) {
   assert_scalar_character(application)
   assert_scalar_character(data)
 
-  tryCatch(
-    jsonlite::parse_json(data),
-    error = function(e) {
-      stop("Syntax error in custom metadata: ", e$message, call. = FALSE)
-    })
+  parse_json(data, name = "custom metadata")
 
   if (application %in% vcapply(packet$custom, "[[", "application")) {
     stop(sprintf("metadata for '%s' has already been added for this packet",

R/util.R

@@ -364,10 +364,26 @@ to_json <- function(x, schema = NULL, auto_unbox = FALSE, ...) {
   json
 }
 
-
-as_json <- function(str) {
-  assert_scalar_character(str)
-  structure(str, class = "json")
+read_json <- function(path, ...) {
+  parse_json(file(path), ...)
+}
+
+parse_json <- function(json, ..., name = NULL) {
+  rlang::try_fetch(
+    jsonlite::parse_json(json, ...),
+    error = function(cnd) {
+      if (is.null(name) && inherits(json, "connection")) {
+        name <- summary(json)$description
+      }
+      if (!is.null(name)) {
+        msg <- "Error while reading {name}"
+      } else {
+        msg <- "Error while reading JSON document"
+      }
+      cli::cli_abort(
+        c(msg, i="This usually suggests some corruption of the repository"),
+        parent = cnd)
+    })
 }
 
 

tests/testthat/test-outpack-packet.R

@@ -36,7 +36,7 @@ test_that("Can run a basic packet", {
   expect_true(file.exists(path_location))
   expect_true(load_schema("outpack/location.json")$validate(path_location))
 
-  meta <- outpack_metadata_load(path_metadata)
+  meta <- outpack_metadata_load(file(path_metadata), NULL)
 
   ## The index metadata is a subset of the full set:
   expect_mapequal(
@@ -309,7 +309,7 @@ test_that("Can add multiple copies of extra data", {
   outpack_packet_end_quietly(p)
 
   path_metadata <- file.path(root$path, ".outpack", "metadata", p$id)
-  meta <- outpack_metadata_load(path_metadata, NULL)
+  meta <- outpack_metadata_load(file(path_metadata), NULL)
   expect_equal(meta$custom,
                list(app1 = list(a = 1, b = 2),
                     app2 = list(c = list(1, 2, 3))))
@@ -345,7 +345,7 @@ test_that("Can report nicely about json syntax errors", {
   p <- outpack_packet_start_quietly(src, "example", root = root)
   expect_error(
     outpack_packet_add_custom(p, "app1", '{"a": 1, "b": 2'),
-    "Syntax error in custom metadata:")
+    "Error while reading custom metadata")
 })
 
 

tests/testthat/test-util.R

@@ -321,6 +321,7 @@ test_that("read_string strips newlines", {
   expect_equal(result, "12345678")
 })
 
+
 describe("expand_dirs_virtual", {
   files <- list(
     "d1" = c("f2", "f3"),
@@ -367,6 +368,7 @@ describe("expand_dirs_virtual", {
   })
 })
 
+
 describe("expand_dirs", {
   p <- withr::local_tempdir()
   files <- c("f1", "d1/f2", "d1/f3", "d2/f4", "d2/d3/f5")
@@ -425,3 +427,42 @@ test_that("fill_missing_names works", {
   expect_equal(fill_missing_names(c("a", "a")), c(a = "a", a = "a"))
   expect_equal(fill_missing_names(c(x = "a", "a")), c(x = "a", a = "a"))
 })
+
+
+test_that("parse_json accepts literal string", {
+  expect_equal(parse_json('{ "x": 1 }'), list(x = 1))
+  expect_equal(parse_json('null'), NULL)
+})
+
+
+test_that("parse_json accepts files", {
+  f <- withr::local_tempfile()
+  writeLines('{ "x": 1 }', f)
+  expect_equal(parse_json(file(f)), list(x = 1))
+})
+
+
+test_that("parse_json is not confused by ambiguity", {
+  withr::with_dir(withr::local_tempdir(), {
+    writeLines('{ "contents": "hello" }', "true")
+    writeLines('{ "contents": "world" }', "4")
+    expect_equal(parse_json("true"), TRUE)
+    expect_equal(parse_json("4"), 4)
+    expect_equal(parse_json(file("true")), list(contents = "hello"))
+    expect_equal(parse_json(file("4")), list(contents = "world"))
+  })
+})
+
+
+test_that("parse_json includes file path in its errors", {
+  f <- file.path(withr::local_tempdir(), "contents.json")
+  writeLines("bad json", f)
+  expect_error(parse_json(file(f)),
+               "Error while reading .*contents.json.*lexical error")
+})
+
+
+test_that("parse_json includes name argument in its errors", {
+  expect_error(parse_json("bad json", name = "my file"),
+               "Error while reading my file.*lexical error")
+})