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

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

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

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

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

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)

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

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())),

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)),

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)
 

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())

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

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)),

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

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'")