Merge branch 'main' into mrc-5276

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 = "[email protected]"),
              person("Robert", "Ashton", role = "aut"),

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)

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

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

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

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