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..4b79555d 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..daf6d3f6 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") +})