installPkg: do no work when using cached package and annotate safely (#…

…726)

* remove the uncalled annotatePkgs()

* write annotated DESCRIPTION to temporary location then rename

* compute pkgSrc only when needed

* do no additional work when package present in cache

* news update

* avoid redundant package-install path declarations

* remove redundant existing-library-restore-on-error

* stop when rename of annotated DESCRIPTION fails

* cleanup on description annotation error

* NEWS clean-up

* simpler error handler

NEWS.md

@@ -1,8 +1,10 @@
 # packrat (development version)
 
-# packrat 0.9.2
+- Improve package installation in a multi-process environment. Do less work
+  when a target package is in the cache and write package `DESCRIPTION`
+  updates to temporary files before persisting. (#720)
 
-# Packrat 0.9.2 (UNRELEASED)
+# Packrat 0.9.2
 
 - Update vendored `renv` package to include functions for normalizing and
   transforming Posit Package Manager URLs. (#711)

R/restore.R

@@ -391,16 +391,12 @@ annotatePkgDesc <- function(pkgRecord, project, lib = libDir(project)) {
     content[name] <- records[name]
   }
 
-  # Write it out
-  write_dcf(content, descFile)
-}
-
-# Annotate a set of packages by name.
-annotatePkgs <- function(pkgNames, project, lib = libDir(project)) {
-  records <- searchPackages(lockInfo(project), pkgNames)
-  lapply(records, function(record) {
-    annotatePkgDesc(record, project, lib)
-  })
+  # Write it out using a temporary file so DESCRIPTION is never partial.
+  tmpf <- tempfile(tmpdir = dirname(descFile))
+  write_dcf(content, tmpf)
+  if (!file.rename(tmpf, descFile)) {
+    stop("Unable to rename annotated package DESCRIPTION")
+  }
 }
 
 # Takes a vector of package names, and returns a logical vector that indicates
@@ -433,10 +429,6 @@ installPkg <- function(pkgRecord,
                        repos,
                        lib = libDir(project))
 {
-  pkgSrc <- NULL
-  type <- "built source"
-  needsInstall <- TRUE
-
   # If we're trying to install a package that overwrites a symlink, e.g. for a
   # cached package, we need to move that symlink out of the way (otherwise
   # `install.packages()` or `R CMD INSTALL` will fail with surprising errors,
@@ -451,7 +443,6 @@ installPkg <- function(pkgRecord,
   # NOTE: a symlink that points to a path that doesn't exist
   # will return FALSE when queried by `file.exists()`!
   if (file.exists(pkgInstallPath) || is.symlink(pkgInstallPath)) {
-
     temp <- tempfile(tmpdir = lib)
     file.rename(pkgInstallPath, temp)
     on.exit({
@@ -467,36 +458,20 @@ installPkg <- function(pkgRecord,
   cacheCopyStatus <- new.env(parent = emptyenv())
   copiedFromCache <- restoreWithCopyFromCache(project, pkgRecord, cacheCopyStatus)
   if (copiedFromCache) {
-    type <- cacheCopyStatus$type
-    needsInstall <- FALSE
+    return(cacheCopyStatus$type)
   }
 
   # Try restoring the package from the 'unsafe' cache, if applicable.
   copiedFromUntrustedCache <- restoreWithCopyFromUntrustedCache(project, pkgRecord, cacheCopyStatus)
   if (copiedFromUntrustedCache) {
-    type <- cacheCopyStatus$type
-    needsInstall <- FALSE
+    return(cacheCopyStatus$type)
   }
 
-  # if we still need to attempt an installation at this point,
-  # remove a prior installation / file from library (if necessary).
-  # we move the old directory out of the way temporarily, and then
-  # delete if if all went well, or restore it if installation failed
-  # for some reason
-  if (needsInstall && file.exists(pkgInstallPath)) {
-    pkgRenamePath <- tempfile(tmpdir = lib)
-    file.rename(pkgInstallPath, pkgRenamePath)
-    on.exit({
-      if (file.exists(pkgInstallPath))
-        unlink(pkgRenamePath, recursive = !is.symlink(pkgRenamePath))
-      else
-        file.rename(pkgRenamePath, pkgInstallPath)
-    }, add = TRUE)
-  }
+  type <- "built source"
+  needsInstall <- TRUE
 
   # Try downloading a binary (when appropriate).
-  if (!(copiedFromCache || copiedFromUntrustedCache) &&
-      hasBinaryRepositories() &&
+  if (hasBinaryRepositories() &&
       binaryRepositoriesEnabled() &&
       isFromCranlikeRepo(pkgRecord, repos) &&
       pkgRecord$name %in% availablePackagesBinary(repos = repos)[, "Package"] &&
@@ -531,14 +506,11 @@ installPkg <- function(pkgRecord,
     })
   }
 
-  if (is.null(pkgSrc)) {
+  if (needsInstall) {
     # When installing from github/bitbucket/gitlab or an older version, use the cached source
     # tarball or zip created in snapshotSources
     pkgSrc <- file.path(srcDir(project), pkgRecord$name,
                         pkgSrcFilename(pkgRecord))
-  }
-
-  if (needsInstall) {
 
     if (!file.exists(pkgSrc)) {
       # If the source file is missing, try to download it. (Could happen in the
@@ -598,35 +570,37 @@ installPkg <- function(pkgRecord,
   }
 
   # Annotate DESCRIPTION file so we know we installed it
-  annotatePkgDesc(pkgRecord, project, lib)
+  withCallingHandlers(
+    annotatePkgDesc(pkgRecord, project, lib),
+    error = function(e) {
+      unlink(pkgInstallPath, recursive = TRUE)
+    }
+  )
 
   # copy package into cache if enabled
   if (isUsingCache(project)) {
-    pkgPath <- file.path(lib, pkgRecord$name)
-
     # copy into global cache if this is a trusted package
     if (isTrustedPackage(pkgRecord$name)) {
-      descPath <- file.path(pkgPath, "DESCRIPTION")
+      descPath <- file.path(pkgInstallPath, "DESCRIPTION")
       if (!file.exists(descPath)) {
         warning("cannot cache package: no DESCRIPTION file at path '", descPath, "'")
       } else {
         hash <- hash(descPath)
         moveInstalledPackageToCache(
-          packagePath = pkgPath,
+          packagePath = pkgInstallPath,
           hash = hash,
           cacheDir = cacheLibDir()
         )
       }
     } else {
-      pkgPath <- file.path(lib, pkgRecord$name)
       tarballName <- pkgSrcFilename(pkgRecord)
       tarballPath <- file.path(srcDir(project), pkgRecord$name, tarballName)
       if (!file.exists(tarballPath)) {
         warning("cannot cache untrusted package: source tarball not available")
       } else {
         hash <- hashTarball(tarballPath)
         moveInstalledPackageToCache(
-          packagePath = pkgPath,
+          packagePath = pkgInstallPath,
           hash = hash,
           cacheDir = untrustedCacheLibDir()
         )

tests/testthat/test-packrat.R

@@ -7,21 +7,39 @@
 
 library(testthat)
 
+# Confirm that the package name still exists in the DESCRIPTION along with
+# the install-time annotation.
+#
+# Other fields are not included in this check.
+expect_annotated_description <- function(lib, name) {
+  desc <- file.path(lib, name, "DESCRIPTION")
+  result <- as.data.frame(readDcf(desc), stringsAsFactors = FALSE)
+
+  expect_equal(result$Package, name)
+  expect_equal(result$InstallAgent, paste('packrat', packageVersion('packrat')))
+}
+
 withTestContext({
 
-  test_that("init creates project structure and installs dependencies", {
+  test_that("init creates project structure and installs dependencies with annotated DESCRIPTION", {
     skip_on_cran()
     projRoot <- cloneTestProject("sated")
     init(enter = FALSE, projRoot, options = list(local.repos = "packages"))
     lib <- libDir(projRoot)
     expect_true(file.exists(lockFilePath(projRoot)))
     expect_true(file.exists(srcDir(projRoot)))
     expect_true(file.exists(libDir(projRoot)))
+
+    expect_true(file.exists(file.path(lib, "packrat")))
     expect_true(file.exists(file.path(lib, "breakfast")))
     expect_true(file.exists(file.path(lib, "bread")))
     expect_true(file.exists(file.path(lib, "oatmeal")))
-    expect_true(file.exists(file.path(lib, "packrat")))
     expect_true(file.exists(file.path(lib, "toast")))
+
+    expect_annotated_description(lib, "breakfast")
+    expect_annotated_description(lib, "bread")
+    expect_annotated_description(lib, "oatmeal")
+    expect_annotated_description(lib, "toast")
   })
 
   test_that("init does not install dependencies when infer.dependencies is false", {
@@ -33,10 +51,11 @@ withTestContext({
     expect_true(file.exists(lockFilePath(projRoot)))
     expect_true(file.exists(srcDir(projRoot)))
     expect_true(file.exists(libDir(projRoot)))
+
+    expect_true(file.exists(file.path(lib, "packrat")))
     expect_false(file.exists(file.path(lib, "breakfast")))
     expect_false(file.exists(file.path(lib, "bread")))
     expect_false(file.exists(file.path(lib, "oatmeal")))
-    expect_true(file.exists(file.path(lib, "packrat")))
     expect_false(file.exists(file.path(lib, "toast")))
   })
 

tests/testthat/test-restore.R

@@ -67,3 +67,32 @@ test_that("appendRemoteInfoToDescription modifies DESCRIPTION file", {
   expect_identical(tail(desc, 6), expected_desc_tail)
   getwd()
 })
+
+test_that("annotatePkgDesc annotates a package description", {
+  project <- tempfile()
+  dir.create(project)
+  lib <- libDir(project)
+  package <- file.path(lib, "fake")
+  dir.create(package, recursive = TRUE)
+  desc <- file.path(package, "DESCRIPTION")
+  write_dcf(
+    list(
+      Package = "fake",
+      Version = "1.2.3",
+      InstallAgent = "testthat"
+    ),
+    desc
+  )
+  pkgRecord <- list(
+    name = "fake",
+    source = "CRAN",
+    version = "1.2.3"
+  )
+
+  annotatePkgDesc(pkgRecord, project)
+  result <- as.data.frame(readDcf(desc), stringsAsFactors = FALSE)
+  expect_equal(result$Package, "fake")
+  expect_equal(result$Version, "1.2.3")
+  expect_equal(result$InstallAgent, paste('packrat', packageVersion('packrat')))
+  expect_equal(result$InstallSource, "CRAN")
+})