Speculatively write pbs driver

.github/workflows/check-linux.yaml

@@ -0,0 +1,54 @@
+# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples
+# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help
+on:
+  push:
+    branches: [main, master]
+  pull_request:
+    branches: [main, master]
+
+name: check-linux
+
+jobs:
+  check-linux:
+    runs-on: ${{ matrix.config.os }}
+
+    name: ${{ matrix.config.os }} (${{ matrix.config.r }})
+
+    strategy:
+      fail-fast: false
+      matrix:
+        config:
+          - {os: ubuntu-latest,   r: 'devel', http-user-agent: 'release'}
+          - {os: ubuntu-latest,   r: 'release'}
+          - {os: ubuntu-latest,   r: 'oldrel-1'}
+
+    # Shorter timeout to prevent mac builders hanging for 6 hours!
+    timeout-minutes: 30
+
+    env:
+      GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
+      R_KEEP_PKG_SOURCE: yes
+
+    steps:
+      - uses: actions/checkout@v3
+
+      - uses: r-lib/actions/setup-pandoc@v2
+
+      - uses: r-lib/actions/setup-r@v2
+        with:
+          r-version: ${{ matrix.config.r }}
+          http-user-agent: ${{ matrix.config.http-user-agent }}
+          use-public-rspm: true
+
+      - uses: r-lib/actions/setup-r-dependencies@v2
+        with:
+          extra-packages: |
+            any::rcmdcheck
+            local::../..
+          needs: check
+          working-directory: drivers/linux
+
+      - uses: r-lib/actions/check-r-package@v2
+        with:
+          upload-snapshots: true
+          working-directory: drivers/linux

drivers/pbs/DESCRIPTION → drivers/linux/DESCRIPTION

@@ -1,19 +1,24 @@
-Package: hipercow.pbs
-Title: Generic PBS Support for 'hipercow'
+Package: hipercow.linux
+Title: Generic Linux Support for 'hipercow'
 Version: 0.1.0
 Authors@R: c(person("Rich", "FitzJohn", role = c("aut", "cre"),
                     email = "rich.fitzjohn@gmail.com"),
              person("Wes", "Hinsley", role = "aut"),
              person("Imperial College of Science, Technology and Medicine",
                     role = "cph"))
-Description: Driver for using any PBS cluster.  Specific cluster drivers
-    will be needed to set up your cluster, but these will be tiny.
+Description: Driver for using any Linux cluster (running pbs or
+    slurm).  Specific cluster drivers will be needed to set up your
+    cluster, but these will be tiny packages that mostly provide a
+    small amount of configuration and additional tooling.
 License: MIT + file LICENSE
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.3.1
 URL: https://github.com/mrc-ide/hipercow, https://mrc-ide.github.io/hipercow
 BugReports: https://github.com/mrc-ide/hipercow/issues
+Imports:
+    cli,
+    hipercow
 Suggests:
     testthat (>= 3.0.0)
 Config/testthat/edition: 3

drivers/linux/R/batch.R

@@ -0,0 +1,73 @@
+write_batch_task_run <- function(task_id, config, resources, path_root) {
+  data <- template_data(config, resources, path_root)
+  data$task_id <- task_id
+  template_name <- sprintf("%s/task_run.sh", config$manager)
+  str <- glue_whisker(read_template(template_name), data)
+  path <- file.path(path_root, "hipercow", "tasks", task_id, BATCH_RUN)
+  writeLines(str, path)
+  path
+
+}
+
+
+read_template <- function(name) {
+  read_lines(hipercow_linux_file(sprintf("templates/%s", name)))
+}
+
+
+template_data <- function(config, resources, path_root) {
+  ## Semicolon delimited list on windows; see "Managing libraries" in
+  ## https://cran.r-project.org/doc/manuals/r-release/R-admin.html
+  hipercow_library <- paste(config$path_lib, path_bootstrap(config), sep = ":")
+
+  ## TODO: default walltime should come from the configuration
+  walltime <- walltime_with_default(resources, "01:00:00")
+  ## TODO: treatment of cores is quite hard, especially where cores =
+  ## Inf wants to select a single node.  There's also issues around
+  ## "mpinodes" and issues around the complete lack of any sort of
+  ## usable documentation.
+  cores <- resources$cores
+  stopifnot(is.finite(cores))
+
+  memory <- memory_with_default(resources, "4")
+
+  ## TODO: we're going to need to query this periodically and find the
+  ## best match.  Running 'module avail R/' gets us most of the way
+  ## there but we need this in machine readable format and also limit
+  ## to those in the "prod" set..  The prod module will be ict
+  ## specific so that needs to go into the configuration too.
+  r_module <- "R/4.3.2-gfbf-2023a"
+
+  list(
+    hostname = hostname(),
+    date = as.character(Sys.time()),
+    hipercow_version = hipercow_version(),
+    r_module = r_module,
+    walltime = walltime,
+    cores = cores,
+    memory = memory,
+    hipercow_library = hipercow_library)
+}
+
+
+
+walltime_with_default <- function(resources, default) {
+  if (is.null(resources$max_runtime)) {
+    return(default)
+  }
+  mins <- resources$max_runtime %% 60
+  hours <- resources$max_runtime %/% 60
+  sprintf("%02d:02d:00", hours, mins)
+}
+
+
+memory_with_default <- function(resources, default) {
+  if (!is.null(resources$memory_per_node)) {
+    return(resources$memory_per_node)
+  }
+  if (!is.null(resources$memory_per_process)) {
+    stopifnot(is.finite(resources$cores))
+    return(resources$memory_per_process * resources$cores)
+  }
+  default
+}

