Greatly simplified the copy to the staging directory during upload.

For symlinks, we just reproduce them exactly, regardless of whether they
are local or not. If they're non-local links that end up being dangling
after the copy... well too bad, the user shouldn't have created them.

For copies, we don't bother creating hardlinks. This is safer as it
avoids propagation of hardlinks into the registry, whereby users could
then inadvertently modify our "immutable" files. Performance should not
be majorly impacted as we were copying across partitions anyway.

To offset any perf hit, the copy is now parallelized with parLapply.
We also check that the copied files have the correct MD5 checksums and
sizes, just to protect against filesystem corruption.

Author: LTLA

DESCRIPTION

@@ -12,6 +12,7 @@ Imports:
     methods,
     tools,
     jsonlite,
+    digest,
     httr2
 Suggests:
     parallel,

NAMESPACE

@@ -33,9 +33,9 @@ export(validateVersion)
 export(versionPath)
 import(httr2)
 import(methods)
+importFrom(digest,digest)
 importFrom(jsonlite,fromJSON)
 importFrom(jsonlite,toJSON)
 importFrom(utils,URLencode)
 importFrom(utils,download.file)
-importFrom(utils,head)
 importFrom(utils,tail)

R/uploadDirectory.R

@@ -17,8 +17,15 @@
 #' @param spoof String containing the name of a user on whose behalf this request is being made.
 #' This should only be used if the Gobbler service allows spoofing by the current user. 
 #' If \code{NULL}, no spoofing is performed.
+#' @param concurrent Integer specifying the number of concurrent downloads.
+#' Only used if files need to be copied from \code{directory} to \code{staging}.
 #' @inheritParams createProject
 #'
+#' @details
+#' If \code{directory} is not inside \code{staging}, a new staging subdirectory is allocated by \code{\link{allocateUploadDirectory}}.
+#' The contents of \code{directory} are then copied to the new subdirectory, preserving all symbolic links, dotfiles and empty directories.
+#' If \code{consume=NULL}, it is set to \code{TRUE} as the copied contents will no longer be used. 
+#'
 #' @return On success, \code{NULL} is invisibly returned.
 #'
 #' @author Aaron Lun
@@ -47,7 +54,7 @@
 #' \code{\link{fetchManifest}}, to obtain the manifest of the versioned asset's contents.
 #'
 #' @export
