From 97c06e9b2e40180f22397d540d30d51a382244e5 Mon Sep 17 00:00:00 2001 From: Paul Lietar Date: Thu, 30 May 2024 18:03:34 +0100 Subject: [PATCH] Mark files as read-only when copying them into the archive. It is easy for a user to inspect a packet's result by opening it up in their editor and accidentally edit and save the file. If they didn't have a file store and no other packet contains a copy of the file then the packet may be irremediably corrupted. Marking the file as read-only is an easy way to prevent this. Of course a user can always force their way around it, but this should at least prevent most accidental occurrences. A side-effect of this change is that file copied out of the archive will now be read-only as well, since copying the files preserves the access mode. This is desirable when copying files from a dependency, but may not be when copying outside of a packet context. If this causes problems we can introduce some option to `orderly_copy_files` to add the write bit back on files it copies. Files that were put into the file store were already being marked as read-only, so this change makes the two implementations more consistent. The executable bit was being cleared as well, which seems unnecessary to me and in some contexts even wrong (a user may well want to include a bash script in their report). I've changed the chmod operation from "a-wx" to "a-w". This doesn't matter on Windows, where executable bits don't exist. A few places around the codebase were using `unlink(recursive=TRUE)` to remove directories, which on Windows fails silently if the directory contains read-only files. One example of this was the temporary draft directory for a packet, which would not be deleted on completion of a run if a file from a dependency had been copied in. While `unlink` has a `force` option to change the permissions before deleting, I've decided to use `fs::dir_delete` instead, which always allows deleting read-only files, and which does not fail silently. For consistency I've replaced all the uses of unlink, even some that we don't expect to be removing files from the archive or file store. --- R/outpack_root.R | 3 +++ R/outpack_store.R | 2 +- R/run.R | 2 +- R/validate.R | 4 ++-- tests/testthat/helper-orderly.R | 6 ++--- tests/testthat/helper-outpack.R | 25 ++++++++++++++------ tests/testthat/test-init.R | 6 ++--- tests/testthat/test-location-path.R | 2 +- tests/testthat/test-location.R | 7 +++--- tests/testthat/test-orderly.R | 4 ++-- tests/testthat/test-outpack-packet.R | 34 ++++++++++++++++++++++++---- tests/testthat/test-plugin.R | 2 +- tests/testthat/test-root.R | 8 +++---- tests/testthat/test-run.R | 14 ++++++++---- tests/testthat/test-validate.R | 15 +++++++----- vignettes/introduction.Rmd | 2 +- 16 files changed, 93 insertions(+), 43 deletions(-) diff --git a/R/outpack_root.R b/R/outpack_root.R index 7044fa05..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") + } } 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 3a510bab..fd9f2808 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 c7e88ff6..155edab2 100644 --- a/tests/testthat/test-location-path.R +++ b/tests/testthat/test-location-path.R @@ -362,7 +362,7 @@ test_that("Fail to push sensibly if files have been changed", { ## Corrupt one file: path <- file.path(client$path, "archive", "b", ids[["b"]], "script.R") - append_lines(path, "# anything") + forcibly_truncate_file(path) expect_error( suppressMessages(orderly_location_push(ids[[4]], "server", client)), 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: