Preserve relative links within the upload directory.

This matches a corresponding update to the gobbler backend and allows users to
explicitly deduplicate their uploads when they need to store the same file
multiple times, e.g., for delayed arrays with shared seeds.

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: gobbler
-Version: 0.3.6
-Date: 2024-08-27
+Version: 0.3.7
+Date: 2024-09-15
 Title: Interface to the gobbler service
 Description:
     Friendly interface to the gobbler service.

NAMESPACE

@@ -33,3 +33,4 @@ importFrom(jsonlite,fromJSON)
 importFrom(jsonlite,toJSON)
 importFrom(utils,URLencode)
 importFrom(utils,download.file)
+importFrom(utils,head)

R/startGobbler.R

@@ -36,7 +36,7 @@
 #' 
 #' @export
 #' @importFrom utils download.file
-startGobbler <- function(staging=tempfile(), registry=tempfile(), port = NULL, wait = 1, version = "0.3.2", overwrite = FALSE) {
+startGobbler <- function(staging=tempfile(), registry=tempfile(), port = NULL, wait = 1, version = "0.3.4", overwrite = FALSE) {
     if (!is.null(running$active)) {
         return(list(new=FALSE, staging=running$staging, registry=running$registry, port=running$port, url=assemble_url(running$port)))
     }

R/uploadDirectory.R

@@ -54,15 +54,17 @@ uploadDirectory <- function(project, asset, version, directory, staging, url, pr
                 if (!suppressWarnings(file.link(src, dest)) && !file.copy(src, dest)) {
                     stop("failed to link or copy '", p, "' to the staging directory")
                 }
-            } else if (!startsWith(src.link, "/")) { # i.e., not a link to an absolute path.
+
+            } else if (.has_valid_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")
                 }
-            } else {
-                if (!file.symlink(src.link, dest)) {
-                    stop("failed to create a symlink for '", p, "' in the staging directory")
-                }
             }
         }
         directory <- new.dir
@@ -86,3 +88,29 @@ uploadDirectory <- function(project, asset, version, directory, staging, url, pr
 
     invisible(NULL)
 }
+
+#' @importFrom utils head
+.has_valid_link <- function(target, link.path) {
+    # Assuming Unix-style file paths, who uses a Windows HPC anyway?
+    if (startsWith(target, "/")) {
+        return(TRUE)
+    }
+
+    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
+        }
+    }
+
+    TRUE
+}

tests/testthat/test-upload.R

@@ -70,9 +70,13 @@ 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"))
+    file.symlink("blah.txt", file.path(dest, "whee.txt")) # relative links within the directory are preserved.
     dir.create(file.path(dest, "foo"))
-    file.symlink("../whee.txt", file.path(dest, "foo/bar.txt"))
+    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", 
@@ -84,10 +88,12 @@ 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", "whee.txt"))
-    expect_null(man[["whee"]]$link)
-    expect_null(man[["foo/bar.txt"]]$link)
+    expect_identical(sort(names(man)), c("blah.txt", "foo/bar.txt", "foo/outer.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)
 })