Use the fs package to copy files.

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: orderly2
 Title: Orderly Next Generation
-Version: 1.99.38
+Version: 1.99.39
 Authors@R: c(person("Rich", "FitzJohn", role = c("aut", "cre"),
                     email = "[email protected]"),
              person("Robert", "Ashton", role = "aut"),

R/outpack_root.R

@@ -46,9 +46,7 @@ file_export <- function(root, id, there, here, dest, overwrite, call = NULL) {
   fs::dir_create(dirname(here_full))
 
   if (root$config$core$use_file_store) {
-    for (i in seq_along(here_full)) {
-      root$files$get(hash[[i]], here_full[[i]], overwrite)
-    }
+    root$files$get(hash, here_full, overwrite)
   } else {
     there_full <- file.path(root$path, root$config$core$path_archive,
                             meta$name, meta$id, there)
@@ -71,9 +69,14 @@ file_export <- function(root, id, there, here, dest, overwrite, call = NULL) {
         })
     }
 
-    # Set copy_mode = FALSE: files in the archive are read-only. It's easier on
-    # the user if we make them writable again.
-    copy_files(there_full, here_full, overwrite = overwrite, copy_mode = FALSE)
+    copy_files(there_full, here_full, overwrite = overwrite)
+
+    # Files in the archive are read-only to avoid accidental corruption.
+    # This is however an implementation detail, and we should export them as
+    # writable again.
+    if (length(here_full) > 0) { # https://github.com/r-lib/fs/issues/471
+      fs::file_chmod(here_full, "u+w")
+    }
   }
 }
 
@@ -106,14 +109,13 @@ file_import_archive <- function(root, path, file_path, name, id) {
   ## some files behind.  This does match the behaviour of the file
   ## store version, but not of orderly.
   file_path_dest <- file.path(dest, file_path)
-  fs::dir_create(dirname(file_path_dest))
 
   ## overwrite = FALSE; see assertion above
   copy_files(file.path(path, file_path),
              file_path_dest,
              overwrite = FALSE)
 
-  if (length(file_path_dest) > 0) {
+  if (length(file_path_dest) > 0) { # https://github.com/r-lib/fs/issues/471
     fs::file_chmod(file_path_dest, "a-w")
   }
 }

R/outpack_store.R

@@ -32,11 +32,15 @@ file_store <- R6::R6Class(
                            paste(sprintf("  - %s", missing), collapse = "\n"))
         stop(not_found_error(message, missing))
       }
-      fs::dir_create(dirname(dst))
 
-      # Set copy_mode = FALSE: files in the store are read-only. It's easier on
-      # the user if we make them writable again.
-      copy_files(src, dst, overwrite = overwrite, copy_mode = FALSE)
+      copy_files(src, dst, overwrite = overwrite)
+
+      # Files in the store are read-only to avoid accidental corruption.
+      # This is however an implementation detail, and we should export them as
+      # writable again.
+      if (length(dst) > 0) { # https://github.com/r-lib/fs/issues/471
+        fs::file_chmod(dst, "u+w")
+      }
 
       invisible(dst)
     },

R/run.R

@@ -194,7 +194,8 @@ orderly_run <- function(name, parameters = NULL, envir = NULL, echo = TRUE,
 
   if (dat$strict$enabled) {
     inputs_info <- NULL
-    copy_files(file.path(src, entrypoint_filename), path)
+    copy_files(file.path(src, entrypoint_filename),
+               file.path(path, entrypoint_filename))
   } else {
     inputs_info <- copy_resources_implicit(src, path, dat$resources,
                                            dat$artefacts)
@@ -477,8 +478,7 @@ copy_resources_implicit <- function(src, dst, resources, artefacts) {
   }
 
   copy_files(file.path(src, to_copy),
-             file.path(dst, to_copy),
-             overwrite = TRUE)
+             file.path(dst, to_copy))
 
   withr::with_dir(dst, fs::file_info(to_copy))
 }

R/util.R

@@ -184,18 +184,48 @@ expand_dirs <- function(files, workdir) {
 }
 
 
