Merge pull request #9 from mrc-ide/add-drivers

Add windows driver package

.Rbuildignore

@@ -25,3 +25,4 @@
 ^tmp\.R$
 ^.*\.Rproj$
 ^\.Rproj\.user$
+^drivers$

.github/workflows/R-CMD-check.yaml → .github/workflows/check-hermod.yaml

@@ -6,10 +6,10 @@ on:
   pull_request:
     branches: [main, master]
 
-name: R-CMD-check
+name: check-hermod
 
 jobs:
-  R-CMD-check:
+  check-hermod:
     runs-on: ${{ matrix.config.os }}
 
     name: ${{ matrix.config.os }} (${{ matrix.config.r }})

.github/workflows/check-windows.yaml

@@ -0,0 +1,56 @@
+# 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-windows
+
+jobs:
+  check-windows:
+    runs-on: ${{ matrix.config.os }}
+
+    name: ${{ matrix.config.os }} (${{ matrix.config.r }})
+
+    strategy:
+      fail-fast: false
+      matrix:
+        config:
+          - {os: macos-latest,   r: 'release'}
+          - {os: windows-latest, r: 'release'}
+          - {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/windows
+
+      - uses: r-lib/actions/check-r-package@v2
+        with:
+          upload-snapshots: true
+          working-directory: drivers/windows

drivers/windows/.Rbuildignore

@@ -0,0 +1,23 @@
+^scripts$
+^Makefile$
+^README\.Rmd$
+^\.travis\.yml$
+^docs$
+^\.lintr$
+^tests/testthat/.*\.o$
+^tests/testthat/.*\.so$
+^tests/testthat/.*\.dll$
+\.dylib$
+^appveyor\.yml$
+^docker$
+^\.hadolint\.yaml$
+\.valgrind_ignore$
+^scripts$
+\.gcda$
+\.gcno$
+^pkgdown$
+^LICENSE\.md$
+^buildkite$
+^\.covrignore$
+^\.github$
+\.*gcov$

drivers/windows/.gitignore

@@ -0,0 +1,17 @@
+.Rproj.user
+.Rhistory
+.RData
+.Ruserdata
+.DS_Store
+TODO.md
+docs
+*.o
+*.so
+*.dll
+*.dylib
+*.gcda
+*.gcno
+*.gcov
+.valgrind_ignore
+inst/doc
+pkgdown

drivers/windows/.lintr

@@ -0,0 +1,7 @@
+linters: linters_with_defaults(
+    indentation_linter = NULL,
+    object_length_linter = NULL,
+    object_usage_linter = NULL,
+    cyclocomp_linter = NULL
+    )
+exclusions: list("tests/testthat.R", "R/cpp11.R")

drivers/windows/DESCRIPTION

@@ -0,0 +1,33 @@
+Package: hermod.windows
+Title: DIDE HPC Support for Windows
+Version: 0.1.0
+Authors@R: c(person("Rich", "FitzJohn", role = c("aut", "cre"),
+                    email = "[email protected]"),
+             person("Wes", "Hinsley", role = "aut"),
+             person("Imperial College of Science, Technology and Medicine",
+                    role = "cph"))
+Description: Driver for using the DIDE windows cluster, via the hermod
+    package. Typically the user will install that package directly and
+    this once they are requested to.
+License: MIT + file LICENSE
+Encoding: UTF-8
+Roxygen: list(markdown = TRUE)
+RoxygenNote: 7.2.3
+URL: https://github.com/mrc-ide/hermod.windows
+BugReports: https://github.com/mrc-ide/hermod.windows/issues
+Imports:
+    cli,
+    crayon,
+    fs,
+    glue,
+    hermod,
+    httr,
+    jsonlite,
+    keyring,
+    rematch,
+    xml2
+Suggests:
+    mockery,
+    testthat (>= 3.0.0),
+    withr
+Config/testthat/edition: 3

drivers/windows/LICENSE

@@ -0,0 +1,2 @@
+YEAR: 2021
+COPYRIGHT HOLDER: Imperial College of Science, Technology and Medicine

drivers/windows/Makefile

@@ -0,0 +1,34 @@
+PACKAGE := $(shell grep '^Package:' DESCRIPTION | sed -E 's/^Package:[[:space:]]+//')
+RSCRIPT = Rscript --no-init-file
+
+all:
+	${RSCRIPT} -e 'pkgbuild::compile_dll()'
+
+test:
+	${RSCRIPT} -e 'devtools::test()'
+
+roxygen:
+	@mkdir -p man
+	${RSCRIPT} -e "devtools::document()"
+
+install:
+	R CMD INSTALL .
+
+build:
+	R CMD build .
+
+README.md: README.Rmd
+	Rscript -e 'devtools::load_all(); knitr::knit("README.Rmd")'
+	sed -i.bak 's/[[:space:]]*$$//' README.md
+	rm -f $@.bak
+
+check:
+	_R_CHECK_CRAN_INCOMING_=FALSE make check_all
+
+check_all:
+	${RSCRIPT} -e "rcmdcheck::rcmdcheck(args = c('--as-cran', '--no-manual'))"
+
+clean:
+	rm -f src/*.o src/*.so src/*.gcda src/*.gcno src/*.gcov
+
+.PHONY: clean all test document install

drivers/windows/NAMESPACE

@@ -0,0 +1,11 @@
+# Generated by roxygen2: do not edit by hand
+
+S3method(as.character,password)
+S3method(as.character,path_mapping)
+S3method(format,dide_clusterload)
+S3method(print,dide_clusterload)
+S3method(print,password)
+S3method(print,path_mapping)
+export(dide_authenticate)
+export(dide_credentials)
+export(path_mapping)

drivers/windows/R/base64.R

@@ -0,0 +1,60 @@
+decode64 <- function(x) {
+  storr_decode64(chartr("+/", "-_", x))
+}
+
+
+encode64 <- function(x) {
+  if (x == "") {
+    ""
+  } else {
+    storr_encode64(x, "+", "/")
+  }
+}
+
+
+storr_encode64 <- function(x, char62 = "-", char63 = "_", pad = TRUE) {
+  tr <- c(LETTERS, letters, 0:9, char62, char63)
+  x <- as.integer(charToRaw(x))
+  n_bytes <- length(x)
+  n_blocks <- ceiling(n_bytes / 3L)
+  n_pad <- 3L * n_blocks - n_bytes
+
+  ## The integer() call here pads the *input* to have the correct number
+  ## of blocks of bytes.
+  x <- matrix(c(x, integer(3L * n_blocks - n_bytes)), 3L, n_blocks)
+
+  y <- matrix(integer(4 * n_blocks), 4L, n_blocks)
+  y[1L, ] <- bitwShiftR(x[1L, ], 2L)
+  y[2L, ] <- bitwOr(bitwShiftL(x[1L, ], 4L), bitwShiftR(x[2L, ], 4L))
+  y[3L, ] <- bitwOr(bitwShiftL(x[2L, ], 2L), bitwShiftR(x[3L, ], 6L))
+  y[4L, ] <- x[3L, ]
+
+  z <- tr[bitwAnd(y, 63L) + 1L]
+  if (n_pad > 0) {
+    len <- length(z)
+    z[(len - n_pad + 1):len] <- if (pad) "=" else ""
+  }
+  paste0(z, collapse = "")
+}
+
+storr_decode64 <- function(x, char62 = "-", char63 = "_", error = TRUE) {
+  ## TODO: check that the string is correctly encoded before doing
+  ## anything.
+  tr <- c(LETTERS, letters, 0:9, char62, char63)
+
+  ## sub is the timesink here, followed by strsplit.  charToRaw might be better.
+  x <- strsplit(sub("=+$", "", x), NULL)[[1]]
+  y <- match(x, tr) - 1L
+
+  n_byte <- length(y)
+  n_block <- ceiling(n_byte / 4L)
+
+  y <- matrix(c(y, integer(4L * n_block - n_byte)), 4L, n_block)
+  x <- matrix(integer(3 * n_block), 3, n_block)
+  x[1L, ] <- bitwOr(bitwShiftL(y[1L, ], 2L), bitwShiftR(y[2L, ], 4L))
+  x[2L, ] <- bitwOr(bitwShiftL(y[2L, ], 4L), bitwShiftR(y[3L, ], 2L))
+  x[3L, ] <- bitwOr(bitwShiftL(y[3L, ], 6L), y[4L, ])
+  x <- bitwAnd(x, 255L)
+
+  rawToChar(as.raw(x))
+}

drivers/windows/R/batch.R

@@ -0,0 +1,55 @@
+write_batch_task_run <- function(task_id, workdir, config, path_root) {
+  data <- template_data(workdir, config, path_root)
+  data$hermod_task_id <- task_id
+  str <- glue_whisker(read_template("task_run"), data)
+  ## NOTE: we could use the root object here, not 100% sure that's the
+  ## best line to take; alternatively write 'hermod_get_paths' or
+  ## similar?
+  path <- file.path(path_tasks(path_root), task_id, BATCH_RUN)
+  writeLines(str, path)
+  path
+}
+
+
+read_template <- function(name) {
+  read_lines(hermod_windows_file(sprintf("templates/%s.bat", name)))
+}
+
+
+template_data <- function(workdir, config, path_root) {
+  if (!fs::path_has_parent(workdir, path_root)) {
+    cli::cli_abort(c(
+      "Expected working directory to be within hermod root",
+      i = "Working directory: '{workdir}'",
+      i = "hermod root: '{path_root}'"))
+  }
+  workdir <- prepare_path(workdir, config$shares)
+  hermod_root <- prepare_path(path_root, config$shares)
+
+  ## Same path, absolute, that will be used remotely
+  hermod_root_abs <- windows_path(
+    file.path(hermod_root$drive_remote, hermod_root$rel))
+
+  r_version_str <- paste(unclass(config$r_version)[[1]], collapse = "_")
+
+  network_shares_data <- list(
+    drive = lapply(config$shares, "[[", "drive_remote"),
+    path = lapply(config$shares, "[[", "path_remote"))
+  network_shares_create <- glue_whisker(
+    "ECHO mapping {{drive}} -^> {{path}}\nnet use {{drive}} {{path}} /y",
+    network_shares_data)
+  network_shares_delete <- glue_whisker(
+    "ECHO Removing mapping {{drive}}\nnet use {{drive}} /delete /y",
+    network_shares_data)
+
+  list(hostname = hostname(),
+       date = as.character(Sys.time()),
+       hermod_version = hermod_version(),
+       r_version = r_version_str,
+       network_shares_create = paste(network_shares_create, collapse = "\n"),
+       network_shares_delete = paste(network_shares_delete, collapse = "\n"),
+       hermod_workdir_drive = workdir$drive_remote,
+       hermod_workdir_path = paste0("\\", windows_path(workdir$rel)),
+       hermod_path_root_abs = hermod_root_abs,
+       cluster_name = config$cluster)
+}

drivers/windows/R/cluster.R

@@ -0,0 +1,50 @@
+cluster_name <- function(name) {
+  if (is.null(name)) {
+    name <- cluster_name("default")
+  } else {
+    assert_scalar_character(name)
+    if (!(name %in% valid_clusters())) {
+      alias <- list(
+        "wpia-hn" = c("default", "sk", "new", "windows"))
+      alias <- set_names(rep(names(alias), lengths(alias)),
+                         unlist(alias, FALSE, FALSE))
+      name <- alias[[match_value(tolower(name), names(alias), "name")]]
+    }
+  }
+  name
+}
+
+
+valid_clusters <- function() {
+  "wpia-hn"
+}
+
+
+## TODO: this will move into an API call
+valid_templates <- function(cluster) {
+  switch(
+    cluster,
+    "wpia-hn" = "AllNodes",
+    stop(sprintf("Invalid cluster '%s'", cluster)))
+}
+
+
+valid_cores <- function(cluster) {
+  switch(cluster,
+         "wpia-hn" = 32,
+         stop(sprintf("Invalid cluster '%s'", cluster)))
+}
+
+
+r_versions <- function() {
+  if (is.null(cache$r_versions)) {
+    cache$r_versions <- r_versions_fetch()
+  }
+  cache$r_versions
+}
+
+
+r_versions_fetch <- function() {
+  credentials <- list(username = "public", username = "public")
+  web_client$new(credentials, login = FALSE)$r_versions()
+}