wire in support for subdirs (#129)

Author: kevinushey

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: renv
 Type: Package
 Title: Project Environments for R
-Version: 0.6.0-63
+Version: 0.6.0-64
 Authors@R: c(
     person("Kevin", "Ushey", role = c("aut", "cre"), email = "[email protected]"),
     person("RStudio", role = c("cph"))

R/description.R

@@ -1,5 +1,5 @@
 
-renv_description_read <- function(path = NULL, package = NULL, ...) {
+renv_description_read <- function(path = NULL, package = NULL, subdir = "", ...) {
 
   # if given a package name, construct path to that package
   if (!is.null(package))
@@ -32,11 +32,18 @@ renv_description_read <- function(path = NULL, package = NULL, ...) {
     # find the DESCRIPTION file. note that for some source tarballs (e.g.
     # those from GitHub) the first entry may not be the package name, so
     # just consume everything up to the first slash
-    file <- grep("^[^/]+/DESCRIPTION$", files, value = TRUE)
-    if (length(file) != 1)
-      stopf("failed to infer path to DESCRIPTION within file '%s'", path)
+    parts <- c(if(nzchar(subdir)) subdir, "DESCRIPTION$")
+    descpath <- paste(parts, collapse = "/")
+    pattern <- paste0("(?:^|/)", descpath)
+
+    descs <- grep(pattern, files, value = TRUE)
+    if (empty(descs)) {
+      fmt <- "archive '%s' does not appear to contain a DESCRIPTION file"
+      stopf(fmt, aliased_path(path))
+    }
 
     # unpack into tempdir location
+    file <- descs[[1]]
     exdir <- renv_tempfile("renv-description-")
     renv_archive_decompress(path, files = file, exdir = exdir)
 

R/install.R

@@ -226,15 +226,35 @@ renv_install_package_local <- function(record, quiet = TRUE) {
   # get user-defined options to apply during installation
   options <- renv_install_package_options(package)
 
+  # get archive path for package
+  library <- renv_libpaths_default()
+  path <- record$Path
+
+  # for packages living within a sub-directory, we need to
+  # unpack the archive explicitly and update the path
+  subdir <- record$RemoteSubdir %||% ""
+  if (nzchar(subdir)) {
+
+    # create extraction directory
+    dir <- tempfile("renv-package-")
+    ensure_directory(dir)
+    on.exit(unlink(dir, recursive = TRUE), add = TRUE)
+
+    # decompress archive to dir
+    renv_archive_decompress(path, exdir = dir)
+
+    # update path
+    path <- file.path(dir, list.files(dir)[[1]], subdir)
+
+  }
+
   # run user-defined hooks before, after install
   before <- options$before.install %||% identity
   after  <- options$after.install %||% identity
 
   before(package)
   on.exit(after(package), add = TRUE)
 
-  library <- renv_libpaths_default()
-  path <- record$Path
 
   destination <- file.path(library, package)
   callback <- renv_file_backup(destination)

R/remotes.R

@@ -128,7 +128,7 @@ renv_remotes_resolve_github_sha_pull <- function(host, user, repo, pull) {
 
   fmt <- "https://%s/repos/%s/%s/pulls/%s"
   url <- sprintf(fmt, host, user, repo, pull)
-  jsonfile <- renv_tempfile("ren-json-")
+  jsonfile <- renv_tempfile("renv-json-")
   download(url, destfile = jsonfile, type = "github", quiet = TRUE)
   json <- renv_json_read(jsonfile)
   json$head$sha
@@ -154,11 +154,15 @@ renv_remotes_resolve_github_sha_ref <- function(host, user, repo, ref) {
 
 }
 
-renv_remotes_resolve_github_description <- function(host, user, repo, sha) {
+renv_remotes_resolve_github_description <- function(host, user, repo, subdir, sha) {
+
+  # form DESCRIPTION path
+  parts <- c(if (nzchar(subdir)) subdir, "DESCRIPTION")
+  descpath <- paste(parts, collapse = "/")
 
   # get the DESCRIPTION contents
-  fmt <- "https://%s/repos/%s/%s/contents/DESCRIPTION?ref=%s"
-  url <- sprintf(fmt, host, user, repo, sha)
+  fmt <- "https://%s/repos/%s/%s/contents/%s?ref=%s"
+  url <- sprintf(fmt, host, user, repo, descpath, sha)
   jsonfile <- renv_tempfile("renv-json-")
   download(url, destfile = jsonfile, type = "github", quiet = TRUE)
   json <- renv_json_read(jsonfile)
@@ -188,7 +192,7 @@ renv_remotes_resolve_github <- function(entry) {
     nzchar(ref)  ~ renv_remotes_resolve_github_sha_ref(host, user, repo, ref)
   )
 
-  desc <- renv_remotes_resolve_github_description(host, user, repo, sha)
+  desc <- renv_remotes_resolve_github_description(host, user, repo, subdir, sha)
 
   list(
     Package        = desc$Package,
@@ -211,10 +215,13 @@ renv_remotes_resolve_gitlab <- function(entry) {
   subdir <- entry$subdir
   ref    <- entry$ref %""% "master"
 
-  fmt <- "https://%s/api/v4/projects/%s/repository/files/DESCRIPTION/raw?ref=%s"
+  parts <- c(if (nzchar(subdir)) subdir, "DESCRIPTION")
+  descpath <- URLencode(paste(parts, collapse = "/"), reserved = TRUE)
+
+  fmt <- "https://%s/api/v4/projects/%s/repository/files/%s/raw?ref=%s"
   host <- renv_config("gitlab.host", "gitlab.com")
-  id <- paste(user, repo, sep = "%2F")
-  url <- sprintf(fmt, host, id, ref)
+  id <- URLencode(paste(user, repo, sep = "/"), reserved = TRUE)
+  url <- sprintf(fmt, host, id, descpath, ref)
 
   destfile <- renv_tempfile("renv-description-")
   download(url, destfile = destfile, type = "gitlab", quiet = TRUE)
@@ -223,7 +230,7 @@ renv_remotes_resolve_gitlab <- function(entry) {
   list(
     Package        = desc$Package,
     Version        = desc$Version,
-    Source         = "Gitlab",
+    Source         = "GitLab",
     RemoteUsername = user,
     RemoteRepo     = repo,
     RemoteSubdir   = subdir,

R/retrieve.R

@@ -170,7 +170,10 @@ renv_retrieve_gitlab <- function(record) {
 
   # TODO: remotes doesn't appear to understand how to interact with GitLab API?
   host <- record$RemoteHost %||% "gitlab.com"
-  id <- paste(record$RemoteUsername, record$RemoteRepo, sep = "%2F")
+
+  user <- record$RemoteUsername
+  repo <- record$RemoteRepo
+  id <- URLencode(paste(user, repo, sep = "/"), reserved = TRUE)
 
   fmt <- "https://%s/api/v4/projects/%s/repository/archive.tar.gz"
   url <- sprintf(fmt, host, id)
@@ -424,7 +427,11 @@ renv_retrieve_package <- function(record, url, path) {
 renv_retrieve_successful <- function(record, path, install = TRUE) {
 
   # augment record with information from DESCRIPTION file
-  desc <- renv_description_read(path)
+  subdir <- record$RemoteSubdir %||% ""
+  desc <- renv_description_read(path, subdir = subdir)
+
+  # update the record's package name, version
+  # TODO: should we warn if they didn't match for some reason?
   record$Package <- desc$Package
   record$Version <- desc$Version
 

tests/testthat/test-install.R

@@ -76,3 +76,41 @@ test_that("packages can be installed from local sources", {
   expect_true(renv_package_version("bread") == "1.0.0")
 
 })
+
+test_that("various remote styles can be used during install", {
+  skip_on_cran()
+
+  renv_tests_scope()
+  renv::init()
+
+  # install CRAN latest
+  renv::install("bread")
+  expect_true(renv_package_installed("bread"))
+  expect_true(renv_package_version("bread") == "1.0.0")
+
+  # install from archive
+  renv::install("[email protected]")
+  expect_true(renv_package_installed("bread"))
+  expect_true(renv_package_version("bread") == "0.1.0")
+
+  # install from github
+  renv::install("kevinushey/skeleton")
+  expect_true(renv_package_installed("skeleton"))
+  expect_true(renv_package_version("skeleton") == "1.0.1")
+
+  # install from github PR
+  renv::install("kevinushey/skeleton#1")
+  expect_true(renv_package_installed("skeleton"))
+  expect_true(renv_package_version("skeleton") == "1.0.2")
+
+  # install from branch
+  renv::install("kevinushey/skeleton@feature/version-bump")
+  expect_true(renv_package_installed("skeleton"))
+  expect_true(renv_package_version("skeleton") == "1.0.2")
+
+  #install from subdir
+  renv::install("kevinushey/subdir/subdir")
+  expect_true(renv_package_installed("subdir"))
+  expect_true(renv_package_version("subdir") == "0.0.0.9000")
+
+})

tests/testthat/test-retrieve.R

@@ -78,6 +78,23 @@ test_that("we can retrieve packages from GitHub", {
 
 })
 
+test_that("we can retrieve packages from GitHub (in a sub-directory)", {
+  skip_on_cran()
+  skip_if_offline(host = "github.com")
+
+  record <- list(
+    Package        = "subdir",
+    Source         = "github",
+    RemoteUsername = "kevinushey",
+    RemoteRepo     = "subdir",
+    RemoteSubdir   = "subdir",
+    RemoteSha      = "100373b23c8adae1da4e4d6995402d40e9227cfb"
+  )
+
+  renv_test_retrieve(record)
+
+})
+
 
 test_that("we can retrieve packages from GitLab", {
   skip_on_cran()

vignettes/renv.Rmd

@@ -231,7 +231,7 @@ required authentication information.
 | **Remote Source** | **Authentication**                      |
 | ----------------- | --------------------------------------- |
 | GitHub            | `GITHUB_PAT`                            |
-| Gitlab            | `GITLAB_PAT`                            |
+| GitLab            | `GITLAB_PAT`                            |
 | Bitbucket         | `BITBUCKET_USER` + `BITBUCKET_PASSWORD` |
 | Git Remotes       | `GIT_PAT` / `GIT_USER` + `GIT_PASSWORD` |