diff --git a/DESCRIPTION b/DESCRIPTION index 733ff5df..8ffc3210 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: orderly2 Title: Orderly Next Generation -Version: 1.99.15 +Version: 1.99.17 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.R b/R/location.R index e25d4088..ba0247f3 100644 --- a/R/location.R +++ b/R/location.R @@ -392,8 +392,14 @@ orderly_location_push <- function(packet_id, location, root = NULL, if (length(plan$files) > 0 || length(plan$packet_id) > 0) { driver <- location_driver(location_name, root) for (hash in plan$files) { - ## TODO: mrc-4505 - needs work - driver$push_file(find_file_by_hash(root, hash), hash) + src <- find_file_by_hash(root, hash) + if (is.null(src)) { + cli::cli_abort( + c("Did not find suitable file, can't push this packet", + i = paste("The original file has been changed or deleted.", + "Details are above"))) + } + driver$push_file(src, hash) } for (id in plan$packet_id) { path <- file.path(root$path, ".outpack", "metadata", id) diff --git a/R/outpack_root.R b/R/outpack_root.R index c676f116..f075aec7 100644 --- a/R/outpack_root.R +++ b/R/outpack_root.R @@ -106,6 +106,9 @@ file_import_archive <- function(root, path, file_path, name, id) { fs::dir_create(dirname(file_path_dest)) ## overwrite = FALSE; see assertion above fs::file_copy(file.path(path, file_path), file_path_dest, overwrite = FALSE) + if (length(file_path_dest) > 0) { + fs::file_chmod(file_path_dest, "a-w") + } } @@ -120,17 +123,27 @@ find_file_by_hash <- function(root, hash) { for (id in index$unpacked) { meta <- index$metadata[[id]] for (i in which(meta$files$hash == hash)) { - path <- file.path(path_archive, meta$name, id, meta$files$path[[i]]) - if (file.exists(path) && hash_file(path, algorithm) == hash) { + filename <- meta$files$path[[i]] + path <- file.path(path_archive, meta$name, id, filename) + if (!file.exists(path)) { + cli::cli_alert_warning( + "Missing file from archive '{filename}' in '{meta$name}/{id}'") + next + } + hash_found <- hash_file(path, algorithm) + if (file.exists(path) && hash_found == hash) { return(path) } - p <- meta$files$path[[i]] ## Not actually a warning; formats in a way that works within ## the overal logging. What is not obvious is that this is ## potentially coming from a remote and that's not always clear, ## so we need a way of nesting output cli::cli_alert_warning( - "Rejecting file from archive '{p}' in '{meta$name}/{id}'") + "Rejecting file from archive '{filename}' in '{meta$name}/{id}'") + cli::cli_alert_info( + "Expected ({cli::symbol$tick}) and found ({cli::symbol$cross}) hashes:") + cli::cli_alert_success(hash) + cli::cli_alert_danger(hash_found) } } diff --git a/R/outpack_store.R b/R/outpack_store.R index ba848f44..7c0b5005 100644 --- a/R/outpack_store.R +++ b/R/outpack_store.R @@ -57,7 +57,7 @@ file_store <- R6::R6Class( } else { fs::file_copy(src, dst, overwrite = FALSE) } - fs::file_chmod(dst, "a-wx") + fs::file_chmod(dst, "a-w") } else if (move) { unlink(src) } diff --git a/R/run.R b/R/run.R index f31506d8..62905ff9 100644 --- a/R/run.R +++ b/R/run.R @@ -494,7 +494,7 @@ orderly_packet_cleanup_success <- function(p, call = NULL) { orderly_packet_add_metadata(p) outpack_packet_end(p) - unlink(path, recursive = TRUE) + fs::dir_delete(path) } diff --git a/R/validate.R b/R/validate.R index b179b18e..c675e324 100644 --- a/R/validate.R +++ b/R/validate.R @@ -91,8 +91,8 @@ orderly_validate_archive_packet <- function(id, action, cache, root) { drop_local_packet(id, root) } else if (action == "delete") { drop_local_packet(id, root) - unlink(file.path(root$path, root$config$core$path_archive, res$name, id), - recursive = TRUE) + fs::dir_delete( + file.path(root$path, root$config$core$path_archive, res$name, id)) } } diff --git a/tests/testthat/helper-orderly.R b/tests/testthat/helper-orderly.R index 1e27a984..373786c6 100644 --- a/tests/testthat/helper-orderly.R +++ b/tests/testthat/helper-orderly.R @@ -6,7 +6,7 @@ options(outpack.schema_validate = test_prepare_orderly_example <- function(examples, ...) { tmp <- tempfile() - withr::defer_parent(unlink(tmp, recursive = TRUE)) + withr::defer_parent(fs::dir_delete(tmp)) suppressMessages(orderly_init(tmp, ...)) copy_examples(examples, tmp) as.character(fs::path_norm(tmp)) @@ -15,11 +15,11 @@ test_prepare_orderly_example <- function(examples, ...) { test_prepare_orderly_example_separate <- function(examples, ...) { tmp <- tempfile() - withr::defer_parent(unlink(tmp, recursive = TRUE)) + withr::defer_parent(fs::dir_delete(tmp)) path_outpack <- file.path(tmp, "outpack") suppressMessages(orderly_init(path_outpack, ...)) - unlink(file.path(path_outpack, "orderly_config.yml")) + fs::file_delete(file.path(path_outpack, "orderly_config.yml")) path_src <- file.path(tmp, "src") copy_examples(examples, path_src) diff --git a/tests/testthat/helper-outpack.R b/tests/testthat/helper-outpack.R index 12eff2a5..c6c5e9cc 100644 --- a/tests/testthat/helper-outpack.R +++ b/tests/testthat/helper-outpack.R @@ -6,7 +6,7 @@ options(outpack.schema_validate = TRUE) create_random_packet <- function(root, name = "data", parameters = NULL, id = NULL) { src <- fs::dir_create(tempfile()) - on.exit(unlink(src, recursive = TRUE)) + on.exit(fs::dir_delete(src)) saveRDS(runif(10), file.path(src, "data.rds")) p <- outpack_packet_start_quietly( src, name, parameters = parameters, id = id, root = root) @@ -18,7 +18,7 @@ create_random_packet <- function(root, name = "data", parameters = NULL, create_deterministic_packet <- function(root, name = "data", parameters = NULL) { src <- fs::dir_create(tempfile()) - on.exit(unlink(src, recursive = TRUE)) + on.exit(fs::dir_delete(src)) saveRDS(1:10, file.path(src, "data.rds")) p <- outpack_packet_start_quietly( src, name, parameters = parameters, root = root) @@ -38,7 +38,7 @@ mock_metadata_depends <- function(id, depends = character(0)) { ## other. create_random_packet_chain <- function(root, length, base = NULL) { src <- fs::dir_create(tempfile()) - on.exit(unlink(src, recursive = TRUE), add = TRUE) + on.exit(fs::dir_delete(src), add = TRUE) id <- character() suppressMessages({ @@ -69,7 +69,7 @@ create_random_packet_chain <- function(root, length, base = NULL) { create_random_dependent_packet <- function(root, name, dependency_ids) { src <- fs::dir_create(tempfile()) - on.exit(unlink(src, recursive = TRUE), add = TRUE) + on.exit(fs::dir_delete(src), add = TRUE) p <- outpack_packet_start_quietly(src, name, root = root) @@ -96,7 +96,7 @@ create_random_dependent_packet <- function(root, name, dependency_ids) { create_temporary_root <- function(...) { path <- tempfile() - withr::defer_parent(unlink(path, recursive = TRUE)) + withr::defer_parent(fs::dir_delete(path)) suppressMessages(orderly_init(path, ...)) root_open(path, locate = FALSE, require_orderly = FALSE) } @@ -105,7 +105,7 @@ create_temporary_root <- function(...) { ## A really simple example that we use in a few places create_temporary_simple_src <- function() { path <- tempfile() - withr::defer_parent(unlink(path, recursive = TRUE)) + withr::defer_parent(fs::dir_delete(path)) fs::dir_create(path) path <- tempfile() @@ -126,7 +126,11 @@ create_temporary_simple_src <- function() { temp_file <- function() { path <- tempfile() - withr::defer_parent(unlink(path, recursive = TRUE)) + withr::defer_parent({ + if (fs::file_exists(path)) { + fs::file_delete(path) + } + }) path } @@ -174,3 +178,10 @@ outpack_packet_start_quietly <- function(...) { outpack_packet_end_quietly <- function(...) { suppressMessages(outpack_packet_end(...)) } + +forcibly_truncate_file <- function(path) { + permissions <- fs::file_info(path)$permissions + fs::file_chmod(path, "a+w") + file.create(path) + fs::file_chmod(path, permissions) +} diff --git a/tests/testthat/test-init.R b/tests/testthat/test-init.R index f47bdfa3..dd854848 100644 --- a/tests/testthat/test-init.R +++ b/tests/testthat/test-init.R @@ -1,7 +1,7 @@ test_that("Initialisation requires empty directory", { tmp <- tempfile() fs::dir_create(tmp) - on.exit(unlink(tmp, recursive = TRUE)) + on.exit(fs::dir_delete(tmp)) file.create(file.path(tmp, "file")) expect_error(orderly_init_quietly(tmp), "'root' exists but is not empty, or an outpack archive") @@ -10,7 +10,7 @@ test_that("Initialisation requires empty directory", { test_that("Can initialise a new orderly root", { tmp <- tempfile() - on.exit(unlink(tmp, recursive = TRUE)) + on.exit(fs::dir_delete(tmp)) res <- orderly_init_quietly(tmp) expect_true(file.exists(tmp)) expect_identical(normalise_path(res), normalise_path(tmp)) @@ -45,7 +45,7 @@ test_that("can initialise a repo with orderly but no .outpack directory", { path <- test_prepare_orderly_example("data") parent <- dirname(path) base <- basename(path) - unlink(file.path(path, ".outpack"), recursive = TRUE) + fs::dir_delete(file.path(path, ".outpack")) err <- expect_error( withr::with_dir(parent, orderly_run_quietly("data", root = base, envir = new.env())), diff --git a/tests/testthat/test-location-path.R b/tests/testthat/test-location-path.R index a951dd6c..155edab2 100644 --- a/tests/testthat/test-location-path.R +++ b/tests/testthat/test-location-path.R @@ -350,3 +350,21 @@ test_that("Can read metadata files with a trailing newline", { expected_hash <- packets[packets$packet == id]$hash expect_no_error(hash_validate_data(data, expected_hash)) }) + + +test_that("Fail to push sensibly if files have been changed", { + client <- create_temporary_root() + ids <- create_random_packet_chain(client, 4) + + server <- create_temporary_root(use_file_store = TRUE, path_archive = NULL) + orderly_location_add("server", "path", list(path = server$path), + root = client) + + ## Corrupt one file: + path <- file.path(client$path, "archive", "b", ids[["b"]], "script.R") + forcibly_truncate_file(path) + + expect_error( + suppressMessages(orderly_location_push(ids[[4]], "server", client)), + "Did not find suitable file, can't push this packet") +}) diff --git a/tests/testthat/test-location.R b/tests/testthat/test-location.R index 9f260cf4..b24aec9d 100644 --- a/tests/testthat/test-location.R +++ b/tests/testthat/test-location.R @@ -433,7 +433,8 @@ test_that("detect and avoid modified files in source repository", { orderly_location_pull_metadata(root = root$dst) ## Corrupt the file in the first id by truncating it: - file.create(file.path(root$src$path, "archive", "data", id[[1]], "a.rds")) + forcibly_truncate_file( + file.path(root$src$path, "archive", "data", id[[1]], "a.rds")) ## Then pull res <- testthat::evaluate_promise( @@ -1076,8 +1077,8 @@ test_that("can prune orphans from tree", { test_that("don't prune referenced orphans", { root <- create_temporary_root() id <- create_random_packet_chain(root, 3) - unlink(file.path(root$path, "archive", "a"), recursive = TRUE) - unlink(file.path(root$path, "archive", "c"), recursive = TRUE) + fs::dir_delete(file.path(root$path, "archive", "a")) + fs::dir_delete(file.path(root$path, "archive", "c")) suppressMessages(orderly_validate_archive(action = "orphan", root = root)) expect_equal(nrow(root$index$location(orphan)), 2) diff --git a/tests/testthat/test-orderly.R b/tests/testthat/test-orderly.R index eeb7337a..fbe7c205 100644 --- a/tests/testthat/test-orderly.R +++ b/tests/testthat/test-orderly.R @@ -16,14 +16,14 @@ test_that("find expected candidates", { test_that("ignore paths without orderly file", { v <- c("data", "depends", "depends-params", "description") path <- test_prepare_orderly_example(v) - unlink(file.path(path, "src", v[1], "data.R")) + fs::file_delete(file.path(path, "src", v[1], "data.R")) expect_equal(orderly_list_src(path), v[-1]) }) test_that("no candidates returns empty character vector", { path <- test_prepare_orderly_example(character()) - unlink(file.path(path, "src"), recursive = TRUE) + fs::dir_delete(file.path(path, "src")) expect_setequal(dir(path, all.files = TRUE, no.. = TRUE), c(".outpack", "orderly_config.yml")) expect_equal(withr::with_dir(path, orderly_list_src()), character()) diff --git a/tests/testthat/test-outpack-packet.R b/tests/testthat/test-outpack-packet.R index 32c06648..faa158f1 100644 --- a/tests/testthat/test-outpack-packet.R +++ b/tests/testthat/test-outpack-packet.R @@ -268,10 +268,8 @@ test_that("validate dependencies from archive", { outpack_packet_run(p1, "script.R") outpack_packet_end_quietly(p1) - ## Change the value here: - write.csv(data.frame(x = 1:10, y = runif(10)), - file.path(root$path, "archive", "a", id1, "data.csv"), - row.names = FALSE) + ## Corrupt the file here. + forcibly_truncate_file(file.path(root$path, "archive", "a", id1, "data.csv")) p2 <- outpack_packet_start_quietly(path_src2, "b", root = root) id2 <- p2$id @@ -835,3 +833,31 @@ test_that("metadata files match their hash", { path <- file.path(root$path, ".outpack", "metadata", id) expect_no_error(hash_validate_file(path, expected_hash)) }) + + +test_that("Files in the archive are read-only", { + src <- temp_file() + fs::dir_create(src) + writeLines(c( + "d <- read.csv('data.csv')", + "png('myplot.png')", + "plot(d)", + "dev.off()"), + file.path(src, "script.R")) + write.csv(data.frame(x = 1:10, y = runif(10)), + file.path(src, "data.csv"), + row.names = FALSE) + + root <- create_temporary_root(path_archive = "archive", + use_file_store = FALSE) + path <- root$path + + p <- outpack_packet_start_quietly(src, "a", root = root) + outpack_packet_run(p, "script.R") + outpack_packet_end_quietly(p) + + files <- c("data.csv", "script.R", "myplot.png") + files_path <- file.path(path, "archive", "a", p$id, files) + expect_true(all(fs::file_access(files_path, "read"))) + expect_true(all(!fs::file_access(files_path, "write"))) +}) diff --git a/tests/testthat/test-plugin.R b/tests/testthat/test-plugin.R index be91da49..f894df73 100644 --- a/tests/testthat/test-plugin.R +++ b/tests/testthat/test-plugin.R @@ -179,7 +179,7 @@ test_that("validate that plugins make sense", { orderly_plugin("pkg", config, NULL, deserialise, NULL, NULL), "If 'deserialise' is given, then 'serialise' must be non-NULL") - unlink(schema) + fs::file_delete(schema) expect_error( orderly_plugin("pkg", config, serialise, deserialise, cleanup, basename(schema)), diff --git a/tests/testthat/test-root.R b/tests/testthat/test-root.R index 9fb12579..d1ff24df 100644 --- a/tests/testthat/test-root.R +++ b/tests/testthat/test-root.R @@ -1,6 +1,6 @@ test_that("Configuration must be empty", { tmp <- tempfile() - on.exit(unlink(tmp, recursive = TRUE)) + on.exit(fs::dir_delete(tmp)) fs::dir_create(tmp) writeLines(c(empty_config_contents(), "a: 1"), file.path(tmp, "orderly_config.yml")) @@ -11,7 +11,7 @@ test_that("Configuration must be empty", { test_that("Configuration must exist", { tmp <- tempfile() - on.exit(unlink(tmp, recursive = TRUE)) + on.exit(fs::dir_delete(tmp)) fs::dir_create(tmp) outpack_init_no_orderly(tmp) expect_error(orderly_config_read(tmp), @@ -55,7 +55,7 @@ test_that("pass back a root", { test_that("can silently detect that git setup is ok", { root <- create_temporary_root() info <- helper_add_git(root$path) - unlink(file.path(root$path, ".outpack", "r", "git_ok")) + expect_false(file.exists(file.path(root$path, ".outpack", "r", "git_ok"))) expect_silent(root_check_git(root, NULL)) expect_true(file.exists(file.path(root$path, ".outpack", "r", "git_ok"))) }) @@ -74,7 +74,7 @@ test_that("can add gitignore if git setup is ok, but not present", { root <- create_temporary_root() info <- helper_add_git(root$path) fs::file_delete(file.path(root$path, ".gitignore")) - unlink(file.path(root$path, ".outpack", "r", "git_ok")) + expect_false(file.exists(file.path(root$path, ".outpack", "r", "git_ok"))) expect_message(root_check_git(root, NULL), "Wrote '.gitignore'") expect_true(file.exists(file.path(root$path, ".outpack", "r", "git_ok"))) expect_true(file.exists(file.path(root$path, ".gitignore"))) diff --git a/tests/testthat/test-run.R b/tests/testthat/test-run.R index dcad6f34..a8d53f0c 100644 --- a/tests/testthat/test-run.R +++ b/tests/testthat/test-run.R @@ -188,6 +188,12 @@ test_that("Can run simple case with dependency", { envir2 <- new.env() id2 <- orderly_run_quietly("depends", root = path, envir = envir2) + ## Nothing left in drafts + expect_true(is_directory(file.path(path, "draft", "data"))) + expect_true(is_directory(file.path(path, "draft", "depends"))) + expect_false(file.exists(file.path(path, "draft", "data", id1))) + expect_false(file.exists(file.path(path, "draft", "depends", id2))) + path1 <- file.path(path, "archive", "data", id1) path2 <- file.path(path, "archive", "depends", id2) @@ -316,7 +322,7 @@ test_that("can validate shared resource arguments", { test_that("can't use shared resources if not enabled", { path <- test_prepare_orderly_example("shared") - unlink(file.path(path, "shared"), recursive = TRUE) + fs::dir_delete(file.path(path, "shared")) envir <- new.env() path_src <- file.path(path, "src", "shared") err <- expect_error( @@ -1156,7 +1162,7 @@ test_that("cope with manually deleted packets, exclude from deps", { }) id <- ids[[3]] - unlink(file.path(path, "archive", "data", id), recursive = TRUE) + fs::dir_delete(file.path(path, "archive", "data", id)) err <- expect_error( orderly_run_quietly("depends", root = path, envir = new.env()), @@ -1191,7 +1197,7 @@ test_that("cope with corrupted packets, exclude from deps", { }) id <- ids[[3]] - file.create(file.path(path, "archive", "data", id, "data.rds")) # truncate + forcibly_truncate_file(file.path(path, "archive", "data", id, "data.rds")) err <- expect_error( orderly_run_quietly("depends", root = path, envir = new.env()), @@ -1342,7 +1348,7 @@ test_that("can read about dependencies", { test_that("nice error if resource file not found", { path <- test_prepare_orderly_example("explicit") envir <- new.env() - unlink(file.path(path, "src", "explicit", "data.csv")) + fs::file_delete(file.path(path, "src", "explicit", "data.csv")) err <- expect_error( orderly_run_quietly("explicit", root = path, envir = envir), "Resource file does not exist: 'data.csv'") diff --git a/tests/testthat/test-validate.R b/tests/testthat/test-validate.R index 23e366d8..9dd14428 100644 --- a/tests/testthat/test-validate.R +++ b/tests/testthat/test-validate.R @@ -11,7 +11,7 @@ test_that("Can validate a packet that is invalid", { root <- create_temporary_root() id <- create_random_packet(root = root) path <- file.path(root$path, "archive", "data", id, "data.rds") - file.create(path) # truncate file + forcibly_truncate_file(path) res <- evaluate_promise(orderly_validate_archive(id, root = root)) expect_match(res$messages, sprintf("%s (data) is invalid", id), fixed = TRUE) expect_equal(res$result, id) @@ -25,7 +25,7 @@ test_that("Can orphan an invalid packet", { ids <- replicate(3, create_random_packet(root = root)) id <- ids[[2]] path <- file.path(root$path, "archive", "data", id, "data.rds") - file.create(path) # truncate file + forcibly_truncate_file(path) res <- evaluate_promise( orderly_validate_archive(id, action = "orphan", root = root)) expect_match(res$messages, sprintf("%s (data) is invalid", id), fixed = TRUE) @@ -41,7 +41,7 @@ test_that("Can delete an invalid packet", { ids <- replicate(3, create_random_packet(root = root)) id <- ids[[2]] path <- file.path(root$path, "archive", "data", id, "data.rds") - file.create(path) # truncate file + forcibly_truncate_file(path) res <- evaluate_promise( orderly_validate_archive(action = "delete", root = root)) expect_match(res$messages, sprintf("%s (data) is invalid", id), fixed = TRUE, @@ -65,7 +65,8 @@ test_that("recursively validate, errors in upstream are a problem", { root <- create_temporary_root(require_complete_tree = TRUE) ids <- create_random_packet_chain(5, root = root) - file.create(file.path(root$path, "archive", "c", ids[["c"]], "data.rds")) + forcibly_truncate_file( + file.path(root$path, "archive", "c", ids[["c"]], "data.rds")) res <- evaluate_promise( orderly_validate_archive(ids[["d"]], root = root)) @@ -108,7 +109,8 @@ test_that("invalidate all children of corrupt parent", { evaluate_promise(orderly_validate_archive(id3, root = root)), res) - file.create(file.path(root$path, "archive", "child", id2[[1]], "data.rds")) + forcibly_truncate_file( + file.path(root$path, "archive", "child", id2[[1]], "data.rds")) res <- evaluate_promise(orderly_validate_archive(id3, root = root)) expect_match(res$messages[c(1, 3, 4)], re, all = TRUE) expect_match(res$messages[[2]], @@ -137,7 +139,8 @@ test_that("don't invalidate children when complete tree off", { expect_length(res$messages, 1) ## We no longer know, or care, if this is invalid due to children - file.create(file.path(root$path, "archive", "child", id2[[1]], "data.rds")) + forcibly_truncate_file( + file.path(root$path, "archive", "child", id2[[1]], "data.rds")) expect_equal( evaluate_promise(orderly_validate_archive(id3, root = root)), res) diff --git a/vignettes/introduction.Rmd b/vignettes/introduction.Rmd index 19ff1f8d..5b8634cd 100644 --- a/vignettes/introduction.Rmd +++ b/vignettes/introduction.Rmd @@ -400,7 +400,7 @@ orderly2::orderly_metadata_extract( ```{r include = FALSE, inwd = path} id_latest <- orderly2::orderly_search("latest", name = "incoming_data") -unlink(file.path(path, "archive", "incoming_data", id_latest), recursive = TRUE) +fs::dir_delete(file.path(path, "archive", "incoming_data", id_latest)) ``` When we run the `analysis` task, it will pull in the most recent version (`r inline(id_latest)`). However, if you had deleted this manually (e.g., to save space or accidentally) or corrupted it (e.g., by opening some output in Excel and letting it save changes) it will not be able to be included, and running `analysis` will fail: