Cope better with relative locations

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: orderly2
 Title: Orderly Next Generation
-Version: 1.99.49
+Version: 1.99.50
 Authors@R: c(person("Rich", "FitzJohn", role = c("aut", "cre"),
                     email = "[email protected]"),
              person("Robert", "Ashton", role = "aut"),

R/location.R

@@ -96,6 +96,21 @@ orderly_location_add <- function(name, type, args, verify = TRUE, root = NULL) {
 
   if (type == "path") {
     assert_scalar_character(args$path, name = "path")
+    if (!fs::is_absolute_path(args$path)) {
+      ## This only happens where the current working directory is not
+      ## the same as the root.
+      root_error <- !file.exists(file.path(root$path, args$path)) &&
+        file.exists(args$path)
+      if (root_error) {
+        root_fix <- as.character(fs::path_rel(args$path, root$path))
+        cli::cli_abort(
+          c("'path' must be given relative to the orderly root",
+            x = paste("You have provided the relative path '{args$path}',",
+                      "which exists, but does not exist relatively to",
+                      "'{root$path}', the root of your orderly archive"),
+            i = "Consider passing '{root_fix}' instead"))
+      }
+    }
   } else if (type == "http") {
     assert_scalar_character(args$url, name = "url")
   } else if (type == "packit") {
@@ -114,7 +129,7 @@ orderly_location_add <- function(name, type, args, verify = TRUE, root = NULL) {
 
   if (verify) {
     cli_alert_info("Testing location")
-    location_driver_create(type, args)$verify()
+    location_driver_create(type, args, root)$verify()
     cli_alert_success("Location configured successfully")
   }
 
@@ -129,9 +144,18 @@ orderly_location_add <- function(name, type, args, verify = TRUE, root = NULL) {
 
 ##' @rdname orderly_location_add
 ##'
-##' @param path The path to the other archive root. This should
-##'   generally be an absolute path, or the behaviour of outpack will
-##'   be unreliable.
+##' @param path The path to the other archive root. This can be a
+##'   relative or absolute path, with different tradeoffs.  If you use
+##'   an absolute path, then this location will typically work well on
+##'   this machine, but it may behave poorly when the location is
+##'   found on a shared drive **and** when you use your orderly root
+##'   from more than one system.  This setup is common when using an
+##'   HPC system.  If you use a relative path, then we will interpret
+##'   it **relative to your orderly root** and not the directory that
+##'   you evaluate this command from.  Typically your path should
+##'   include leading dots (e.g. `../../somewhere/else`) as you should
+##'   not nest orderly projects.  This approach should work fine on
+##'   shared filesystems.
 ##'
 ##' @export
 orderly_location_add_path <- function(name, path, verify = TRUE, root = NULL) {
@@ -496,16 +520,19 @@ location_driver <- function(location_name, root) {
   i <- match(location_name, root$config$location$name)
   type <- root$config$location$type[[i]]
   args <- root$config$location$args[[i]]
-  location_driver_create(type, args)
+  location_driver_create(type, args, root)
 }
 
 
-location_driver_create <- function(type, args) {
+location_driver_create <- function(type, args, root) {
   location <- switch(type,
                      path = orderly_location_path$new,
                      http = orderly_location_http$new,
                      packit = orderly_location_packit,
                      custom = orderly_location_custom)
+  ## Set the workdir to the orderly root so that paths are interpreted
+  ## relative to the root.
+  withr::local_dir(root$path)
   do.call(location, args)
 }
 

tests/testthat/test-location-path.R

@@ -359,3 +359,52 @@ test_that("Fail to push sensibly if files have been changed", {
     suppressMessages(orderly_location_push(ids[[4]], "server", client)),
     "Did not find suitable file, can't push this packet")
 })
+
+
+test_that("allow relative paths in path locations", {
+  tmp <- withr::local_tempdir()
+  a <- suppressMessages(orderly_init(file.path(tmp, "a")))
+  b <- suppressMessages(orderly_init(file.path(tmp, "b")))
+  ids <- vcapply(1:3, function(i) create_random_packet(b))
+  withr::with_dir(a, orderly_location_add_path("b", path = "../b"))
+  orderly_location_pull_metadata(root = a)
+  expect_equal(orderly_search(root = a, location = "b"), ids)
+})
+
+
+test_that("allow weird absolute paths in path locations", {
+  tmp <- withr::local_tempdir()
+  nms <- letters[1:3]
+  root <- suppressMessages(
+    set_names(lapply(nms, function(x) orderly_init(file.path(tmp, x))), nms))
+
+  withr::with_dir(
+    tmp, orderly_location_add_path("b", path = "../b", root = "a"))
+  expect_equal(
+    orderly_location_list(verbose = TRUE, root = root$a)$args[[2]]$path,
+    "../b")
+
+  fs::dir_create(file.path(root$a, "some/deep/path"))
+  withr::with_dir(
+    file.path(root$a, "some/deep/path"),
+    orderly_location_add_path("c", path = "../c"))
+  expect_equal(
+    orderly_location_list(verbose = TRUE, root = root$a)$args[[3]]$path,
+    "../c")
+})
+
+
+test_that("provide hint when wrong relative path given", {
+  tmp <- withr::local_tempdir()
+  tmp <- normalizePath(tmp)
+  nms <- letters[1:3]
+  root <- suppressMessages(
+    set_names(lapply(nms, function(x) orderly_init(file.path(tmp, x))), nms))
+
+  err <- expect_error(
+    withr::with_dir(
+      tmp, orderly_location_add_path("b", path = "b", root = "a")),
+    "'path' must be given relative to the orderly root")
+  expect_equal(err$body[[2]],
+               "Consider passing '../b' instead")
+})

tests/testthat/test-location.R

@@ -850,7 +850,8 @@ test_that("can add a packit location", {
     list("packit",
          list(url = "https://example.com",
               token = "abc123",
-              save_token = FALSE)))
+              save_token = FALSE),
+         root))
 })
 
 test_that("can add a packit location without a token", {
@@ -873,7 +874,8 @@ test_that("can add a packit location without a token", {
   expect_equal(
     mockery::mock_args(mock_driver)[[1]],
     list("packit",
-         list(url = "https://example.com", token = NULL, save_token = TRUE)))
+         list(url = "https://example.com", token = NULL, save_token = TRUE),
+         root))
 })
 
 test_that("cope with trailing slash in url if needed", {
@@ -947,7 +949,7 @@ test_that("can add a custom outpack location", {
   expect_equal(location_driver(loc$name, root), "value")
   mockery::expect_called(mock_orderly_location_driver_create, 1)
   expect_equal(mockery::mock_args(mock_orderly_location_driver_create)[[1]],
-               list("custom", list(driver = "foo::bar", a = 1, b = 2)))
+               list("custom", list(driver = "foo::bar", a = 1, b = 2), root))
 })