-copy_files <- function(src, dst, overwrite = FALSE,
-                       copy_mode = TRUE) {
+copy_files <- function(src, dst, overwrite = FALSE) {
+  assert_character(src)
+  assert_character(dst)
+
+  if (length(src) != length(dst)) {
+    cli::cli_abort("Source and destination have different lengths")
+  }
+
+  is_dir <- fs::dir_exists(dst)
+  if (any(is_dir)) {
+    paths <- dst[is_dir]
+    cli::cli_abort(paste(
+      "Destination path{?s} {?is a directory/are directories}:",
+      "{.path {paths}}"))
+  }
+
   fs::dir_create(unique(dirname(dst)))
 
-  # mrc-5557: We intentionally don't use fs::file_copy, as it does not work
-  # reliably on mounted Samba file systems.
-  ok <- file.copy(src, dst, overwrite = overwrite,
-                  copy.mode = copy_mode,
-                  copy.date = TRUE)
-  if (any(!ok)) {
-    cli::cli_abort("Could not copy file{?s} {.file {src[!ok]}}")
+  # For some reason, file_copy does not work when `overwrite = TRUE`, the
+  # source file is read-only, the destination file is on a Samba file mount,
+  # and we are on Linux. This seems like a bug in the Linux Samba driver.
+  # See mrc-5557 for details.
+  #
+  # We work around it by always passing `overwrite = FALSE`. Instead we delete
+  # any existing files manually beforehand. It is vulnerable to race condition,
+  # as someone could recreate the file between the calls to file_delete and
+  # file_copy, but that seems unlikely. If any of the files are read-only, we
+  # refuse to proceed.
+  #
+  # If you are going to make changes to this function, make sure to run all
+  # tests with TMPDIR set to a path on a network drive.
+  if (overwrite) {
+    exists <- fs::file_exists(dst)
+    nonwrite <- !fs::file_access(dst[exists], "write")
+    if (any(nonwrite)) {
+      cli::cli_abort(
+        "Cannot overwrite non-writable file{?s}: {dst[exists][nonwrite]}")
+    }
+    fs::file_delete(dst[exists])
   }
+
+  fs::file_copy(src, dst, overwrite = FALSE)
 }
 
 

tests/testthat/helper-outpack.R

@@ -184,7 +184,7 @@ outpack_packet_end_quietly <- function(...) {
 
 forcibly_truncate_file <- function(path) {
   permissions <- fs::file_info(path)$permissions
-  fs::file_chmod(path, "a+w")
-  file.create(path)
+  fs::file_delete(path)
+  fs::file_create(path)
   fs::file_chmod(path, permissions)
 }

tests/testthat/test-outpack-config.R

@@ -97,14 +97,14 @@ test_that("Can add file_store", {
   expect_equal(length(hash_pulled), 3)
 
   dest <- temp_file()
-  dir.create(dest)
-  root$dst$files$get(hash_pulled[[1]], dest, TRUE)
-  root$dst$files$get(hash_pulled[[2]], dest, TRUE)
-  root$dst$files$get(hash_pulled[[3]], dest, TRUE)
+  root$dst$files$get(hash_pulled[[1]], file.path(dest, "a"), TRUE)
+  root$dst$files$get(hash_pulled[[2]], file.path(dest, "b"), TRUE)
+  root$dst$files$get(hash_pulled[[3]], file.path(dest, "c"), TRUE)
 
   hash_not_pulled <- outpack_metadata_core(id[["a"]], root$dst)$files$hash
-  expect_error(root$dst$files$get(hash_not_pulled[[1]], dest, TRUE),
-               "not found in store")
+  expect_error(
+    root$dst$files$get(hash_not_pulled[[1]], file.path(dest, "d"), TRUE),
+    "not found in store")
 })
 
 
@@ -144,7 +144,6 @@ test_that("Files will be searched for by hash when adding file store", {
   expect_true(root$config$core$use_file_store)
 
   dest <- temp_file()
-  dir.create(dest)
   root$files$get(outpack_metadata_core(id, root)$files$hash, dest, TRUE)
 })
 
@@ -247,10 +246,9 @@ test_that("Can add archive", {
   expect_equal(length(hash), 3)
 
   dest <- temp_file()
-  dir.create(dest)
-  root$files$get(hash[[1]], dest, TRUE)
-  root$files$get(hash[[2]], dest, TRUE)
-  root$files$get(hash[[3]], dest, TRUE)
+  root$files$get(hash[[1]], file.path(dest, "a"), TRUE)
+  root$files$get(hash[[2]], file.path(dest, "b"), TRUE)
+  root$files$get(hash[[3]], file.path(dest, "c"), TRUE)
 })
 
 

tests/testthat/test-outpack-helpers.R

@@ -8,6 +8,7 @@ test_that("can copy files from outpack", {
   expect_identical(
     readRDS(file.path(dst, "incoming.rds")),
     readRDS(file.path(root$path, "archive", "data", id, "data.rds")))
+  expect_true(fs::file_access(file.path(dst, "incoming.rds"), "write"))
 })
 
 

tests/testthat/test-outpack-store.R

@@ -34,9 +34,9 @@ test_that("Can store files", {
   expect_length(obj$list(), 10)
   expect_equal(file.exists(obj$filename(obj$list())),
                rep(TRUE, 10))
-  dest <- temp_file()
-  dir.create(dest)
-  obj$get(obj$list(), dest, TRUE)
+
+  dest <- withr::local_tempdir()
+  obj$get(obj$list(), file.path(dest, letters[1:10]), FALSE)
 })
 
 
@@ -73,3 +73,33 @@ test_that("can create a filename within the store", {
   expect_false(file.exists(p))
   expect_true(file.exists(file.path(obj$path, "tmp")))
 })
+
+
+test_that("files is the store are read-only", {
+  obj <- file_store$new(withr::local_tempdir())
+
+  f <- withr::local_tempfile()
+  writeLines("Hello", f)
+  h <- hash_file(f)
+  obj$put(f, h)
+
+  path <- obj$filename(h)
+  expect_true(fs::file_access(path, "read"))
+  expect_false(fs::file_access(path, "write"))
+})
+
+
+test_that("files are writable when retrieved", {
+  obj <- file_store$new(withr::local_tempdir())
+
+  f <- withr::local_tempfile()
+  writeLines("Hello", f)
+  h <- hash_file(f)
+  obj$put(f, h)
+
+  path <- withr::local_tempfile()
+  obj$get(h, path, TRUE)
+  expect_true(fs::file_access(path, "read"))
+  expect_true(fs::file_access(path, "write"))
+  writeLines("World", path)
+})

tests/testthat/test-util.R

@@ -466,3 +466,126 @@ 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")
 })
+
+
+describe("copy_files", {
+  src1 <- withr::local_tempfile()
+  src2 <- withr::local_tempfile()
+  writeLines("Hello", src1)
+  writeLines("World", src2)
+
+  it("can copy one file", {
+    dst <- file.path(withr::local_tempdir(), "destination.txt")
+
+    copy_files(src1, dst)
+    expect_equal(readLines(dst), "Hello")
+  })
+
+
+  it("can copy multiple files", {
+    d <- withr::local_tempdir()
+    dst1 <- file.path(d, "destination1.txt")
+    dst2 <- file.path(d, "destination2.txt")
+
+    copy_files(c(src1, src2), c(dst1, dst2))
+    expect_equal(readLines(dst1), "Hello")
+    expect_equal(readLines(dst2), "World")
+  })
+
+
+  it("can copy zero files", {
+    expect_no_error(copy_files(character(0), character(0)))
+    expect_no_error(copy_files(character(0), character(0), overwrite = TRUE))
+  })
+
+
+  it("creates parent directories", {
+    d <- withr::local_tempdir()
+    dst <- file.path(d, "path", "to", "destination.txt")
+
+    expect_false(fs::dir_exists(file.path(d, "path", "to")))
+    copy_files(src1, dst)
+    expect_true(fs::dir_exists(file.path(d, "path", "to")))
+  })
+
+
+  it("can copy a read-only file", {
+    d <- withr::local_tempdir()
+    src <- file.path(d, "source.txt")
+    dst <- c(file.path(d, "destination1.txt"),
+             file.path(d, "destination2.txt"))
+
+    writeLines("Hello", src)
+    fs::file_chmod(src, "a-w")
+
+    copy_files(src, dst[[1]])
+    copy_files(src, dst[[2]], overwrite = TRUE)
+
+    expect_true(all(fs::file_access(dst, mode = "read")))
+    expect_false(any(fs::file_access(dst, mode = "write")))
+  })
+
+
+  it("can overwrite an existing file", {
+    d <- withr::local_tempdir()
+    dst <- file.path(d, "destination.txt")
+
+    fs::file_create(dst)
+
+    expect_error(copy_files(src1, dst), "file already exists")
+
+    copy_files(src1, dst, overwrite = TRUE)
+    expect_equal(readLines(dst), "Hello")
+  })
+
+
+  it("overwrites a single file out of two", {
+    d <- withr::local_tempdir()
+    dst1 <- file.path(d, "destination1.txt")
+    dst2 <- file.path(d, "destination2.txt")
+
+    fs::file_create(dst1)
+    copy_files(c(src1, src2), c(dst1, dst2), overwrite = TRUE)
+
+    expect_equal(readLines(dst1), "Hello")
+    expect_equal(readLines(dst2), "World")
+  })
+
+
+  it("does not overwrite by default", {
+    d <- withr::local_tempdir()
+    dst <- file.path(d, "destination.txt")
+
+    fs::file_create(dst)
+
+    expect_error(copy_files(src1, dst),
+                 "file already exists")
+    expect_error(copy_files(src1, dst, overwrite = FALSE),
+                 "file already exists")
+  })
+
+
+  it("does not overwrite a read-only file", {
+    d <- withr::local_tempdir()
+    dst <- file.path(d, "destination.txt")
+
+    fs::file_create(dst)
+    fs::file_chmod(dst, "a-w")
+
+    expect_error(copy_files(src1, dst, overwrite = TRUE),
+                 "Cannot overwrite non-writable file")
+  })
+
+
+  it("errors if the destination is a directory", {
+    d <- withr::local_tempdir()
+    expect_error(copy_files(src1, d), "Destination path is a directory")
+  })
+
+
+  it("errors if argument length is different", {
+    d <- withr::local_tempfile()
+    expect_error(copy_files(c(src1, src2), d),
+                 "have different lengths")
+  })
+})