From c43b3ba5a7a0cf48a004e42c9de1792439381410 Mon Sep 17 00:00:00 2001 From: Paul Lietar Date: Tue, 10 Sep 2024 17:35:28 +0100 Subject: [PATCH] Use the fs package to copy files. It has more bells and whistles, and is often more performant. In particular, it makes use of `CopyFileW` (on Windows) and `copy_file_range` (on Linux) when applicable. This offers a big speedup when copying a file within a network drive, which is a common use case for orderly. The reason why `file.copy` was introduced in #165 is that copying read-only files with the `fs` package wasn't working properly on Samba drives. It turns out this situation only occurs when `overwrite = TRUE`. When the flag is set to FALSE, the copy succeeds. To work around this we do an initial check before the copy to delete any files in the destination path, and copy with `overwrite = FALSE`. This was manually tested by running the test suite with the `TMPDIR` environment variable set to a path on a network drive. --- DESCRIPTION | 2 +- R/outpack_root.R | 7 +- R/outpack_store.R | 7 +- R/util.R | 44 +++++++++--- tests/testthat/helper-outpack.R | 4 +- tests/testthat/test-outpack-store.R | 6 +- tests/testthat/test-util.R | 100 ++++++++++++++++++++++++++++ 7 files changed, 149 insertions(+), 21 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 8853892e..e1415fbf 100644 --- a/DESCRIPTION +++ b/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 = "rich.fitzjohn@gmail.com"), person("Robert", "Ashton", role = "aut"), diff --git a/R/outpack_root.R b/R/outpack_root.R index a73e6c49..6f936ea8 100644 --- a/R/outpack_root.R +++ b/R/outpack_root.R @@ -71,9 +71,10 @@ 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) + # 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, + make_writable = TRUE) } } diff --git a/R/outpack_store.R b/R/outpack_store.R index 4036e60c..523f3d0b 100644 --- a/R/outpack_store.R +++ b/R/outpack_store.R @@ -32,11 +32,10 @@ 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) + # Files in the archive are read-only. It's easier on the user if we make + # them writable again. + copy_files(src, dst, overwrite = overwrite, make_writable = FALSE) invisible(dst) }, diff --git a/R/util.R b/R/util.R index 4b79555d..4176148f 100644 --- a/R/util.R +++ b/R/util.R @@ -185,16 +185,44 @@ expand_dirs <- function(files, workdir) { copy_files <- function(src, dst, overwrite = FALSE, - copy_mode = TRUE) { + make_writable = 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 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) + fs::file_delete(dst[exists]) + } + + fs::file_copy(src, dst, overwrite = FALSE) + if (make_writable && length(dst) > 0) { + fs::file_chmod(dst, "a+w") } } diff --git a/tests/testthat/helper-outpack.R b/tests/testthat/helper-outpack.R index f85f25c7..98789a09 100644 --- a/tests/testthat/helper-outpack.R +++ b/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) } diff --git a/tests/testthat/test-outpack-store.R b/tests/testthat/test-outpack-store.R index abe3a361..af6143cc 100644 --- a/tests/testthat/test-outpack-store.R +++ b/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) }) diff --git a/tests/testthat/test-util.R b/tests/testthat/test-util.R index daf6d3f6..34e1973a 100644 --- a/tests/testthat/test-util.R +++ b/tests/testthat/test-util.R @@ -322,6 +322,7 @@ test_that("read_string strips newlines", { }) +<<<<<<< HEAD describe("expand_dirs_virtual", { files <- list( "d1" = c("f2", "f3"), @@ -466,3 +467,102 @@ 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)) + expect_no_error(copy_files(character(0), character(0), make_writable = 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 <- file.path(d, sprintf("destination%d.txt", 1:4)) + + writeLines("Hello", src) + fs::file_chmod(src, "a-w") + + copy_files(src, dst[[1]]) + copy_files(src, dst[[2]], overwrite = TRUE) + copy_files(src, dst[[3]], make_writable = TRUE) + copy_files(src, dst[[4]], make_writable = TRUE, overwrite = TRUE) + + expect_true(all(fs::file_access(dst, mode="read"))) + expect_equal(unname(fs::file_access(dst, mode="write")), + c(FALSE, FALSE, TRUE, TRUE)) + }) + + + 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("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") + }) +})