Avoid failing to install git remotes when packfile parsing fails for unnecessary files

R/git-protocol.R

@@ -523,6 +523,7 @@ unpack_packfile_repo <- function(parsed, output, url) {
   done <- logical(length(trees))
   idx <- 1L
   wd <- character()
+  paths <- logical(0L)  # named vector of (path, success)
 
   mkdirp(output)
 
@@ -532,7 +533,9 @@ unpack_packfile_repo <- function(parsed, output, url) {
     tr <- trees[[i]]$object
     for (l in seq_len(nrow(tr))) {
       idx <<- idx + 1L
-      opath <- file.path(output, paste(c(wd, tr$path[l]), collapse = "/"))
+      rpath <- paste(c(wd, tr$path[l]), collapse = "/")
+      opath <- file.path(output, rpath)
+      paths[[rpath]] <<- FALSE
       if (tr$type[l] == "tree") {
         tidx <- which(tr$hash[l] == names(trees))[1]
         if (is.na(tidx)) {
@@ -543,10 +546,12 @@ unpack_packfile_repo <- function(parsed, output, url) {
         }
         wd <<- c(wd, tr$path[l])
         mkdirp(opath)
+        paths[[rpath]] <<- TRUE
         process_tree(tidx)
         wd <<- utils::head(wd, -1)
-      } else if (tr$type[l] == "blob") {
+      } else if (tr$type[l] == "blob" && !is.null(parsed[[tr$hash[l]]])) {
         writeBin(parsed[[tr$hash[l]]]$raw, opath)
+        paths[[rpath]] <<- TRUE
       }
     }
   }
@@ -567,10 +572,9 @@ unpack_packfile_repo <- function(parsed, output, url) {
     )
   }
 
-
   for (i in seq_along(trees)) process_tree(i)
 
-  invisible()
+  invisible(paths)
 }
 
 # -------------------------------------------------------------------------

R/type-git.R

@@ -93,11 +93,76 @@ download_remote_git <- function(resolution, target, target_tree,
   pkgdir <- file.path(target_tree, resolution$package)
   mkdirp(pkgdir)
   async_git_download_repo(url, ref = sha, output = pkgdir)$
+    then(function(files) {
+      check_git_download_missing_files(
+        resolution$remote[[1]],
+        files = files,
+        output = pkgdir
+      )
+    })$
     then(function() {
       "Got"
     })
 }
 
