From 99916a2565591b408bcc5e418852e70e34429cdf Mon Sep 17 00:00:00 2001 From: LTLA Date: Sun, 15 Sep 2024 21:36:20 -0700 Subject: [PATCH] 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 | 4 ++-- NAMESPACE | 1 + R/startGobbler.R | 2 +- R/uploadDirectory.R | 38 +++++++++++++++++++++++++++++++----- man/startGobbler.Rd | 2 +- tests/testthat/test-upload.R | 16 ++++++++++----- 6 files changed, 49 insertions(+), 14 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 3fff9e8..8b7b2dc 100644 --- a/DESCRIPTION +++ b/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. diff --git a/NAMESPACE b/NAMESPACE index d1ddbf7..592b906 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -33,3 +33,4 @@ importFrom(jsonlite,fromJSON) importFrom(jsonlite,toJSON) importFrom(utils,URLencode) importFrom(utils,download.file) +importFrom(utils,head) diff --git a/R/startGobbler.R b/R/startGobbler.R index 441bc6e..be6bb67 100644 --- a/R/startGobbler.R +++ b/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))) } diff --git a/R/uploadDirectory.R b/R/uploadDirectory.R index 860f43f..4e354de 100644 --- a/R/uploadDirectory.R +++ b/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 +} diff --git a/man/startGobbler.Rd b/man/startGobbler.Rd index e346376..471616f 100644 --- a/man/startGobbler.Rd +++ b/man/startGobbler.Rd @@ -10,7 +10,7 @@ startGobbler( registry = tempfile(), port = NULL, wait = 1, - version = "0.3.2", + version = "0.3.4", overwrite = FALSE ) diff --git a/tests/testthat/test-upload.R b/tests/testthat/test-upload.R index 0d78445..e149c44 100644 --- a/tests/testthat/test-upload.R +++ b/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) })