From 71a708a084b1baf33eb25de1ccf579c402b515b6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Paul=20Li=C3=A9tar?= Date: Thu, 12 Sep 2024 15:11:06 +0100 Subject: [PATCH 1/2] 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 | 2 +- R/location_path.R | 2 +- R/outpack_config.R | 2 +- R/outpack_index.R | 4 +-- R/outpack_metadata.R | 16 +++-------- R/outpack_packet.R | 6 +--- R/util.R | 24 +++++++++++++--- tests/testthat/test-outpack-packet.R | 6 ++-- tests/testthat/test-util.R | 41 ++++++++++++++++++++++++++++ 9 files changed, 74 insertions(+), 29 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 61f46f4d..8853892e 100644 --- a/DESCRIPTION +++ b/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 = "rich.fitzjohn@gmail.com"), person("Robert", "Ashton", role = "aut"), diff --git a/R/location_path.R b/R/location_path.R index b84f0675..d548ebdf 100644 --- a/R/location_path.R +++ b/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)) diff --git a/R/outpack_config.R b/R/outpack_config.R index 7804efaa..90f783d5 100644 --- a/R/outpack_config.R +++ b/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"), diff --git a/R/outpack_index.R b/R/outpack_index.R index f17d91ac..f11a037e 100644 --- a/R/outpack_index.R +++ b/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() } diff --git a/R/outpack_metadata.R b/R/outpack_metadata.R index 7c0844d9..5666f440 100644 --- a/R/outpack_metadata.R +++ b/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) diff --git a/R/outpack_packet.R b/R/outpack_packet.R index ff422b18..31fe8f2c 100644 --- a/R/outpack_packet.R +++ b/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", diff --git a/R/util.R b/R/util.R index 636c25d1..5d3d36e5 100644 --- a/R/util.R +++ b/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) + }) } diff --git a/tests/testthat/test-outpack-packet.R b/tests/testthat/test-outpack-packet.R index 5933695a..079377a0 100644 --- a/tests/testthat/test-outpack-packet.R +++ b/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") }) diff --git a/tests/testthat/test-util.R b/tests/testthat/test-util.R index 0408adca..7b4912a4 100644 --- a/tests/testthat/test-util.R +++ b/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") +}) From e294e588be9c29571a9b09222485366d213ff78d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Paul=20Li=C3=A9tar?= Date: Thu, 12 Sep 2024 16:27:00 +0100 Subject: [PATCH 2/2] codefactor --- R/util.R | 2 +- tests/testthat/test-util.R | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/util.R b/R/util.R index 5d3d36e5..4b79555d 100644 --- a/R/util.R +++ b/R/util.R @@ -381,7 +381,7 @@ parse_json <- function(json, ..., name = NULL) { msg <- "Error while reading JSON document" } cli::cli_abort( - c(msg, i="This usually suggests some corruption of the repository"), + c(msg, i = "This usually suggests some corruption of the repository"), parent = cnd) }) } diff --git a/tests/testthat/test-util.R b/tests/testthat/test-util.R index 7b4912a4..daf6d3f6 100644 --- a/tests/testthat/test-util.R +++ b/tests/testthat/test-util.R @@ -431,7 +431,7 @@ test_that("fill_missing_names works", { test_that("parse_json accepts literal string", { expect_equal(parse_json('{ "x": 1 }'), list(x = 1)) - expect_equal(parse_json('null'), NULL) + expect_equal(parse_json("null"), NULL) })