+
+#' Check Downloaded git Repo for Missing Files
+#'
+#' Throws a warning if any files failed to download which are necessary for the
+#' building of the package from source. Will ignore the failure to download
+#' files outside a specified remote sub-directory or omitted using a
+#' `.Rbuildignore` file.
+#'
+#' @param remote A git remote
+#' @param files A named logical vector with names corresponding to relative
+#'   file paths to each file in the git repository, and a logical value
+#'   indicating whether the file was successfully downloaded.
+#' @param output The directory containing downloaded repository files
+#'
+#' @return NULL, function used for its side-effects
+#'
+
+check_git_download_missing_files <- function(remote, files, output) {
+  # subdir consistently trailing in path separator
+  sep <- .Platform$file.sep
+  subdir <- remote$subdir %||% ""
+  if (nchar(subdir) && !endsWith(subdir, sep)) {
+    subdir <- paste0(subdir, sep)
+  }
+
+  # ignore reporting files outside of subdirectory
+  in_subdir <- startsWith(names(files), subdir)
+  files <- files | !in_subdir
+
+  # ignore reporting files that would be ignored using `.Rbuildignore`
+  ignore_path_parts <- c(output, remote$subdir, ".Rbuildignore")
+  ignore_path <- do.call(file.path, as.list(ignore_path_parts))
+  if (file.exists(ignore_path)) {
+    subdir_path <- character(length(files))
+    subdir_path[in_subdir] <- substring(
+      names(files)[in_subdir],
+      nchar(subdir) + 1
+    )
+
+    ignore <- readLines(ignore_path, warn = FALSE)
+    for (pattern in ignore[nzchar(ignore)]) {
+      is_ignored <- grepl(pattern, subdir_path, perl = TRUE, ignore.case = TRUE)
+      files <- files | (in_subdir & is_ignored)
+    }
+  }
+
+  # warn if any files are necessary, but missing
+  if (any(!files)) {
+    throw(pkg_error(
+      "{sum(!files)} necessary file{?s} {?was/were} unable to be fetched",
+      paste0("'", names(files)[!files], "'", collapse = ", "),
+      .class = "pkgdepends_git_fetch"
+    ))
+  }
+
+  invisible(files)
+}
+
 satisfy_remote_git <- function(resolution, candidate,
                                config, ...) {
   ## 1. package name must match

tests/testthat/fixtures/test-rebuild.R

@@ -0,0 +1,37 @@
+#' Rebuild fixtures
+#'
+#' @examples
+#' testthat::test_dir(testthat::test_path("fixtures"))
+#'
+
+test_that("Rebuilding Git Packfile Fixtures", {
+  fixture_updated <- function(msg) {
+    stop(errorCondition(msg, class = "error_fixture_updated"))
+  }
+
+  write_packfile <- function(packfile) {
+    function(x, ...) {
+      path <- file.path(
+        find_package_root(),
+        "tests",
+        "testthat",
+        "fixtures",
+        packfile
+      )
+      writeBin(x, path)
+      fixture_updated(sprintf("Updated fixture: '%s'", path))
+    }
+  }
+
+  url <- "https://github.com/dgkf/test-pkgdepends-git-remote-submod-req.git"
+  expect_error(class = "error_fixture_updated", with_mocked_bindings(
+    git_unpack = write_packfile("git-test-submod-req.pack"),
+    git_download_repo(url)
+  ))
+
+  url <- "https://github.com/dgkf/test-pkgdepends-git-remote-submod-opt.git"
+  expect_error(class = "error_fixture_updated", with_mocked_bindings(
+    git_unpack = write_packfile("git-test-submod-opt.pack"),
+    git_download_repo(url)
+  ))
+})

tests/testthat/test-type-git.R

@@ -197,3 +197,52 @@ test_that("type_git_make_resolution", {
   # TODO
   expect_true(TRUE)
 })
+
+test_that("check_git_download_missing_files warns when missing required files", {
+  packfile <- test_path("fixtures", "git-test-submod-req.pack")
+  pack <- git_unpack(packfile)
+
+  url <- "https://website.org/repo.git"
+  output <- tempfile("pkgdepends-test-git-submod-req")
+  dir.create(output)
+  on.exit(unlink(output, recursive = TRUE))
+
+  # fixture successfully unpacks and produces expected file contents
+  files <- expect_silent(unpack_packfile_repo(pack, output, url = url))
+  expect_vector(files, logical())
+  expect_named(files)
+
+  # files required for build
+  expect_true("inst/generics" %in% names(files))
+  expect_false(files[["inst/generics"]])  # submodule "file" missing
+
+  expect_error(class = "pkgdepends_git_fetch", {
+    check_git_download_missing_files(list(), files, output)
+  })
+})
+
+test_that("check_git_download_missing_files is silent when missing files are unnecessary", {
+  packfile <- test_path("fixtures", "git-test-submod-opt.pack")
+  pack <- git_unpack(packfile)
+
+  url <- "https://website.org/repo.git"
+  output <- tempfile("pkgdepends-test-git-submod-req")
+  dir.create(output)
+  on.exit(unlink(output, recursive = TRUE))
+
+  # fixture successfully unpacks and produces expected file contents
+  files <- expect_silent(unpack_packfile_repo(pack, output, url = url))
+  expect_vector(files, logical())
+  expect_named(files)
+  expect_true("generics" %in% names(files))
+  expect_true("pkgdepends.test.002/inst/generics" %in% names(files))
+
+  # submodule "files" unnecessary for build
+  expect_false(files[["pkgdepends.test.002/inst/generics"]])  # .Rbuildignore'd
+  expect_false(files[["generics"]])  # outside subdir
+
+  expect_silent({
+    remote <- list(subdir = "pkgdepends.test.002")
+    check_git_download_missing_files(remote, files, output)
+  })
+})