Merge pull request #180 from mrc-ide/mrc-5762-corrupt

Include the file path when a JSON decoding error happens.

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")
+})