Expand to include relative check

R/outpack_config.R

@@ -187,15 +187,15 @@ config_set_path_archive <- function(value, root) {
     path_archive_old <- file.path(root$path, config$core$path_archive)
     if (fs::dir_exists(path_archive_old)) {
       path_archive_new <- file.path(root$path, value)
-      assert_relative_path(value, name = "path_archive")
+      assert_relative_path(value, name = "path_archive", workdir = root$path)
       assert_directory_does_not_exist(path_archive_new)
       fs::dir_copy(path_archive_old, path_archive_new)
       fs::dir_delete(path_archive_old)
     }
     config$core$path_archive <- value
   } else {
     path_archive <- file.path(root$path, value)
-    assert_relative_path(value, name = "path_archive")
+    assert_relative_path(value, name = "path_archive", workdir = root$path)
     assert_directory_does_not_exist(path_archive)
     tryCatch({
       fs::dir_create(path_archive)

R/outpack_helpers.R

@@ -150,7 +150,7 @@ orderly_copy_files <- function(..., files, dest, overwrite = TRUE,
 
 
 plan_copy_files <- function(root, id, there, here, call = NULL) {
-  assert_relative_path(there, no_dots = TRUE)
+  assert_relative_path(there, name = "File", workdir = id, call = NULL)
   validate_packet_has_file(root, id, there, call)
   is_dir <- grepl("/$", there)
   if (any(is_dir)) {

R/outpack_metadata.R

@@ -76,8 +76,7 @@ outpack_metadata_create <- function(path, name, id, time, files,
   if (is.null(files)) {
     files <- dir(path, recursive = TRUE, all.files = TRUE, no.. = TRUE)
   } else {
-    assert_relative_path(files, no_dots = TRUE)
-    assert_file_exists(files, workdir = path)
+    assert_file_exists2(files, name = "File", workdir = path)
   }
 
   if (length(file_ignore) > 0) {

R/outpack_packet.R

@@ -325,8 +325,8 @@ outpack_packet_file_mark <- function(packet, files, status) {
   status <- match_value(status, c("immutable", "ignored"))
   packet <- check_current_packet(packet)
 
-  assert_relative_path(files, no_dots = TRUE)
-  assert_file_exists(files, workdir = packet$path)
+  assert_file_exists2(files, workdir = packet$path, name = "File",
+                      call = environment())
 
   ## TODO: these are exclusive categories because we later return a
   ## 1:1 mapping of file to status

R/util_assert.R

@@ -62,6 +62,8 @@ assert_file_exists <- function(x, workdir = NULL, name = "File") {
 
 
 assert_file_exists2 <- function(files, workdir, name, call = NULL) {
+  assert_relative_path(files, name, workdir, call)
+
   assert_character(files, call = call)
   err <- !file_exists(files, workdir = workdir)
   if (any(err)) {
@@ -73,9 +75,12 @@ assert_file_exists2 <- function(files, workdir, name, call = NULL) {
   }
 
   files_canonical <- file_canonical_case(files, workdir)
-  err <- fs::path(files) != files_canonical
+  err <- is.na(files_canonical) | fs::path(files) != files_canonical
   if (any(err)) {
     n <- cli::qty(sum(err))
+    if (any(is.na(files_canonical))) {
+      browser()
+    }
     hint_case <- sprintf("For '%s', did you mean '%s'?",
                          files[err], files_canonical[err])
     cli::cli_abort(
@@ -98,17 +103,27 @@ assert_is_directory <- function(x, workdir = NULL, name = "Directory") {
   }
 }
 
-assert_relative_path <- function(x, no_dots = FALSE,
-                                 name = deparse(substitute(x))) {
-  err <- fs::is_absolute_path(x)
+assert_relative_path <- function(files, name, workdir, call = NULL) {
+  err <- fs::is_absolute_path(files)
   if (any(err)) {
-    stop(sprintf("'%s' must be relative %s",
-                 name, ngettext(length(x), "path", "paths")),
-         call. = FALSE)
+    n <- cli::qty(sum(err))
+    ## TODO: try and relativise - use path_has_parent and path_rel
+    cli::cli_abort(
+      c("{name}{n}{?s} must be relative path{?s}",
+        set_names(files[err], "x"),
+        i = "Path was relative to directory '{workdir}'"),
+      call = call)
   }
-  if (no_dots && any(grepl("..", x, fixed = TRUE))) {
-    stop(sprintf("'%s' must not contain '..' path components", name),
-         call. = FALSE)
+
+  err <- vlapply(fs::path_split(files), function(x) any(x == ".."))
+  if (any(err)) {
+    n <- cli::qty(sum(err))
+    ## TODO: try and elide these, where possible
+    cli::cli_abort(
+      c("{name}{n}{?s} must not contain '..' (parent directory) components",
+        set_names(files[err], "x"),
+        i = "Path was relative to directory '{workdir}'"),
+      call = call)
   }
 }
 

tests/testthat/helper-outpack.R

@@ -161,7 +161,6 @@ outpack_packet_run <- function(packet, script, envir = NULL) {
     envir <- new.env(parent = .GlobalEnv)
   }
   packet <- check_current_packet(packet)
-  assert_relative_path(script, no_dots = TRUE)
   assert_file_exists(script, workdir = packet$path, name = "Script")
   withr::with_dir(packet$path,
                   source_echo(script, envir = envir, echo = FALSE))

tests/testthat/test-util-assert.R

@@ -106,19 +106,21 @@ test_that("assert_is_directory", {
 
 
 test_that("assert_relative_path", {
-  expect_error(assert_relative_path(getwd()),
-               "'getwd()' must be relative path",
+  workdir <- getwd()
+  expect_error(assert_relative_path(getwd(), "File", workdir),
+               "File must be relative path",
                fixed = TRUE)
-  expect_silent(assert_relative_path("relpath"))
+  expect_silent(assert_relative_path("relpath", "File", workdir))
+  expect_silent(assert_relative_path("a/b/c", "File", workdir))
 
-  expect_silent(
-    assert_relative_path("../my/path"))
   expect_error(
-    assert_relative_path("../my/path", TRUE),
-    "must not contain '..' path components")
+    assert_relative_path("../my/path", "File", workdir),
+    "must not contain '..' (parent directory) components",
+    fixed = TRUE)
   expect_error(
-    assert_relative_path("my/../../path", TRUE),
-    "must not contain '..' path components")
+    assert_relative_path("my/../../path", "File", workdir),
+    "must not contain '..' (parent directory) components",
+    fixed = TRUE)
 })