Minor refactoring of upload link code for clarity.

Also fleshed out the test for unpackPaths with non-trivial path=.
ArtifactDB · Oct 28, 2024 · 787f959 · 787f959
1 parent 3670080
commit 787f959
Show file tree

Hide file tree

Showing 2 changed files with 16 additions and 8 deletions.
diff --git a/R/uploadDirectory.R b/R/uploadDirectory.R
@@ -51,20 +51,16 @@ uploadDirectory <- function(project, asset, version, directory, staging, url, pr
 
             src.link <- Sys.readlink(src)
             if (src.link == "") {
-                if (!suppressWarnings(file.link(src, dest)) && !file.copy(src, dest)) {
-                    stop("failed to link or copy '", p, "' to the staging directory")
-                }
+                .link_or_copy(src, dest, p)
 
-            } else if (.has_valid_link(src.link, p)) {
+            } else if (.is_absolute_or_local_link(src.link, p)) {
                 if (!file.symlink(src.link, dest)) {
                     stop("failed to create a symlink for '", p, "' in the staging directory")
                 }
 
             } else {
                 full.src <- normalizePath(file.path(dirname(src), src.link))
-                if (!suppressWarnings(file.link(full.src, dest)) && !file.copy(full.src, dest)) {
-                    stop("failed to link or copy '", p, "' to the staging directory")
-                }
+                .link_or_copy(full.src, dest, p)
             }
         }
         directory <- new.dir
@@ -84,12 +80,15 @@ uploadDirectory <- function(project, asset, version, directory, staging, url, pr
 }
 
 #' @importFrom utils head
-.has_valid_link <- function(target, link.path) {
+.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)
     }
 
+    # 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)
 
@@ -108,3 +107,9 @@ uploadDirectory <- function(project, asset, version, directory, staging, url, pr
 
     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")
+    }
+}
diff --git a/tests/testthat/test-unpackPath.R b/tests/testthat/test-unpackPath.R
@@ -4,6 +4,9 @@ test_that("unpackPath works as expected", {
     out <- unpackPath("project/asset/version/path")
     expect_identical(out, list(project="project", asset="asset", version="version", path="path"))
 
+    out <- unpackPath("project/asset/version/foo/bar")
+    expect_identical(out, list(project="project", asset="asset", version="version", path="foo/bar"))
+
     out <- unpackPath("project/asset/version")
     expect_identical(out, list(project="project", asset="asset", version="version", path=NULL))