drivers/linux/R/bootstrap.R

@@ -0,0 +1,3 @@
+## TODO: we need something that the user can run easily without having
+## installed hipercow that will install it in the right place in the
+## directory that they are looking at.

drivers/linux/R/check.R

@@ -0,0 +1,3 @@
+linux_check <- function(path_root) {
+  TRUE
+}

drivers/linux/R/config.R

@@ -0,0 +1,6 @@
+new_linux_config <- function(manager) {
+  if (manager != "pbs") {
+    cli::cli_abort("Only pbs cluster managers are supported")
+  }
+  list(manager = manager)
+}

drivers/linux/R/constants.R

@@ -0,0 +1,5 @@
+# nolint start
+BATCH_RUN <- "run.sh"
+SCHEDULER_ID <- "scheduler_id"
+TASK_LOG <- "log"
+# nolint end

drivers/linux/R/driver.R

@@ -0,0 +1,121 @@
+hipercow_driver_linux <- function() {
+  hipercow::hipercow_driver(
+    configure = linux_configure,
+    submit = linux_submit,
+    status = linux_status,
+    info = linux_info,
+    log = linux_log,
+    result = linux_result,
+    cancel = linux_cancel,
+    provision_run = linux_provision_run,
+    provision_list = linux_provision_list,
+    provision_compare = linux_provision_compare,
+    keypair = linux_keypair,
+    check_hello = linux_check_hello,
+    cluster_info = linux_cluster_info)
+}
+
+
+linux_submit <- function(id, resources, config, path_root) {
+  path_batch <- write_batch_task_run(id, config, resources, path_root)
+  scheduler_id <- do_linux_submit(path_batch, id, config, path_root)
+  path_scheduler_id <- file.path(dirname(path_batch), SCHEDULER_ID)
+  writeLines(dide_id, path_scheduler_id)
+}
+
+
+linux_status <- function(id, config, path_root) {
+  path_started <- file.path(path_root, "hipercow", "tasks", id,
+                            "status-running")
+  ifelse(file.exists(path_started), "running", "submitted")
+}
+
+
+linux_info <- function(id, config, path_root) {
+  path_scheduler_id <- file.path(
+    path_root, "hipercow", "tasks", id, SCHEDULER_ID)
+  scheduler_id <- readLines(path_scheduler_id)
+  status <- do_linux_status(scheduler_id, config)
+  list(status = status,
+       time_started = time_started(id, path_root))
+}
+
+
+linux_result <- function(id, config, path_root) {
+  ## Nothing to do here, but we might want to do something in the
+  ## cases where the result is not found but the task has failed.
+}
+
+
+linux_log <- function(id, outer, config, path_root) {
+  if (outer) {
+    path_scheduler_id <- file.path(path_root, "hipercow", "tasks", id, SCHEDULER_ID)
+    scheduler_id <- readLines(path_scheduler_id)
+    ## TODO: read .o and .e files
+    NULL
+  } else {
+    readlines_if_exists(file.path(path_root, "hipercow", "tasks", id, TASK_LOG))
+  }
+}
+
+
+linux_cancel <- function(id, config, path_root) {
+  path_scheduler_id <- file.path(path_root, "hipercow", "tasks", id, SCHEDULER_ID)
+  scheduler_id <- vcapply(path_scheduler_id, readLines, USE.NAMES = FALSE)
+  scheduler_id <- scheduler_id[order(as.integer(scheduler_id), decreasing = TRUE)]
+  cancelled <- do_linux_cancel(scheduler_id, config)
+  ## Times are awful:
+  time_started <- rep(Sys.time(), length(id))
+  time_started[] <- NA
+  if (any(cancelled)) {
+    time_started[cancelled] <- time_started(id[cancelled], path_root)
+  }
+  list(cancelled = cancelled, time_started = time_started)
+}
+
+
+linux_check_hello <- function(config, path_root) {
+  if (!linux_check(path_root)) {
+    cli::cli_abort("Failed checks for using linux cluster; please see above")
+  }
+  resources <- hipercow::hipercow_resources_validate(NULL, "linux", path_root)
+  ## TODO: perhaps clusters could return a "fast" queue for use.
+  resources
+}
+
+
+linux_keypair <- function(config, path_root) {
+  cli::cli_abort("encryption not yet supported with the linux driver")
+}
+
+
+linux_provision <- function(args, config, path_root) {
+  cli::cli_abort("provisioning is important but hard")
+}
+
+
+linux_provision_list <- function(args, config, path_root) {
+  if (is.null(args)) {
+    hash <- NULL
+  } else {
+    hash <- conan_config <- rlang::inject(conan2::conan_configure(
+              !!!args,
+              path = path_root,
+              path_lib = config$path_lib,
+              path_bootstrap = path_bootstrap(config)))$hash
+  }
+  path_lib <- file.path(path_root, config$path_lib)
+  conan2::conan_list(path_lib, hash)
+}
+
+
+linux_provision_compare <- function(curr, prev, config, path_root) {
+  path_lib <- file.path(path_root, config$path_lib)
+  conan2::conan_compare(path_lib, curr, prev)
+}
+
+
+time_started <- function(id, path_root) {
+  path <- file.path(path_root, "hipercow", "tasks", id, "status-running")
+  file.info(path, extra_cols = FALSE)$ctime
+}

