Merge pull request #16 from mrc-ide/user-interface

Provisioning, library and bootstrapping improvements

R/provision.R

@@ -9,17 +9,22 @@
 ##' @param ... Arguments passed through to conan. See docs that we
 ##'   need to write still.
 ##'
+##' @param environment The name of the environment to provision (see
+##'   [hermod_environment_create] for details).
+##'
 ##' @inheritParams hermod_task_submit
 ##'
 ##' @return Nothing
 ##'
 ##' @export
-hermod_provision <- function(method = NULL, ..., driver = NULL, root = NULL) {
+hermod_provision <- function(method = NULL, ..., driver = NULL,
+                             environment = "default", root = NULL) {
   ## TODO: here, if *no* driver is found that could be that we are
   ## running on the headnode, either by job submission or directly,
   ## and we'll need to handle that too.
   root <- hermod_root(root)
-  dat <- hermod_driver_prepare(driver, root, environment())
-  dat$driver$provision(method, dat$config, root$path$root, ...)
+  env <- environment_load(environment, root, rlang::current_env())
+  dat <- hermod_driver_prepare(driver, root, rlang::current_env())
+  dat$driver$provision(method, dat$config, root$path$root, env, ...)
   invisible()
 }

drivers/windows/R/batch.R

@@ -38,6 +38,12 @@ template_data <- function(config, path_root) {
     "ECHO Removing mapping {{drive}}\nnet use {{drive}} /delete /y",
     network_shares_data)
 
+  ## Semicolon delimited list on windows; see "Managing libraries" in
+  ## https://cran.r-project.org/doc/manuals/r-release/R-admin.html
+  hermod_library <- paste(unix_path(config$path_lib),
+                          unix_path(config$path_bootstrap),
+                          sep = ";")
+
   list(hostname = hostname(),
        date = as.character(Sys.time()),
        hermod_version = hermod_version(),
@@ -46,5 +52,6 @@ template_data <- function(config, path_root) {
        network_shares_delete = paste(network_shares_delete, collapse = "\n"),
        hermod_root_drive = hermod_root$drive_remote,
        hermod_root_path = paste0("\\", windows_path(hermod_root$rel)),
+       hermod_library = hermod_library,
        cluster_name = config$cluster)
 }

drivers/windows/R/bootstrap.R

@@ -0,0 +1,10 @@
+bootstrap_update <- function(root = NULL) {
+  path_script <- "hermod/bootstrap-windows.R"
+  path_root <- hermod:::hermod_root(root)$path$root
+  path_script_abs <- file.path(path_root, path_script)
+  dir.create(dirname(path_script_abs), FALSE, TRUE)
+  writelines_if_different(
+    readLines(hermod_windows_file("bootstrap.R")),
+    path_script_abs)
+  hermod::hermod_provision("script", script = path_script, root = root)
+}

drivers/windows/R/config.R

@@ -1,9 +1,9 @@
 windows_configure <- function(shares = NULL, r_version = NULL) {
   path <- getwd()
   r_version <- select_r_version(r_version)
-  path_lib <- file.path("hermod", "lib", "windows",
-                        version_string(r_version, "."))
-  path_bootstrap <- "//fi--didef3.dide.ic.ac.uk/tmp/hermod-testing"
+  r_version_str <- version_string(r_version, ".")
+  path_lib <- file.path("hermod", "lib", "windows", r_version_str)
+  path_bootstrap <- sprintf("I:/bootstrap/%s", r_version_str)
   list(cluster = "wpia-hn",
        template = "AllNodes",
        shares = dide_cluster_paths(shares, path),

drivers/windows/R/dide_auth.R

@@ -4,6 +4,10 @@
 ##' @export
 dide_authenticate <- function() {
   if (keyring::keyring_is_locked()) {
+    cli::cli_text(paste(
+      "I need to unlock the system keychain in order to load and save your",
+      "credentials.  This might differ from your DIDE password, and will be",
+      "the password you use to log in to this particular machine"))
     keyring::keyring_unlock()
   }
 
@@ -42,6 +46,8 @@ dide_authenticate <- function() {
       i = "Please try again with 'dide_authenticate()'"))
   }
   keyring::key_set_with_value("hermod/dide/username", password = username)
+
+  cli::cli_text("Excellent news! Everything seems to work!")
   invisible(credentials(username, password))
 }
 

drivers/windows/R/provision.R

@@ -1,10 +1,11 @@
 ## windows-specific provisioning code, called from hermod
-windows_provision <- function(method, config, path_root, ...) {
+windows_provision <- function(method, config, path_root, environment, ...) {
   conan_config <- conan::conan_configure(
     method,
     path = path_root,
     path_lib = config$path_lib,
     path_bootstrap = config$path_bootstrap,
+    environment = environment,
     ...)
 
   id <- ids::random_id()
@@ -19,8 +20,7 @@ windows_provision <- function(method, config, path_root, ...) {
 
   client <- get_web_client()
   template <- "BuildQueue"
-  name <- sprintf("conan:%s", id)
-  dide_id <- client$submit(path_batch_unc, id, template)
+  dide_id <- client$submit(path_batch_unc, sprintf("conan:%s", id), template)
 
   path_dide_id <- file.path(dirname(path_batch), DIDE_ID)
   writeLines(dide_id, path_dide_id)

drivers/windows/R/util.R

@@ -103,6 +103,11 @@ windows_path <- function(x) {
 }
 
 
+unix_path <- function(x) {
+  gsub("\\", "/", x, fixed = TRUE)
+}
+
+
 get_system_username <- function() {
   Sys.getenv(if (is_windows()) "USERNAME" else "USER", NA_character_)
 }
@@ -133,6 +138,14 @@ readlines_if_exists <- function(path, ...) {
 }
 
 
+writelines_if_different <- function(text, path) {
+  skip <- file.exists(path) && identical(readLines(path), text)
+  if (!skip) {
+    writeLines(text, path)
+  }
+}
+
+
 version_string <- function(v, sep = "_") {
   paste(unclass(v)[[1]], collapse = sep)
 }

drivers/windows/inst/bootstrap.R

@@ -0,0 +1,30 @@
+path <- sprintf("I:/bootstrap/%s",
+                paste(unclass(getRversion())[[1]], collapse = "."))
+path_next <- sprintf("%s-next", path)
+path_prev <- sprintf("%s-prev", path)
+unlink(path_next, recursive = TRUE)
+unlink(path_prev, recursive = TRUE)
+if (file.exists(path_prev)) {
+  stop("Failed to remove previous-previous library")
+}
+if (file.exists(path_next)) {
+  stop("Failed to remove previous-next library")
+}
+dir.create(path_next, FALSE, TRUE)
+.libPaths(path_next, FALSE)
+message(sprintf("Installing packages into %s", path_next))
+pkgs <- c("hermod", "remotes", "pkgdepends")
+repos <- c("https://mrc-ide.r-universe.dev", "https://cloud.r-project.org")
+install.packages(pkgs, path_next, repos = repos)
+ok <- all(file.exists(file.path(path_next, pkgs, "Meta", "package.rds")))
+if (!ok) {
+  stop("Failed to install all packages")
+}
+curr_exists <- file.exists(path)
+if (curr_exists) {
+  file.rename(path, path_prev)
+}
+file.rename(path_next, path)
+if (curr_exists) {
+  unlink(path_prev, recursive = TRUE)
+}

drivers/windows/inst/templates/provision.bat

@@ -5,6 +5,7 @@ ECHO generated on date: {{date}}
 ECHO hermod version: {{hermod_version}}
 ECHO running on: %COMPUTERNAME%
 
+net use I: \\wpia-hn\hipercow
 call setr64_{{r_version}}.bat
 
 {{network_shares_create}}
@@ -25,6 +26,8 @@ set ErrorCode=%ERRORLEVEL%
 
 {{network_shares_delete}}
 
+net use I: /delete /y
+
 set ERRORLEVEL=%ErrorCode%
 
 if %ERRORLEVEL% neq 0 (

drivers/windows/inst/templates/task_run.bat

@@ -5,10 +5,7 @@ ECHO generated on date: {{date}}
 ECHO hermod version: {{hermod_version}}
 ECHO running on: %COMPUTERNAME%
 
-REM variables that get pulled in here
-REM * hermod_root_drive - the drive alone (e.g., Q:)
-REM * hermod_root_path - the relative path incl. drive to folder with hermod/
-
+net use I: \\wpia-hn\hipercow
 call setr64_{{r_version}}.bat
 
 {{network_shares_create}}
@@ -17,7 +14,7 @@ call setr64_{{r_version}}.bat
 cd {{hermod_root_path}}
 ECHO working directory: %CD%
 
-set R_LIBS_USER=\\fi--didef3.dide.ic.ac.uk\tmp\hermod-testing
+set R_LIBS_USER={{hermod_library}}
 
 ECHO this is a single task
 
@@ -31,6 +28,8 @@ set ErrorCode=%ERRORLEVEL%
 
 {{network_shares_delete}}
 
+net use I: /delete /y
+
 set ERRORLEVEL=%ErrorCode%
 
 if %ERRORLEVEL% neq 0 (

drivers/windows/tests/testthat/test-batch.R

@@ -14,6 +14,7 @@ test_that("batch data creates entries for share drives", {
            "network_shares_delete",
            "hermod_root_drive",
            "hermod_root_path",
+           "hermod_library",
            "cluster_name")
   expect_setequal(names(dat), nms)
   expect_true(all(vlapply(dat, function(x) is.character(x) && length(x) == 1)))
@@ -22,6 +23,10 @@ test_that("batch data creates entries for share drives", {
 
   expect_equal(dat$hermod_root_drive, "X:")
   expect_equal(dat$hermod_root_path, "\\b\\c")
+
+  v <- version_string(config$r_version, ".")
+  expected <- sprintf("hermod/lib/windows/%s;I:/bootstrap/%s", v, v)
+  expect_equal(dat$hermod_library, expected)
 })
 
 

drivers/windows/tests/testthat/test-bootstrap.R

@@ -0,0 +1,15 @@
+test_that("can run bootstrap", {
+  mount <- withr::local_tempfile()
+  root <- example_root(mount, "b/c")
+  mock_hermod_provision <- mockery::mock()
+  mockery::stub(bootstrap_update, "hermod::hermod_provision",
+                mock_hermod_provision)
+
+  bootstrap_update(root)
+  mockery::expect_called(mock_hermod_provision, 1)
+  expect_true(file.exists(
+    file.path(root$path$root, "hermod", "bootstrap-windows.R")))
+  expect_equal(
+    mockery::mock_args(mock_hermod_provision)[[1]],
+    list("script", script = "hermod/bootstrap-windows.R", root = root))
+})

drivers/windows/tests/testthat/test-config.R

@@ -13,8 +13,7 @@ test_that("Can create configuration", {
   expect_equal(config$shares, list(shares))
   expect_equal(config$r_version, numeric_version("4.3.0"))
   expect_equal(config$path_lib, "hermod/lib/windows/4.3.0")
-  expect_equal(config$path_bootstrap,
-               "//fi--didef3.dide.ic.ac.uk/tmp/hermod-testing")
+  expect_equal(config$path_bootstrap, "I:/bootstrap/4.3.0")
 })
 
 

drivers/windows/tests/testthat/test-provision.R

@@ -13,18 +13,18 @@ test_that("can run provision script", {
   config <- root$config$windows
 
   msg <- capture_messages(
-    windows_provision("script", config, path_root, poll = 0))
+    windows_provision("script", config, path_root, NULL, poll = 0))
 
   mockery::expect_called(mock_get_client, 1)
   expect_equal(mockery::mock_args(mock_get_client)[[1]], list())
 
   mockery::expect_called(mock_client$submit, 1)
   args <- mockery::mock_args(mock_client$submit)[[1]]
-  expect_match(args[[2]], "^[[:xdigit:]]{32}$")
+  expect_match(args[[2]], "^conan:[[:xdigit:]]{32}$")
   id <- args[[2]]
   batch_path <- windows_path(file.path(
     "//host.dide.ic.ac.uk/share/path/b/c/hermod/provision",
-    id,
+    sub("^conan:", "", id),
     "provision.bat"))
   expect_equal(args, list(batch_path, id, "BuildQueue"))
 
@@ -46,6 +46,7 @@ test_that("error on provision script failure", {
   path_root <- root$path$root
   config <- root$config$windows
   expect_error(
-    suppressMessages(windows_provision("script", config, path_root, poll = 0)),
+    suppressMessages(
+      windows_provision("script", config, path_root, NULL, poll = 0)),
     "Installation failed")
 })

drivers/windows/tests/testthat/test-util.R

@@ -115,3 +115,23 @@ test_that("readlines from file if exists returns null if file missing", {
   writeLines(c("a", "b"), path)
   expect_equal(readlines_if_exists(path), c("a", "b"))
 })
+
+
+test_that("writelines_if_not_exists updates files when different", {
+  path <- withr::local_tempfile()
+  writelines_if_different(c("a", "b"), path)
+  expect_equal(readLines(path), c("a", "b"))
+
+  writelines_if_different(c("a", "b", "c"), path)
+  expect_equal(readLines(path), c("a", "b", "c"))
+})
+
+
+test_that("writelines_if_not_exists does not update file when not different", {
+  path <- withr::local_tempfile()
+  writeLines(c("a", "b"), path)
+  mock_writelines <- mockery::mock()
+  mockery::stub(writelines_if_different, "writeLines", mock_writelines)
+  writelines_if_different(c("a", "b"), path)
+  mockery::expect_called(mock_writelines, 0)
+})

tests/testthat/helper-hermod.R

@@ -60,12 +60,13 @@ elsewhere_result <- function(id, config, path_root) {
 }
 
 
-elsewhere_provision <- function(method, config, path_root, ...) {
+elsewhere_provision <- function(method, config, path_root, environment, ...) {
   conan_config <- conan::conan_configure(
     method,
     path = path_root,
     path_lib = file.path("hermod", "lib"),
     path_bootstrap = .libPaths()[[1]],
+    environment = environment,
     ...)
   stopifnot(conan_config$method == "script")
   path_there <- config$path

tests/testthat/test-interface.R

@@ -129,7 +129,8 @@ test_that("can call provision", {
 
   hermod_provision(root = path_here, show_log = FALSE)
   mockery::expect_called(mock_provision, 1)
+  environment <- new_environment("default", NULL, NULL)
   expect_equal(
     mockery::mock_args(mock_provision)[[1]],
-    list(NULL, config, path_root, show_log = FALSE))
+    list(NULL, config, path_root, environment, show_log = FALSE))
 })