pkg_install works remotely

Needs improvements, though:
- no progress bar
- should not copy over all the data

NAMESPACE

@@ -12,6 +12,4 @@ export(pkg_status)
 export(repo_activate)
 export(repo_deactivate)
 export(repo_status)
-importFrom(cliapp,default_app)
-importFrom(cliapp,start_app)
 importFrom(utils,head)

R/onload.R

@@ -2,5 +2,6 @@
 pkgman_data <- new.env(parent = emptyenv())
 
 .onLoad <- function(libname, pkgname) {
+  ## TODO: load callr from the private library
   if (should_remote()) pkgman_data$remote <- callr::r_session$new()
 }

R/package.R

@@ -9,35 +9,51 @@
 #'   latest available version.
 #' @param num_workers Number of worker processes to use.
 #' @param ask Whether to ask for confirmation.
-#' @importFrom cliapp default_app start_app
 #' @export
+
 pkg_install <- function(pkg, lib = .libPaths()[[1L]], upgrade = FALSE,
                         num_workers = 1L, ask = interactive()) {
 
   start <- Sys.time()
-  default_app() %||% start_app()
 
+  r <- remote(
+    function(...) get("pkg_install_make_plan", asNamespace("pkgman"))(...),
+    list(pkg = pkg, lib = lib, upgrade = upgrade))
+
+  ask_for_confirmation(ask, r$get_solution()$data, lib)
+
+  inst <- remote(
+    function(...) get("pkg_install_do_plan", asNamespace("pkgman"))(...),
+    list(remotes = r, lib = lib, num_workers = num_workers))
+
+  attr(inst, "total_time") <- Sys.time() - start
+  class(inst) <- c("pkgman_install_result", class(inst))
+  inst
+}
+
+pkg_install_make_plan <- function(pkg, lib, upgrade) {
+
+  cliapp::default_app() %||% cliapp::start_app()
+
   r <- pkgdepends::remotes$new(pkg, library = lib)
 
   # Solve the dependency graph
   policy <- if (upgrade) "upgrade" else "lazy"
   r$solve(policy = policy)
   r$stop_for_solve_error()
+  r
+}
 
-  ask_for_confirmation(ask, r$get_solution()$data, lib)
+pkg_install_do_plan <- function(remotes, lib, num_workers) {
 
   # Actually download packages as needed
-  r$download_solution()
-  r$stop_for_solution_download_error()
+  remotes$download_solution()
+  remotes$stop_for_solution_download_error()
 
   # Get the installation plan and hand it over to pkginstall
-  plan <- r$get_install_plan()
+  plan <- remotes$get_install_plan()
   inst <- pkginstall::install_package_plan(plan = plan, lib = lib,
                                            num_workers = num_workers)
-
-  attr(inst, "total_time") <- Sys.time() - start
-  class(inst) <- c("pkgman_install_result", class(inst))
-  inst
 }
 
 #' Install a local development package

R/print.R

@@ -46,7 +46,7 @@ print.pkgman_install_result <- function(x, ...) {
   inst_time <- sum(unlist(x$install_time), na.rm = TRUE)
   total_time <- prettyunits::pretty_dt(attr(x, "total_time")) %||% "???s"
 
-  app <- default_app() %||% start_app()
+  app <- cliapp::default_app() %||% cliapp::start_app()
   app$alert_success(paste0(
     direct, " + ", deps, " pkgs | ",
     "kept ", curr, ", updated ", upd, ", new ", newly, " | ",
@@ -66,7 +66,7 @@ ask_for_confirmation <- function(ask, sol, lib) {
 
   if (! (n_newly + n_upd)) return()
 
-  app <- default_app() %||% start_app()  
+  app <- cliapp::default_app() %||% cliapp::start_app()  
   package_list <- function(x) {
     app$div(
       class = "pkglist",
@@ -109,7 +109,7 @@ warn_for_loaded_packages <- function(pkgs, lib) {
     )
     bad <- maybe_bad[normalizePath(loaded_from) == normalizePath(lib)]
     if (length(bad)) {
-      app <- default_app()
+      app <- cliapp::default_app()
       app$alert_warning(
         "Package(s) {format_items(bad)} are already loaded, installing \\
          them may cause problems. Use {code pkgload::unload()} to unload them.",

R/subprocess.R

@@ -1,4 +1,8 @@
 
+## ----------------------------------------------------------------------
+## Helper functions
+## ----------------------------------------------------------------------
+
 remote_is_alive <- function() {
   inherits(rs <- pkgman_data$remote, "process") && rs$is_alive()
 }
@@ -7,9 +11,9 @@ should_remote <- function() {
   !isFALSE(getOption("pkgman.subprocess"))
 }
 
-remote <- function(func) {
-  if (should_remote() || !remote_is_alive()) {
-    return(func())
+remote <- function(func, args = list()) {
+  if (!should_remote() || !remote_is_alive()) {
+    return(do.call(func, args))
   }
 
   rs <- pkgman_data$remote
@@ -18,7 +22,9 @@ remote <- function(func) {
     pr <- callr::poll(list(rs$get_poll_connection()), 5000)[[1]]
     state <- rs$get_state()
   }
-  if (state != "idle") return(func())
+  if (state != "idle") stop("Subprocess is busy or cannot start")
 
-  rs$run(func)$result
+  withCallingHandlers(
+    rs$run(func, args),
+    "callr_message" = function(x) print(x))
 }

tests/testthat/test-subprocess.R

@@ -20,3 +20,9 @@ test_that("no dependencies are loaded with pkgman", {
   if (length(new_pkgs) > 1) print(new_pkgs)
   expect_identical(new_pkgs, "pkgman")
 })
+
+test_that("remote", {
+  pid <- remote(function() Sys.getpid())
+  expect_equal(pid, pkgman_data$remote$get_pid())
+  expect_equal(remote(function() 4 + 4), 8)
+})