drivers/linux/R/manager.R

@@ -0,0 +1,39 @@
+do_linux_submit <- function(path_batch, config, path_root) {
+  scheduler_id <- switch(
+    config$manager,
+    pbs = do_linux_submit_pbs(path_batch, config, path_root),
+    cli::cli_abort("Submission from unknown manager '{config$manager}'"))
+}
+
+
+do_linux_status <- function(scheduler_id, config) {
+  switch(config$manager,
+         pbs = do_linux_status_pbs(scheduler_id, config),
+         cli::cli_abort("Status from unknown manager '{config$manager}'"))
+}
+
+
+do_linux_cancel <- function(scheduler_id, config) {
+  switch(config$manager,
+         pbs = do_linux_cancel_pbs(scheduler_id, config),
+         cli::cli_abort("Submission from unknown manager '{config$manager}'"))
+}
+
+
+do_linux_submit_pbs <- function(path_batch, id, config, path_root) {
+  withr::with_dir(path_root, system3("qsub", path_batch, stdout = TRUE))
+}
+
+
+do_linux_status_pbs <- function(scheduler_id, config) {
+  ## TODO: we don't really know what this returns yet, and how to
+  ## interpret it.
+  system3("qstat", scheduler_id)
+}
+
+
+do_linux_cancel_pbs <- function(scheduler_id, config) {
+  ## TODO: we don't really know what this returns yet, and how to
+  ## interpret it.
+  system3("qdel", scheduler_id)
+}

drivers/linux/R/util.R

@@ -0,0 +1,37 @@
+`%||%` <- function(x, y) { # nolint
+  if (is.null(x)) y else x
+}
+
+
+glue_whisker <- function(template, data) {
+  transformer <- function(...) {
+    ## This transformer prevents a NULL entry destroying the string
+    glue::identity_transformer(...) %||% ""
+  }
+  glue::glue_data(data, template, .open = "{{", .close = "}}",
+                  .trim = FALSE, .transformer = transformer)
+}
+
+hostname <- function() {
+  Sys.info()[["nodename"]]
+}
+
+
+hipercow_linux_file <- function(path) {
+  system.file(path, mustWork = TRUE, package = "hipercow.linux")
+}
+
+
+hipercow_version <- function() {
+  as.character(utils::packageVersion("hipercow"))
+}
+
+
+read_lines <- function(...) {
+  paste(readLines(...), collapse = "\n")
+}
+
+
+normalize_path <- function(path) {
+  normalizePath(path, winslash = "/", mustWork = TRUE)
+}