Merge pull request #110 from mrc-ide/mrc-4375

Check that files have the canonical case

R/cleanup.R

@@ -116,7 +116,7 @@ orderly_cleanup_status <- function(name = NULL, root = NULL, locate = TRUE) {
     path <- file.path(root_path, "src", name)
   }
 
-  info <- orderly_read(path)
+  info <- orderly_read(path, call = environment())
   files <- withr::with_dir(
     path,
     dir(all.files = TRUE, recursive = TRUE, no.. = TRUE))

R/config.R

@@ -1,7 +1,7 @@
 orderly_config_read <- function(path, call = NULL) {
   filename <- file.path(path, "orderly_config.yml")
-  assert_file_exists(basename(filename), workdir = path,
-                     name = "Orderly configuration")
+  assert_file_exists_relative(basename(filename), workdir = path,
+                              name = "Orderly configuration", call = call)
   raw <- yaml_read(filename)
 
   if (!is.null(raw)) {

R/metadata.R

@@ -149,25 +149,20 @@ static_orderly_description <- function(args) {
 ##'
 ##' @export
 orderly_resource <- function(files) {
-  ## TODO: an error here needs to throw a condition that we can easily
-  ## handle and or defer; that's not too hard to do though - convert
-  ## the error into something with a special class, perhaps make it a
-  ## warning in normal R and then register a handler for it in the
-  ## main run.
-  assert_character(files)
-
   p <- get_active_packet()
-  if (is.null(p)) {
-    assert_file_exists(files)
-    files_expanded <- expand_dirs(files, ".")
-  } else {
-    src <- p$orderly2$src
-    assert_file_exists(files, workdir = src)
-    files_expanded <- expand_dirs(files, src)
+  src <- if (is.null(p)) "." else p$orderly2$src
+  assert_file_exists_relative(files, workdir = src, name = "Resource file",
+                              call = environment())
+  files_expanded <- expand_dirs(files, src)
+  if (!is.null(p)) {
     if (p$orderly2$strict$enabled) {
       copy_files(src, p$path, files_expanded)
     } else {
-      assert_file_exists(files, workdir = p$path)
+      ## Above we're looking in the underlying source directory, here
+      ## we're looking within the running directory; it's not obvious
+      ## when this second case would fail, really.
+      assert_file_exists_relative(files, workdir = p$path,
+                                  name = "Resource file", call = environment())
     }
     outpack_packet_file_mark(p, files_expanded, "immutable")
     p$orderly2$resources <- c(p$orderly2$resources, files_expanded)
@@ -321,7 +316,9 @@ orderly_shared_resource <- function(...) {
   files <- validate_shared_resource(list(...), environment())
   ctx <- orderly_context(rlang::caller_env())
 
-  files <- copy_shared_resource(ctx$root_src, ctx$path, ctx$config, files)
+  files <- copy_shared_resource(ctx$root_src, ctx$path, ctx$config, files,
+                                environment())
+
   if (ctx$is_active) {
     outpack_packet_file_mark(ctx$packet, files$here, "immutable")
     ctx$packet$orderly2$shared_resources <-
@@ -350,9 +347,7 @@ validate_shared_resource <- function(args, call) {
 }
 
 
-copy_shared_resource <- function(path_root, path_dest, config, files) {
-  ## This used to be configurable in orderly1, but almost everyone
-  ## just kept it as 'global'. We might make it configurable later.
+copy_shared_resource <- function(path_root, path_dest, config, files, call) {
   shared_dir <- "shared"
   shared_path <- file.path(path_root, shared_dir)
   if (!is_directory(shared_path)) {
@@ -364,9 +359,8 @@ copy_shared_resource <- function(path_root, path_dest, config, files) {
   here <- names(files)
   there <- unname(files)
 
-  assert_file_exists(
-    there, workdir = shared_path,
-    name = sprintf("Shared resources in '%s'", shared_path))
+  assert_file_exists_relative(there, workdir = shared_path,
+                              name = "Shared resource file", call = call)
   src <- file.path(shared_path, there)
   dst <- file.path(path_dest, here)
 

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_exists_relative(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_exists_relative(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/read.R

@@ -1,5 +1,6 @@
-orderly_read <- function(path) {
-  assert_file_exists("orderly.R", workdir = path)
+orderly_read <- function(path, call = NULL) {
+  assert_file_exists_relative("orderly.R", name = "Orderly file",
+                              workdir = path, call = call)
   orderly_read_r(file.path(path, "orderly.R"))
 }
 

R/run.R

@@ -176,7 +176,7 @@ orderly_run <- function(name, parameters = NULL, envir = NULL, echo = TRUE,
   assert_is(envir, "environment")
 
   src <- file.path(root_src, "src", name)
-  dat <- orderly_read(src)
+  dat <- orderly_read(src, environment())
   parameters <- check_parameters(parameters, dat$parameters, environment())
   orderly_validate(dat, src)
 

R/util.R

@@ -599,3 +599,24 @@ pretty_bytes <- function(n) {
   }
   paste(prettyNum(round(n, 1), big.mark = ","), unit)
 }
+
+
+file_canonical_case <- function(path, workdir) {
+  if (length(path) != 1) {
+    return(vcapply(path, file_canonical_case, workdir, USE.NAMES = FALSE))
+  }
+  stopifnot(!fs::is_absolute_path(path))
+  path_split <- tolower(fs::path_split(path)[[1]])
+  base <- workdir
+  ret <- character(length(path_split))
+  for (i in seq_along(path_split)) {
+    pos <- dir(base)
+    j <- which(path_split[[i]] == tolower(pos))
+    if (length(j) != 1) {
+      return(NA_character_)
+    }
+    ret[[i]] <- pos[[j]]
+    base <- file.path(base, pos[[j]])
+  }
+  paste(ret, collapse = "/")
+}

R/util_assert.R

@@ -4,9 +4,9 @@ assert_scalar <- function(x, name = deparse(substitute(x))) {
   }
 }
 
-assert_character <- function(x, name = deparse(substitute(x))) {
+assert_character <- function(x, name = deparse(substitute(x)), call = NULL) {
   if (!is.character(x)) {
-    stop(sprintf("'%s' must be character", name), call. = FALSE)
+    cli::cli_abort("'{name}' must be character", call = call)
   }
 }
 
@@ -51,36 +51,75 @@ assert_is <- function(x, what, name = deparse(substitute(x))) {
   }
 }
 
-assert_file_exists <- function(x, workdir = NULL, name = "File") {
-  err <- !file_exists(x, workdir = workdir)
+assert_file_exists <- function(files, name = "File", call = NULL) {
+  err <- !file.exists(files)
   if (any(err)) {
-    msg <- squote(x[err])
-    stop(sprintf("%s does not exist: %s", name, paste(msg, collapse = ", ")),
-         call. = FALSE)
+    n <- cli::qty(sum(err))
+    cli::cli_abort(
+      "{name}{n}{?s} {?does/do} not exist: {collapseq(files[err])}",
+      call = call)
   }
 }
 
-assert_is_directory <- function(x, workdir = NULL, name = "Directory") {
-  assert_file_exists(x, workdir, name)
-  path <- if (is.null(workdir)) x else file.path(workdir, x)
+
+assert_file_exists_relative <- 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)) {
+    n <- cli::qty(sum(err))
+    cli::cli_abort(
+      c("{name}{n}{?s} {?does/do} not exist: {collapseq(files[err])}",
+        i = "Looked within directory '{workdir}'"),
+      call = call)
+  }
+
+  files_canonical <- file_canonical_case(files, workdir)
+  err <- is.na(files_canonical) | fs::path(files) != files_canonical
+  if (any(err)) {
+    i <- err & !is.na(files_canonical)
+    hint_case <- sprintf("For '%s', did you mean '%s'?",
+                         files[i], files_canonical[i])
+    n <- cli::qty(sum(err))
+    cli::cli_abort(
+      c("{name}{n}{?s} {?does/do} not exist: {collapseq(files[err])}",
+        set_names(hint_case, "i"),
+        i = paste("If you don't use the canonical case for a file, your code",
+                  "is not portable across different platforms"),
+        i = "Looked within directory '{workdir}'"),
+      call = call)
+  }
+}
+
+assert_is_directory <- function(path, name = "Directory", call = NULL) {
+  assert_scalar_character(path)
+  assert_file_exists(path, name = name, call = call)
   if (!is_directory(path)) {
-    stop(sprintf("Path exists but is not a directory: %s",
-                 paste(x, collapse = ", ")),
-         call. = FALSE)
+    cli::cli_abort("Path exists but is not a directory: {path}",
+                   call = call)
   }
 }
 
-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))
+    cli::cli_abort(
+      c("{name}{n}{?s} must be {?a/} 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))
+    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,8 +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-outpack-config.R

@@ -271,7 +271,7 @@ test_that("Archive is not added if file store is corrupt", {
 test_that("Validates path_archive", {
   root <- create_temporary_root(path_archive = NULL, use_file_store = TRUE)
   expect_error(orderly_config_set(core.path_archive = "/archive", root = root),
-               "'path_archive' must be relative path")
+               "'path_archive' must be a relative path")
   expect_null(root$config$core$path_archive)
 
   dir.create(file.path(root$path, "archive"))
@@ -281,7 +281,7 @@ test_that("Validates path_archive", {
 
   orderly_config_set(core.path_archive = "new-archive", root = root)
   expect_error(orderly_config_set(core.path_archive = "/archive", root = root),
-               "'path_archive' must be relative path")
+               "'path_archive' must be a relative path")
   expect_error(orderly_config_set(core.path_archive = "archive", root = root),
                "Directory already exists")
   expect_equal(root$config$core$path_archive, "new-archive")

tests/testthat/test-run.R

@@ -1221,3 +1221,15 @@ test_that("can read about dependencies", {
                                          query = "latest",
                                          files = c(input.rds = "data.rds"))))
 })
+
+
+test_that("nice error if resource file not found", {
+  path <- test_prepare_orderly_example("explicit")
+  envir <- new.env()
+  unlink(file.path(path, "src", "explicit", "data.csv"))
+  err <- expect_error(
+    orderly_run_quietly("explicit", root = path, envir = envir),
+    "Resource file does not exist: 'data.csv'")
+  expect_match(err$parent$body[[1]],
+               "Looked within directory '.+/src/explicit'")
+})