-uploadDirectory <- function(project, asset, version, directory, staging, url, probation=FALSE, consume=NULL, ignore..=TRUE, spoof=NULL) {
+uploadDirectory <- function(project, asset, version, directory, staging, url, probation=FALSE, consume=NULL, ignore..=TRUE, spoof=NULL, concurrent=1L) {
     # Normalizing them so that they're comparable, in order to figure out whether 'directory' lies inside 'staging'.
     directory <- normalizePath(directory)
     staging <- normalizePath(staging)
@@ -65,6 +72,7 @@ uploadDirectory <- function(project, asset, version, directory, staging, url, pr
     if (!in.staging) {
         new.dir <- allocateUploadDirectory(staging) 
         on.exit(unlink(new.dir, recursive=TRUE), add=TRUE, after=FALSE) # cleaning up after the request is done.
+        to.copy <- character(0)
 
         for (p in list.files(directory, recursive=TRUE, include.dirs=TRUE, all.files=TRUE)) {
             src <- file.path(directory, p)
@@ -76,19 +84,22 @@ uploadDirectory <- function(project, asset, version, directory, staging, url, pr
 
             src.link <- Sys.readlink(src)
             if (src.link == "") {
-                .link_or_copy(src, dest, p)
-
-            } else if (.is_absolute_or_local_link(src.link, p)) {
+                to.copy <- c(to.copy, list(c(src, dest)))
+            } else {
                 if (!file.symlink(src.link, dest)) {
-                    stop("failed to create a symlink for '", p, "' in the staging directory")
+                    stop("failed to create a symlink '", dest, "' to '", src.link, "'")
                 }
-
-            } else {
-                full.src <- normalizePath(file.path(dirname(src), src.link))
-                .link_or_copy(full.src, dest, p)
             }
         }
 
+        if (concurrent == 1L) {
+            lapply(to.copy, copy_file)
+        } else {
+            cl <- parallel::makeCluster(concurrent)
+            on.exit(parallel::stopCluster(cl), add=TRUE, after=FALSE)
+            parallel::parLapply(cl, to.copy, copy_file)
+        }
+
         directory <- new.dir
     }
 
@@ -112,37 +123,23 @@ uploadDirectory <- function(project, asset, version, directory, staging, url, pr
     invisible(NULL)
 }
 
-#' @importFrom utils head
-.is_absolute_or_local_link <- function(target, link.path) {
-    # Assuming Unix-style file paths, who uses a Windows HPC anyway?
-    if (startsWith(target, "/")) {
-        return(TRUE)
+#' @importFrom digest digest
+copy_file <- function(job) {
+    src <- job[[1]]
+    dest <- job[[2]]
+    if (!file.copy(src, dest)) {
+        stop("failed to copy '", src, "' to '", dest, "'")
     }
 
-    # Both 'target' and 'link.path' should be relative at this point, so the
-    # idea is to check whether 'file.path(dirname(link.path), target)' is still
-    # a child of 'dirname(link.path)'.
-    pre.length <- length(strsplit(link.path, "/")[[1]]) - 1L
-    post.fragments <- head(strsplit(target, "/")[[1]], -1L)
-
-    for (x in post.fragments) {
-        if (x == ".") {
-            next
-        } else if (x == "..") {
-            pre.length <- pre.length - 1L
-            if (pre.length < 0L) {
-                return(FALSE)
-            }
-        } else {
-            pre.length <- pre.length + 1L
-        }
+    old.size <- file.info(src)$size
+    new.size <- file.info(dest)$size
+    if (old.size != new.size) {
+        stop("mismatching sizes for '", src, "' and '", dest, "'")
     }
 
-    TRUE
-}
-
-.link_or_copy <- function(src, dest, p) {
-    if (!suppressWarnings(file.link(src, dest)) && !file.copy(src, dest)) {
-        stop("failed to link or copy '", p, "' to the staging directory")
+    old.md5 <- digest(file=src)
+    new.md5 <- digest(file=dest)
+    if (old.md5 != new.md5) {
+        stop("mismatching MD5 checksums for '", src, "' and '", dest, "'")
     }
 }

man/uploadDirectory.Rd

@@ -45,6 +45,21 @@ test_that("upload works as expected for regular files", {
     expect_true(all(vapply(man, function(x) !is.null(x$link), TRUE)))
 })
 
+test_that("upload works as expected with parallel copying", {
+    uploadDirectory(
+        project="test-upload", 
+        asset="penelope", 
+        version="1", 
+        directory=tmp,
+        staging=info$staging, 
+        url=info$url,
+        concurrent=2
+    )
+
+    man <- fetchManifest("test-upload", "penelope", "1", registry=info$registry)
+    expect_identical(sort(names(man)), c("blah.txt", "foo/bar.txt"))
+})
+
 test_that("upload works as expected with empty directories", {
     tmp <- tempfile()
     dir.create(tmp)
@@ -91,14 +106,10 @@ test_that("upload works as expected for relative links", {
     dest <- tempfile()
     dir.create(dest)
     write(file=file.path(dest, "blah.txt"), letters)
-    file.symlink("blah.txt", file.path(dest, "whee.txt")) # relative links within the directory are preserved.
+    file.symlink("blah.txt", file.path(dest, "whee.txt"))
     dir.create(file.path(dest, "foo"))
     file.symlink("../whee.txt", file.path(dest, "foo/bar.txt")) 
 
-    outside <- tempfile(tmpdir=dirname(dest))
-    write(file=outside, "FOOBLEWOOBLE")
-    file.symlink(file.path("../../", basename(outside)), file.path(dest, "foo/outer.txt")) # relative links outside the directory are lost.
-
     uploadDirectory(
         project="test-more-upload", 
         asset="nicole", 
@@ -109,12 +120,10 @@ test_that("upload works as expected for relative links", {
     )
 
     man <- fetchManifest("test-more-upload", "nicole", "1", registry=info$registry)
-    expect_identical(sort(names(man)), c("blah.txt", "foo/bar.txt", "foo/outer.txt", "whee.txt"))
+    expect_identical(sort(names(man)), c("blah.txt", "foo/bar.txt", "whee.txt"))
     expect_false(is.null(man[["whee.txt"]]$link))
-    expect_null(man[["foo/outer.txt"]]$link)
     expect_false(is.null(man[["foo/bar.txt"]]$link))
     expect_null(man[["blah.txt"]]$link)
-    expect_identical(13L, man[["foo/outer.txt"]]$size)
     expect_identical(man[["whee.txt"]]$size, man[["foo/bar.txt"]]$size)
     expect_identical(man[["whee.txt"]]$size, man[["blah.txt"]]$size)
 })