From 66fb661c255cb7e13504eed4d3e06607408bcd05 Mon Sep 17 00:00:00 2001 From: Rich FitzJohn Date: Thu, 30 Nov 2023 13:57:35 +0000 Subject: [PATCH 1/3] Add windows driver package --- .Rbuildignore | 1 + drivers/windows/.Rbuildignore | 23 + drivers/windows/.gitignore | 17 + drivers/windows/.lintr | 7 + drivers/windows/DESCRIPTION | 33 ++ drivers/windows/LICENSE | 2 + drivers/windows/Makefile | 34 ++ drivers/windows/NAMESPACE | 11 + drivers/windows/R/base64.R | 60 +++ drivers/windows/R/batch.R | 55 ++ drivers/windows/R/cluster.R | 50 ++ drivers/windows/R/config.R | 31 ++ drivers/windows/R/constants.R | 4 + drivers/windows/R/dide_auth.R | 98 ++++ drivers/windows/R/mounts.R | 190 +++++++ drivers/windows/R/paths.R | 140 +++++ drivers/windows/R/util.R | 132 +++++ drivers/windows/R/util_assert.R | 41 ++ drivers/windows/R/web.R | 508 ++++++++++++++++++ drivers/windows/R/zzz.R | 1 + drivers/windows/README.md | 35 ++ drivers/windows/inst/templates/task_run.bat | 42 ++ drivers/windows/man/dide_authenticate.Rd | 14 + drivers/windows/man/path_mapping.Rd | 38 ++ drivers/windows/tests/testthat.R | 4 + .../windows/tests/testthat/helper-config.R | 21 + .../windows/tests/testthat/helper-hermod.R | 2 + drivers/windows/tests/testthat/helper-web.R | 22 + .../windows/tests/testthat/responses/load.rds | Bin 0 -> 1073 bytes .../windows/tests/testthat/responses/load.txt | 228 ++++++++ .../windows/tests/testthat/responses/log.txt | 2 + .../tests/testthat/responses/status.txt | 6 + drivers/windows/tests/testthat/test-batch.R | 64 +++ drivers/windows/tests/testthat/test-cluster.R | 47 ++ drivers/windows/tests/testthat/test-config.R | 41 ++ .../windows/tests/testthat/test-dide-auth.R | 159 ++++++ drivers/windows/tests/testthat/test-mounts.R | 297 ++++++++++ drivers/windows/tests/testthat/test-paths.R | 99 ++++ .../windows/tests/testthat/test-util-assert.R | 26 + drivers/windows/tests/testthat/test-util.R | 109 ++++ .../windows/tests/testthat/test-web-format.R | 43 ++ .../windows/tests/testthat/test-web-parse.R | 172 ++++++ .../windows/tests/testthat/test-web-support.R | 62 +++ drivers/windows/tests/testthat/test-web.R | 384 +++++++++++++ tmp.R | 40 -- 45 files changed, 3355 insertions(+), 40 deletions(-) create mode 100644 drivers/windows/.Rbuildignore create mode 100644 drivers/windows/.gitignore create mode 100644 drivers/windows/.lintr create mode 100644 drivers/windows/DESCRIPTION create mode 100644 drivers/windows/LICENSE create mode 100644 drivers/windows/Makefile create mode 100644 drivers/windows/NAMESPACE create mode 100644 drivers/windows/R/base64.R create mode 100644 drivers/windows/R/batch.R create mode 100644 drivers/windows/R/cluster.R create mode 100644 drivers/windows/R/config.R create mode 100644 drivers/windows/R/constants.R create mode 100644 drivers/windows/R/dide_auth.R create mode 100644 drivers/windows/R/mounts.R create mode 100644 drivers/windows/R/paths.R create mode 100644 drivers/windows/R/util.R create mode 100644 drivers/windows/R/util_assert.R create mode 100644 drivers/windows/R/web.R create mode 100644 drivers/windows/R/zzz.R create mode 100644 drivers/windows/README.md create mode 100644 drivers/windows/inst/templates/task_run.bat create mode 100644 drivers/windows/man/dide_authenticate.Rd create mode 100644 drivers/windows/man/path_mapping.Rd create mode 100644 drivers/windows/tests/testthat.R create mode 100644 drivers/windows/tests/testthat/helper-config.R create mode 100644 drivers/windows/tests/testthat/helper-hermod.R create mode 100644 drivers/windows/tests/testthat/helper-web.R create mode 100644 drivers/windows/tests/testthat/responses/load.rds create mode 100644 drivers/windows/tests/testthat/responses/load.txt create mode 100644 drivers/windows/tests/testthat/responses/log.txt create mode 100644 drivers/windows/tests/testthat/responses/status.txt create mode 100644 drivers/windows/tests/testthat/test-batch.R create mode 100644 drivers/windows/tests/testthat/test-cluster.R create mode 100644 drivers/windows/tests/testthat/test-config.R create mode 100644 drivers/windows/tests/testthat/test-dide-auth.R create mode 100644 drivers/windows/tests/testthat/test-mounts.R create mode 100644 drivers/windows/tests/testthat/test-paths.R create mode 100644 drivers/windows/tests/testthat/test-util-assert.R create mode 100644 drivers/windows/tests/testthat/test-util.R create mode 100644 drivers/windows/tests/testthat/test-web-format.R create mode 100644 drivers/windows/tests/testthat/test-web-parse.R create mode 100644 drivers/windows/tests/testthat/test-web-support.R create mode 100644 drivers/windows/tests/testthat/test-web.R delete mode 100644 tmp.R diff --git a/.Rbuildignore b/.Rbuildignore index 6cf4d3db..db137abe 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -25,3 +25,4 @@ ^tmp\.R$ ^.*\.Rproj$ ^\.Rproj\.user$ +^drivers$ diff --git a/drivers/windows/.Rbuildignore b/drivers/windows/.Rbuildignore new file mode 100644 index 00000000..1212a326 --- /dev/null +++ b/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$ diff --git a/drivers/windows/.gitignore b/drivers/windows/.gitignore new file mode 100644 index 00000000..c1996e33 --- /dev/null +++ b/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 diff --git a/drivers/windows/.lintr b/drivers/windows/.lintr new file mode 100644 index 00000000..0c778269 --- /dev/null +++ b/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") diff --git a/drivers/windows/DESCRIPTION b/drivers/windows/DESCRIPTION new file mode 100644 index 00000000..52eb5bd4 --- /dev/null +++ b/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 = "rich.fitzjohn@gmail.com"), + 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 diff --git a/drivers/windows/LICENSE b/drivers/windows/LICENSE new file mode 100644 index 00000000..1e61d491 --- /dev/null +++ b/drivers/windows/LICENSE @@ -0,0 +1,2 @@ +YEAR: 2021 +COPYRIGHT HOLDER: Imperial College of Science, Technology and Medicine diff --git a/drivers/windows/Makefile b/drivers/windows/Makefile new file mode 100644 index 00000000..ce34dcf8 --- /dev/null +++ b/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 diff --git a/drivers/windows/NAMESPACE b/drivers/windows/NAMESPACE new file mode 100644 index 00000000..be0a98b2 --- /dev/null +++ b/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) diff --git a/drivers/windows/R/base64.R b/drivers/windows/R/base64.R new file mode 100644 index 00000000..4e1efa0f --- /dev/null +++ b/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)) +} diff --git a/drivers/windows/R/batch.R b/drivers/windows/R/batch.R new file mode 100644 index 00000000..619bf4a1 --- /dev/null +++ b/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) +} diff --git a/drivers/windows/R/cluster.R b/drivers/windows/R/cluster.R new file mode 100644 index 00000000..bac08092 --- /dev/null +++ b/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() +} diff --git a/drivers/windows/R/config.R b/drivers/windows/R/config.R new file mode 100644 index 00000000..a6d91147 --- /dev/null +++ b/drivers/windows/R/config.R @@ -0,0 +1,31 @@ +make_configuration <- function(shares = NULL, r_version = NULL) { + path <- getwd() + config <- list( + cluster = "wpia-hn", + template = "AllNodes", + shares = dide_cluster_paths(shares, path), + r_version = select_r_version(r_version)) + config +} + + +select_r_version <- function(r_version, ours = getRversion()) { + if (is.null(r_version)) { + valid <- r_versions() + if (ours %in% valid) { + r_version <- numeric_version(ours) + } else { + i <- valid > ours + j <- if (any(i)) which(i)[[1L]] else length(valid) + r_version <- valid[[j]] + } + } else { + if (is.character(r_version)) { + r_version <- numeric_version(r_version) + } + if (!(r_version %in% r_versions())) { + stop("Unsupported R version: ", as.character(r_version)) + } + } + r_version +} diff --git a/drivers/windows/R/constants.R b/drivers/windows/R/constants.R new file mode 100644 index 00000000..e82e8ac2 --- /dev/null +++ b/drivers/windows/R/constants.R @@ -0,0 +1,4 @@ +# nolint start +BATCH_RUN <- "run.bat" +DIDE_ID <- "dide_id" +# nolint end diff --git a/drivers/windows/R/dide_auth.R b/drivers/windows/R/dide_auth.R new file mode 100644 index 00000000..3074379d --- /dev/null +++ b/drivers/windows/R/dide_auth.R @@ -0,0 +1,98 @@ +##' Deal with DIDE credentials +##' +##' @title DIDE credentials +##' @export +dide_authenticate <- function() { + if (keyring::keyring_is_locked()) { + keyring::keyring_unlock() + } + + cli::cli_h1("Please enter your DIDE credentials") + cli::cli_text(paste( + "We need to know your DIDE username and password in order to log you", + "into the cluster. This will be shared across all projects on this", + "machine, with the username and password stored securely in your system", + "keychain. You will have to run this command again on other computers")) + cli::cli_text() + cli::cli_text(paste( + "Your DIDE password may differ from your Imperial password, and in some", + "cases your username may also differ. If in doubt, perhaps try logging in", + "at https://mrcdata.dide.ic.ac.uk/hpc and use the combination that", + "works for you there.")) + cli::cli_text() + + username <- check_username( + readline_with_default("DIDE username", dide_guess_username())) + keyring::key_set("hermod/dide/password", username = username) + password <- keyring::key_get("hermod/dide/password", username = username) + + cli::cli_text() + cli::cli_text(paste( + "I am going to try and log in with your password now, if this fails we", + "can always try again, as failure is just the first step towards great", + "success.")) + + result <- tryCatch(api_client_login(username, password), error = identity) + + if (inherits(result, "error")) { + keyring::key_delete("hermod/dide/password", username = username) + cli::cli_abort(c( + "That username/password combination did not work, I'm afraid", + x = result$message, + i = "Please try again with 'dide_authenticate()'")) + } + keyring::key_set_with_value("hermod/dide/username", password = username) + invisible(credentials(username, password)) +} + + +##' @rdname dide_authenticate +##' @export +dide_credentials <- function() { + tryCatch({ + username <- keyring::key_get("hermod/dide/username") + password <- keyring::key_get("hermod/dide/password", username = username) + credentials(username, password) + }, error = function(e) { + cli::cli_abort( + "Did not find your DIDE credentials, please run 'dide_authenticate()'") + }) +} + + +dide_guess_username <- function() { + if ("hermod/dide/username" %in% keyring::key_list()$service) { + keyring::key_get("hermod/dide/username") + } else { + get_system_username() + } +} + + +credentials <- function(username, password) { + list(username = username, + password = structure(password, class = "password")) +} + + +##' @export +as.character.password <- function(x, ...) { + "*******************" +} + + +##' @export +print.password <- function(x, ...) { + print("*******************") + invisible(x) +} + + +check_username <- function(username) { + assert_scalar_character(username) + username <- sub("^DIDE\\\\", "", username) + if (username == "") { + stop("Invalid empty username") + } + username +} diff --git a/drivers/windows/R/mounts.R b/drivers/windows/R/mounts.R new file mode 100644 index 00000000..4e3a1786 --- /dev/null +++ b/drivers/windows/R/mounts.R @@ -0,0 +1,190 @@ +dide_cluster_paths <- function(shares, path_root) { + path_root <- clean_path_local(path_root) + shares <- dide_check_shares(shares) + shares <- dide_add_extra_root_share(shares, path_root) + + for (i in seq_along(shares)) { + shares[[i]]$path_remote <- use_app_on_nas_south_ken(shares[[i]]$path_remote) + } + + shares +} + + +detect_mounts <- function() { + if (is_windows()) { + detect_mounts_windows() + } else { + detect_mounts_unix() + } +} + + +detect_mounts_windows <- function() { + windir <- Sys.getenv("WINDIR", "C:\\Windows") + methods <- c("csv", + paste0(windir, "\\System32\\wbem\\en-US\\csv"), + paste0(windir, "\\System32\\wbem\\en-GB\\csv")) + + for (meth in methods) { + res <- wmic_call(meth) + if (res$success) { + return(res$result) + } + } + + stop("Could not determine windows mounts using wmic\n", res$result) +} + + +## TODO: No idea what spaces in the filenames will do here. Nothing +## pretty, that's for sure. +detect_mounts_unix <- function() { + mount <- sys_which("mount") + type <- if (Sys.info()[["sysname"]] == "Darwin") "smbfs" else "cifs" + + re <- paste( + "//(?[^@]*@)?(?[^/]*)/(?.*?)\\s+on\\s+(?.+?)", + "(?.+)$") + dat <- system2(mount, c("-t", type), stdout = TRUE, stderr = FALSE) + + i <- grepl(re, dat, perl = TRUE) + if (!all(i)) { + ## This will be useful to see if the above regex becomes wrong + warning("Ignoring mounts:\n", paste(dat[!i], collapse = "\n"), + immediate. = TRUE) + } + dat <- dat[i] + + if (length(dat) == 0L) { + return(cbind(remote = character(), local = character())) + } + + ## There are a couple of formats here. On the VPN and with OSX + ## (currently correlated) I see a //username@host/path format while + ## on on the wired network and Linux I see //shorthost/path + ## + ## //(user@)?(host)(.dide.ic.ac.uk)?/(path) + m <- rematch::re_match(re, dat)[, c("host", "path", "local"), drop = FALSE] + + host <- sub("\\.dide\\.ic\\.ac\\.uk$", "", m[, "host"]) + remote <- sprintf("\\\\%s\\%s", host, gsub("/", "\\\\", m[, "path"])) + cbind(remote = remote, + local = clean_path_local(m[, "local"])) +} + + +## Windows support: +wmic_call <- function(formatstr) { + ## ordinarily we'd use system2 but that writes a string that can't + ## be parsed under Rgui due to odd encoding. + ## https://stackoverflow.com/q/61067574 + ## Using system() does not seem to suffer the same problem + cmd <- sprintf('wmic netuse list brief /format:"%s"', formatstr) + res <- tryCatch( + list(success = TRUE, + result = wmic_parse(system_intern_check(cmd))), + error = function(e) list(success = FALSE, result = e$message)) +} + + +wmic_parse <- function(x) { + tmp <- tempfile() + writeLines(x, tmp) + on.exit(unlink(tmp)) + dat <- utils::read.csv(tmp, stringsAsFactors = FALSE) + expected <- c("RemoteName", "LocalName") + msg <- setdiff(expected, names(dat)) + if (length(msg) > 0) { + stop("Failed to find expected names in wmic output: ", + paste(msg, collapse = ", ")) + } + cbind(remote = dat$RemoteName, local = dat$LocalName) +} + + +use_app_on_nas_south_ken <- function(path_remote) { + # Similar to the above, but for the new South Ken + # cluster, wpia-hn.hpc + if (!(grepl("^[/\\\\]{2}wpia-hn-app", path_remote))) { + path_remote <- sub("^([/\\\\]{2}wpia-hn)\\b", "\\1-app", path_remote) + } + + re <- paste("^([/\\\\]{2}wpia-hn-app)\\.hpc\\.dide\\.ic\\.ac\\.uk|", + "\\.hpc\\.dide\\.local\\b") + path_remote <- sub(re, "\\1.hpc.dide.local", path_remote) + + path_remote <- gsub("wpia-hn-app.dide.local", "wpia-hn-app.hpc.dide.local", + path_remote) + + path_remote +} + + +dide_check_shares <- function(shares) { + if (length(shares) == 0) { + return(NULL) + } + if (inherits(shares, "path_mapping")) { + shares <- list(shares) + } + if (!is.list(shares)) { + stop("Invalid input for 'shares'") + } + if (!all(vlapply(shares, inherits, "path_mapping"))) { + stop("All elements of 'shares' must be a path_mapping") + } + + remote <- vcapply(shares, "[[", "drive_remote", USE.NAMES = FALSE) + dups <- unique(remote[duplicated(remote)]) + if (length(dups) > 0L) { + stop("Duplicate remote drive names: ", paste(dups, collapse = ", ")) + } + + unname(shares) +} + + +dide_add_extra_root_share <- function(shares, path_root, + mounts = detect_mounts()) { + mapped <- vcapply(shares, "[[", "path_local") + if (any(vlapply(mapped, fs::path_has_parent, path = path_root))) { + ## Our local directory is already on a given share + return(shares) + } + + ## We did not find the local directory on a mapped share, look in the mounts + i <- vlapply(mounts[, "local"], fs::path_has_parent, path = path_root) + + if (sum(i) > 1L) { + cli::cli_abort(c( + "Having trouble determining the working root directory mount point", + i = "You have two plausible mounts, how have you done this?")) + } else if (sum(i) == 0) { + cli::cli_abort( + c("Can't map local directory '{path_root}' to network path", + i = paste("You need to work with your hermod root on a network", + "share (and your working directory within that root),", + "but I can't work out the network path for this", + "myself. Most likely your working directory is on your", + "local computer only. Please see the package docs for", + "more information."))) + } + drive <- available_drive(shares, mounts[i, "local"]) + c(shares, + list(path_mapping("root", mounts[i, "local"], mounts[i, "remote"], drive))) +} + + +## If we're mounting some local drive (not home/temp) then on windows +## we'll reflect the local drive letter. Otherwise on linux/mac we'll +## pick from a late letter. +available_drive <- function(shares, local_mount, prefer = NULL) { + if (grepl("^[A-Za-z]:", local_mount)) { + local_mount + } else { + used <- toupper(substr(vcapply(shares, "[[", "drive_remote"), 1, 1)) + pos <- c(prefer, LETTERS[22:26]) + paste0(setdiff(pos, used)[[1L]], ":") + } +} diff --git a/drivers/windows/R/paths.R b/drivers/windows/R/paths.R new file mode 100644 index 00000000..a38f07a7 --- /dev/null +++ b/drivers/windows/R/paths.R @@ -0,0 +1,140 @@ +##' Describe a path mapping for use when setting up jobs on the cluster. +##' @title Describe a path mapping +##' +##' @param name Name of this map. Can be anything at all, and is used +##' for information purposes only. +##' +##' @param path_local The point where the drive is attached locally. +##' On Windows this will be something like "Q:/", on Mac something +##' like "/Volumes/mountname", and on Linux it could be anything at +##' all, depending on what you used when you mounted it (or what is +##' written in `/etc/fstab`) +##' +##' @param path_remote The network path for this drive. It +##' will look something like `\\\\fi--didef3.dide.ic.ac.uk\\tmp\\`. +##' Unfortunately backslashes are really hard to get right here and +##' you will need to use twice as many as you expect (so *four* +##' backslashes at the beginning and then two for each separator). +##' If this makes you feel bad know that you are not alone: +##' https://xkcd.com/1638 -- alternatively you may use forward +##' slashes in place of backslashes (e.g. `//fi--didef3.dide.ic.ac.uk/tmp`) +##' +##' @param drive_remote The place to mount the drive on the cluster. +##' We're probably going to mount things at Q: and T: already so +##' don't use those. And things like C: are likely to be used. +##' Perhaps there are some guidelines for this somewhere? +##' +##' @export +##' @author Rich FitzJohn +path_mapping <- function(name, path_local, path_remote, drive_remote) { + assert_scalar_character(name) + assert_scalar_character(path_local) + assert_scalar_character(path_remote) + assert_scalar_character(drive_remote) + + if (!grepl("^[A-Za-z]:$", drive_remote)) { + stop(sprintf("drive_remote must be of the form 'X:' (but was '%s')", + drive_remote)) + } + + if (grepl("^[A-Za-z]:$", path_local)) { + path_local <- paste0(path_local, "/") + } + + path_remote <- clean_path_remote(path_remote) + if (!grepl("^\\\\\\\\(.*)$", path_remote)) { + stop("path_remote must be a network path, starting with // or \\\\\\\\") + } + + if (!file.exists(path_local)) { + stop("Local mount point does not exist: ", path_local) + } + + ret <- list( + name = name, + path_remote = path_remote, + path_local = clean_path_local(path_local), + drive_remote = drive_remote) + class(ret) <- "path_mapping" + + ret +} + + +##' @export +as.character.path_mapping <- function(x, ...) { + if (is.null(x$rel)) { + sprintf("(local) %s => %s => %s (remote)", + x$path_local, x$path_remote, x$drive_remote) + } else { + sprintf("[rel: %s] (local) %s => %s => %s (remote)", + x$rel, x$path_local, x$path_remote, x$drive_remote) + } +} + + +##' @export +print.path_mapping <- function(x, ...) { + cat(paste0(": ", as.character(x), "\n")) + invisible(x) +} + + +remote_path <- function(x, shares) { + x <- prepare_path(x, shares) + windows_path(file.path(x$path_remote, x$rel, fsep = "/")) +} + + +clean_path_local <- function(path) { + clean_path(normalize_path(path)) +} + + +clean_path_remote <- function(path) { + ## Make FQDN + bits <- strsplit(clean_path(path), "/")[[1]] + + ## Catch varieties of wpia-hn, as we need to add .hpc in domain + wpia_hn <- c("wpia-hn", "wpia-hn.dide.ic.ac.uk", "wpia-hn.dide.local") + if (bits[3] %in% wpia_hn) { + bits[3] <- "wpia-hn.hpc" + } + + ## This contains... empty, empty, server-name, share, dir ... + ## So server_name should always be index 3. + ## Remove .dide.local if we find it. + + if (grepl(".dide.local", bits[3], ignore.case = TRUE)) { + bits[3] <- sub(".dide.local", "", bits[3], ignore.case = TRUE) + } + + ## Add .dide.ic.ac.uk if it's not there. + if (!grepl(".dide.ic.ac.uk", bits[3], ignore.case = TRUE)) { + bits[3] <- paste0(bits[3], ".dide.ic.ac.uk") + } + + ## re_assemble + paste0(bits, collapse = "\\") +} + + +## TODO: This is a terrible name. +## +## This path converts a local path into a network path mapping +prepare_path <- function(path, mappings, error = TRUE) { + if (!file.exists(path)) { + stop("path does not exist: ", path) + } + for (m in mappings) { + if (fs::path_has_parent(path, m$path_local)) { + m$rel <- as.character(fs::path_rel(path, m$path_local)) + return(m) + } + } + if (error) { + cli::cli_abort("did not find network mapping for path '{path}'") + } else { + NULL + } +} diff --git a/drivers/windows/R/util.R b/drivers/windows/R/util.R new file mode 100644 index 00000000..14aacf70 --- /dev/null +++ b/drivers/windows/R/util.R @@ -0,0 +1,132 @@ +`%||%` <- function(x, y) { # nolint + if (is.null(x)) y else x +} + + +set_names <- function(x, nms) { + names(x) <- nms + x +} + + +read_lines <- function(...) { + paste(readLines(...), collapse = "\n") +} + + +from_json <- function(x, ...) { + jsonlite::fromJSON(x, simplifyDataFrame = FALSE, simplifyMatrix = FALSE, ...) +} + + +vcapply <- function(X, FUN, ...) { # nolint + vapply(X, FUN, character(1), ...) +} + + +vlapply <- function(X, FUN, ...) { # nolint + vapply(X, FUN, logical(1), ...) +} + + +httr_text <- function(r) { + httr::content(r, as = "text", encoding = "UTF-8") +} + + +squote <- function(x) { + sprintf("'%s'", x) +} + + +is_windows <- function() { + Sys.info()[["sysname"]] == "Windows" +} + + +sys_which <- function(name) { + ret <- Sys.which(name) + if (ret == "") { + stop(sprintf("%s not found in $PATH", name)) + } + ret +} + + +system_intern_check <- function(...) { + res <- suppressWarnings(system(..., intern = TRUE)) + status <- attr(res, "status", exact = TRUE) + if (!is.null(status) && status > 0) { + stop("Error running command") + } + res +} + + +glue_whisker <- function(template, data) { + transformer <- function(...) { + ## This transformer prevents a NULL entry destroying the string + glue::identity_transformer(...) %||% "" + } + glue::glue(template, .envir = data, .open = "{{", .close = "}}", + .trim = FALSE, .transformer = transformer) +} + + +hostname <- function() { + Sys.info()[["nodename"]] +} + + +hermod_windows_file <- function(path) { + system.file(path, mustWork = TRUE, package = "hermod.windows") +} + + +hermod_version <- function() { + as.character(utils::packageVersion("hermod")) +} + + +normalize_path <- function(path) { + normalizePath(path, winslash = "/", mustWork = TRUE) +} + + +clean_path <- function(x) { + as.character(fs::path_tidy(x)) +} + + +windows_path <- function(x) { + gsub("/", "\\", x, fixed = TRUE) +} + + +get_system_username <- function() { + Sys.getenv(if (is_windows()) "USERNAME" else "USER", NA_character_) +} + + +readline_with_default <- function(prefix, default) { + if (is.na(default) || default == "") { + prompt <- sprintf("%s > ", prefix) + } else { + prompt <- sprintf("%s (default: %s) > ", prefix, default) + } + result <- readline(prompt) + if (result == "") { + if (is.na(default)) { + cli::cli_abort("A value must be provided") + } + result <- default + } + result +} + + +## This is really part of hermod, but until we decide on the +## interface, leaving it here. +path_tasks <- function(path_root) { + file.path(path_root, "hermod", "tasks") +} diff --git a/drivers/windows/R/util_assert.R b/drivers/windows/R/util_assert.R new file mode 100644 index 00000000..1075965d --- /dev/null +++ b/drivers/windows/R/util_assert.R @@ -0,0 +1,41 @@ +assert_scalar <- function(x, name = deparse(substitute(x))) { + if (length(x) != 1) { + stop(sprintf("'%s' must be a scalar", name), call. = FALSE) + } +} + + +assert_scalar_character <- function(x, name = deparse(substitute(x))) { + assert_scalar(x, name) + assert_character(x, name) +} + + +assert_character <- function(x, name = deparse(substitute(x))) { + if (!is.character(x)) { + stop(sprintf("'%s' must be a character", name), call. = FALSE) + } +} + + +assert_scalar_integer <- function(x, name = deparse(substitute(x))) { + assert_scalar(x, name) + assert_integer(x, name) +} + + +assert_integer <- function(x, name = deparse(substitute(x))) { + if (!(is.integer(x) || all(x - round(x) == 0))) { + stop(sprintf("'%s' must be an integer", name), call. = FALSE) + } +} + + +match_value <- function(arg, choices, name = deparse(substitute(arg))) { + assert_scalar_character(arg) + if (!(arg %in% choices)) { + stop(sprintf("'%s' must be one of %s", + name, paste(squote(choices), collapse = ", "))) + } + arg +} diff --git a/drivers/windows/R/web.R b/drivers/windows/R/web.R new file mode 100644 index 00000000..c8d538ac --- /dev/null +++ b/drivers/windows/R/web.R @@ -0,0 +1,508 @@ +get_web_client <- function() { + if (is.null(cache$web_client)) { + cache$web_client <- web_client$new(dide_credentials(), login = FALSE) + } + cache$web_client +} + +web_client <- R6::R6Class( + "web_client", + cloneable = FALSE, + + public = list( + initialize = function(credentials, cluster_default = NULL, login = FALSE, + client = NULL) { + private$client <- client %||% api_client$new(credentials) + private$cluster <- cluster_name(cluster_default) + if (login) { + self$login() + } + }, + + login = function(refresh = TRUE) { + private$client$login(refresh = refresh) + }, + + logout = function() { + private$client$logout() + }, + + logged_in = function() { + private$client$logged_in() + }, + + check_access = function(cluster = NULL) { + client_check(cluster %||% private$cluster, self$headnodes()) + }, + + submit = function(path, name, template, cluster = NULL, + resource_type = "Cores", resource_count = 1, + depends_on = NULL) { + data <- client_body_submit( + path, name, template, cluster %||% private$cluster, + resource_type, resource_count, depends_on) + r <- private$client$POST("/submit_1.php", data) + client_parse_submit(httr_text(r), 1L) + }, + + cancel = function(dide_id, cluster = NULL) { + data <- client_body_cancel(dide_id, cluster %||% private$cluster) + r <- private$client$POST("/cancel.php", data) + client_parse_cancel(httr_text(r)) + }, + + log = function(dide_id, cluster = NULL) { + data <- client_body_log(dide_id, cluster %||% private$cluster) + r <- private$client$POST("/showjobfail.php", data) + client_parse_log(httr_text(r)) + }, + + status_user = function(state = "*", cluster = NULL) { + data <- client_body_status(state, private$client$username(), + cluster %||% private$cluster) + r <- private$client$POST("/_listalljobs.php", data) + client_parse_status(httr_text(r)) + }, + + status_job = function(dide_id, cluster = NULL) { + pars <- list(scheduler = cluster %||% private$cluster, + jobid = dide_id) + r <- private$client$GET("/api/v1/get_job_status/", query = pars) + status_map(httr_text(r)) + }, + + load_node = function(cluster = NULL) { + cluster <- cluster %||% private$cluster + data <- list(cluster = encode64(cluster %||% private$cluster), + hpcfunc = "shownodes", + cluster_no = as.character(match(cluster, valid_clusters()))) + r <- private$client$POST("/shownodes.php", data) + client_parse_load_cluster(httr_text(r), cluster) + }, + + load_overall = function() { + dat <- lapply(self$headnodes(), self$load_node) + client_parse_load_overall(dat) + }, + + load_show = function(cluster = NULL, nodes = TRUE) { + if (isTRUE(cluster)) { + print(self$load_overall()) + } else { + print(self$load_node(cluster %||% self$cluster), + nodes = nodes) + } + }, + + headnodes = function(forget = FALSE) { + if (forget || is.null(private$headnodes_)) { + data <- list(user = encode64("")) + r <- private$client$POST("/_listheadnodes.php", data) + private$headnodes_ <- client_parse_headnodes(httr_text(r)) + } + private$headnodes_ + }, + + r_versions = function() { + r <- private$client$GET("/api/v1/cluster_software/", public = TRUE) + client_parse_r_versions(httr_text(r)) + }, + + api_client = function() { + private$client + } + ), + + private = list( + client = NULL, + cluster = NULL, + headnodes_ = NULL + )) + +## This is code directly copied over from didehpc; we may want to +## change this pretty fundamentally in future, but because we'll also +## look at the portal itself over the next year or so, we'll pause on +## that now. This was imported from didehpc version 0.3.22 and works +## well in practice. +api_client <- R6::R6Class( + "api_client", + cloneable = FALSE, + + public = list( + initialize = function(credentials) { + private$credentials <- credentials + }, + + username = function() { + private$credentials$username + }, + + GET = function(path, ...) { + self$request(httr::GET, path, ...) + }, + + POST = function(path, body, ...) { + self$request(httr::POST, path, body = body, ..., + httr::accept("text/plain"), encode = "form") + }, + + request = function(verb, path, ..., public = FALSE) { + self$login(public) + url <- paste0(private$url, path) + r <- verb(url, ...) + status <- httr::status_code(r) + if (status %in% c(401, 403)) { + stop("Please login first") + } + httr::stop_for_status(r) + r + }, + + login = function(public = FALSE, refresh = FALSE) { + if (public && !refresh) { + return() + } + if (refresh || !private$has_logged_in) { + api_client_login(private$credentials$username, + private$credentials$password) + private$has_logged_in <- TRUE + } + }, + + logout = function() { + private$has_logged_in <- FALSE + self$GET("/logout.php", public = TRUE) + invisible() + }, + + logged_in = function() { + if (!private$has_logged_in) { + return(FALSE) + } + r <- self$POST("/_listheadnodes.php", list(user = encode64(""))) + httr::status_code(r) < 300 + } + ), + + private = list( + url = "https://mrcdata.dide.ic.ac.uk/hpc", + credentials = NULL, + has_logged_in = FALSE + )) + + +api_client_login <- function(username, password) { + data <- list(us = encode64(username), + pw = encode64(password), + hpcfunc = encode64("login")) + r <- httr::POST("https://mrcdata.dide.ic.ac.uk/hpc/index.php", + body = data, encode = "form") + httr::stop_for_status(r) + ## We get this where DIDE username/password ok but access is not + ## allowed + if (grepl("You don't seem to have any HPC access", httr_text(r))) { + stop("You do not have HPC access - please contact Wes") + } +} + + +client_body_submit <- function(path, name, template, cluster, + resource_type, resource_count, depends_on) { + ## TODO: this clearly used to allow batch submission of several jobs + ## at once, and we should consider re-allowing that. It looks like + ## the issue is we can't easily get the names sent as a vector? Or + ## is that allowed? + assert_scalar_character(path) + if (!grepl("^\\\\\\\\", path)) { + stop("All paths must be Windows network paths") + } + path_call <- paste("call", shQuote(path, "cmd")) + + name <- name %||% "" + assert_scalar_character(name) + + deps <- paste0(depends_on, collapse = ",") + + workdir <- "" + stderr <- "" + stdout <- "" + list( + cluster = encode64(cluster), + template = encode64(template), + rc = encode64(as.character(resource_count)), + rt = encode64(resource_type), + jn = encode64(name), + wd = encode64(workdir), + se = encode64(stderr), + so = encode64(stdout), + jobs = encode64(path_call), + dep = encode64(deps), + hpcfunc = "submit") +} + + +client_body_cancel <- function(dide_id, cluster) { + if (length(dide_id) == 0L) { + stop("Need at least one task to cancel") + } + jobs <- set_names(as.list(dide_id), paste0("c", dide_id)) + c(list(cluster = encode64(cluster), + hpcfunc = encode64("cancel")), + jobs) +} + + +client_body_log <- function(dide_id, cluster) { + assert_scalar_character(dide_id) + list(hpcfunc = "showfail", + cluster = encode64(cluster), + id = dide_id) +} + + +client_body_status <- function(state, username, cluster) { + valid <- c("*", "Running", "Finished", "Queued", "Failed", "Cancelled") + state <- match_value(state, valid) + list(user = encode64(username), + scheduler = encode64(cluster), + state = encode64(state), + jobs = encode64(as.character(-1))) +} + + +client_parse_status <- function(txt) { + cols <- c("dide_id", "name", "status", "resources", "user", + "time_start", "time_submit", "time_end", "template") + ## Id Name State Resources User StartTime SubmitTime EndTime JobTemplate + if (nzchar(txt)) { + res <- strsplit(strsplit(txt, "\n")[[1]], "\t") + len <- lengths(res) + if (any(len != length(cols))) { + stop("Parse error; unexpected output from server") + } + res <- as.data.frame(do.call(rbind, res), stringsAsFactors = FALSE) + } else { + res <- as.data.frame(matrix(character(0), 0, length(cols)), + stringsAsFactors = FALSE) + } + names(res) <- cols + + ## Some type switches: + res$dide_id <- res$dide_id + res$name <- trimws(res$name) + res$name[!nzchar(res$name)] <- NA_character_ + res$user <- sub("^DIDE\\\\", "", res$user) + res$status <- status_map(res$status) + res$time_start <- dide_time_parse(res$time_start) + res$time_end <- dide_time_parse(res$time_end) + res$time_submit <- dide_time_parse(res$time_submit) + res +} + + +client_parse_log <- function(txt) { + xml <- xml2::read_html(txt) + value <- xml2::xml_attr(xml2::xml_find_first(xml, '//input[@id="res"]'), + "value") + value <- trimws(sub("^Output\\s*:\\s*?\n+", "", decode64(value))) + strsplit(value, "\n")[[1]] +} + + +client_parse_r_versions <- function(txt) { + dat <- from_json(txt) + dat_r <- dat$software[vcapply(dat$software, "[[", "name") == "R"] + numeric_version(vcapply(dat_r, "[[", "version")) +} + + +client_parse_headnodes <- function(txt) { + dat <- strsplit(txt, "\n")[[1]] + stopifnot(all(grepl("^(fi--|wpia-)", dat))) + setdiff(dat, "fi--didelxhn") +} + + +client_parse_submit <- function(txt, n) { + txt <- strsplit(txt, "\n")[[1]] + re <- "^Job has been submitted. ID: +([0-9]+)\\.$" + i <- grepl(re, txt) + + extra <- txt[!i] + if (length(extra) > 0L) { + message("Discarding additional response from server:\n", + paste(extra, collapse = "\n")) + } + + nok <- sum(i) + if (nok > 0L) { + if (nok != n) { + ## Hopefully never triggers + stop("Unexpected response length from server") + } + sub(re, "\\1", txt[i]) + } else { + ## TODO: Detect this and hit login and try again? + stop("Job submission has likely failed; could be a login error") + } +} + + +client_parse_cancel <- function(txt) { + d <- strsplit(txt, "\n")[[1]] + d <- strsplit(d[nzchar(d)], "\t") + set_names(vcapply(d, "[[", 2L), vcapply(d, "[[", 1L)) +} + +client_parse_load_cluster <- function(txt, cluster) { + cluster <- tolower(cluster) + txt <- strsplit(txt, "\n", fixed = TRUE)[[1]] + re <- "^([^ ]+) +- +([0-9]+) +([^ ]+) *(.*)$" + d <- txt[-seq_len(2)] + d <- d[nzchar(d)] + node <- sub(re, "\\1", d) + core <- as.integer(sub(re, "\\2", d)) + 1L + status <- sub(re, "\\3", d) + rest <- sub(re, "\\4", d) + task_id <- rep(NA_character_, length(d)) + i <- nchar(rest) > 0L + task_id[i] <- sub("^([0-9]+).*", "\\1", rest[i]) + res <- data.frame(node = tolower(node), core = core, status = status, + dide_id = task_id, stringsAsFactors = FALSE) + res <- res[res$node != cluster, ] + res <- res[order(res$node), ] + free <- tapply(res$status == "Idle", res$node, sum) + total <- tapply(res$node, res$node, length) + used <- total - free + percent_used <- round(used / total * 100) + + summary <- data.frame(name = names(free), + free = unname(free), + used = unname(used), + total = unname(total), + percent_used = unname(percent_used), + stringsAsFactors = FALSE) + + overall <- list(name = cluster, + free = sum(free), + used = sum(total) - sum(free), + total = sum(total), + percent_used = round((1 - sum(free) / sum(total)) * 100)) + + ret <- list(cluster = cluster, + detail = res, + summary = summary, + overall = overall) + class(ret) <- "dide_clusterload" + ret +} + + +client_parse_load_overall <- function(dat) { + summary <- do.call("rbind", lapply(dat, function(x) { + as.data.frame(x$overall, stringsAsFactors = FALSE) + })) + overall <- list(name = "didehpc", + free = sum(summary$free), + used = sum(summary$used), + total = sum(summary$total)) + overall$percent_used <- round(100 * overall$used / overall$total) + ret <- list(cluster = "didehpc", + detail = NULL, + summary = summary, + overall = overall) + class(ret) <- "dide_clusterload" + ret +} + + +client_check <- function(cluster, valid) { + if (!(cluster %in% valid)) { + if (length(valid) == 0L) { + stop("You do not have access to any cluster") + } else if (length(valid) == 1L) { + stop(sprintf("You do not have access to '%s'; try '%s'", cluster, valid)) + } else { + stop(sprintf("You do not have access to '%s'; try one of %s", + cluster, paste(squote(valid), collapse = ", "))) + } + } +} + + +status_map <- function(x) { + map <- c(Running = "RUNNING", + Finished = "COMPLETE", + Queued = "PENDING", + Failed = "ERROR", + Canceled = "CANCELLED", + Cancelled = "CANCELLED") + ret <- unname(map[x]) + ret[is.na(ret)] <- "MISSING" + ret +} + + +dide_time_parse <- function(x) { + ## YYYYMMDDHHMMSS + ## 20151109170805 + as.POSIXct(strptime(x, "%Y%m%d%H%M%S")) +} + + +##' @export +format.dide_clusterload <- function(x, ..., nodes = TRUE) { + f <- function(name) { + vals <- c(x$overall[[name]], x$summary[[name]]) + if (name == "percent_used") { + name <- "% used" + vals <- paste0(vals, "%") + } + format(c(name, vals), justify = "right") + } + m <- cbind(f("name"), f("free"), f("used"), f("total"), f("percent_used")) + + ## Header: + mh <- vcapply(m[1, ], crayon::bold) + + ## Divider: + md <- vcapply(nchar(m[1, ]), strrep, x = "-") + + ## Summary + if (nodes) { + ms <- m[-seq_len(2), , drop = FALSE] + col <- cluster_load_cols(x$summary$used / x$summary$total) + ms[, 1] <- crayon::blue(ms[, 1]) + ms[, -1] <- t(vapply(seq_along(col), + function(i) crayon::make_style(col[[i]])(ms[i, -1]), + character(ncol(m) - 1L))) + ms <- rbind(ms, md, deparse.level = 0) + } else { + ms <- NULL + } + + ## Overall + mo <- m[2, ] + col <- cluster_load_cols(x$overall$used / x$overall$total) + mo[1] <- crayon::make_style("blue")$bold(mo[1]) + mo[-1] <- vcapply(mo[-1], crayon::make_style(col)$bold) + + mm <- rbind(mh, md, ms, mo, deparse.level = 0) + + apply(mm, 1, paste, collapse = " ") +} + + +##' @export +print.dide_clusterload <- function(x, ...) { + cat(paste0(format(x, ...), "\n", collapse = "")) + invisible(x) +} + + +cluster_load_cols <- function(p, max = 1) { + cols <- c("#FED976", "#FEB24C", "#FD8D3C", "#FC4E2A", "#E31A1C", "#B10026") + p[is.nan(p)] <- 0 + ret <- grDevices::colorRamp(cols)(p / max) + grDevices::rgb(ret[, 1], ret[, 2], ret[, 3], maxColorValue = 255) +} diff --git a/drivers/windows/R/zzz.R b/drivers/windows/R/zzz.R new file mode 100644 index 00000000..a3c67299 --- /dev/null +++ b/drivers/windows/R/zzz.R @@ -0,0 +1 @@ +cache <- new.env(parent = emptyenv()) diff --git a/drivers/windows/README.md b/drivers/windows/README.md new file mode 100644 index 00000000..15f899e3 --- /dev/null +++ b/drivers/windows/README.md @@ -0,0 +1,35 @@ +# hermod.windows + + +[![Project Status: Concept – Minimal or no implementation has been done yet, or the repository is only intended to be a limited example, demo, or proof-of-concept.](https://www.repostatus.org/badges/latest/concept.svg)](https://www.repostatus.org/#concept) +[![R build status](https://github.com/mrc-ide/hermod.windows/workflows/R-CMD-check/badge.svg)](https://github.com/mrc-ide/hermod.windows/actions) +[![Build status]()](https://buildkite.com/mrc-ide/mrcide/hermod-dot-windows?branch=main) +[![codecov.io](https://codecov.io/github/mrc-ide/hermod.windows/coverage.svg?branch=main)](https://codecov.io/github/mrc-ide/hermod.windows?branch=main) + + +## Installation + +To install `hermod.windows`: + +```r +remotes::install_github("mrc-ide/hermod.windows", upgrade = FALSE) +``` + + +## Usage + +On a network share + +``` +hermod::hermod_init(".") +hermod::hermod_configure("windows", r_version = "4.3.1") + +hermod::hermod_task_create_explicit(quote(sessionInfo()), submit = "windows") + +id <- hermod::hermod_task_create_explicit(quote(sessionInfo())) +hermod::hermod_task_submit(id, "windows") +``` + +## License + +MIT © Imperial College of Science, Technology and Medicine diff --git a/drivers/windows/inst/templates/task_run.bat b/drivers/windows/inst/templates/task_run.bat new file mode 100644 index 00000000..812e4d10 --- /dev/null +++ b/drivers/windows/inst/templates/task_run.bat @@ -0,0 +1,42 @@ +@echo off +REM automatically generated +ECHO generated on host: {{hostname}} +ECHO generated on date: {{date}} +ECHO hermod version: {{hermod_version}} +ECHO running on: %COMPUTERNAME% + +REM variables that get pulled in here +REM * hermod_drive - the drive alone (e.g., Q:) +REM * hermod_root - the absolute path incl. drive to folder with hermod/ +REM * hermod_workdir - the absolute path on drive to working directory + +call setr64_{{r_version}}.bat + +{{network_shares_create}} + +{{hermod_workdir_drive}} +cd {{hermod_workdir_path}} +ECHO working directory: %CD% + +set R_LIBS_USER=\\fi--didef3.dide.ic.ac.uk\tmp\hermod-testing + +ECHO this is a single task + +@REM The quoting here is necessary for paths with spaces. +ECHO on +Rscript -e "hermod::hermod_task_eval('{{hermod_task_id}}')" > "{{hermod_path_root_abs}}\hermod\tasks\{{hermod_task_id}}\log" 2>&1 + +@ECHO off +%SystemDrive% +set ErrorCode=%ERRORLEVEL% + +{{network_shares_delete}} + +set ERRORLEVEL=%ErrorCode% + +if %ERRORLEVEL% neq 0 ( + ECHO Error running task + EXIT /b %ERRORLEVEL% +) + +@ECHO Quitting diff --git a/drivers/windows/man/dide_authenticate.Rd b/drivers/windows/man/dide_authenticate.Rd new file mode 100644 index 00000000..04010fe3 --- /dev/null +++ b/drivers/windows/man/dide_authenticate.Rd @@ -0,0 +1,14 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/dide_auth.R +\name{dide_authenticate} +\alias{dide_authenticate} +\alias{dide_credentials} +\title{DIDE credentials} +\usage{ +dide_authenticate() + +dide_credentials() +} +\description{ +Deal with DIDE credentials +} diff --git a/drivers/windows/man/path_mapping.Rd b/drivers/windows/man/path_mapping.Rd new file mode 100644 index 00000000..9b53f16d --- /dev/null +++ b/drivers/windows/man/path_mapping.Rd @@ -0,0 +1,38 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/paths.R +\name{path_mapping} +\alias{path_mapping} +\title{Describe a path mapping} +\usage{ +path_mapping(name, path_local, path_remote, drive_remote) +} +\arguments{ +\item{name}{Name of this map. Can be anything at all, and is used +for information purposes only.} + +\item{path_local}{The point where the drive is attached locally. +On Windows this will be something like "Q:/", on Mac something +like "/Volumes/mountname", and on Linux it could be anything at +all, depending on what you used when you mounted it (or what is +written in \verb{/etc/fstab})} + +\item{path_remote}{The network path for this drive. It +will look something like \verb{\\\\\\\\fi--didef3.dide.ic.ac.uk\\\\tmp\\\\}. +Unfortunately backslashes are really hard to get right here and +you will need to use twice as many as you expect (so \emph{four} +backslashes at the beginning and then two for each separator). +If this makes you feel bad know that you are not alone: +https://xkcd.com/1638 -- alternatively you may use forward +slashes in place of backslashes (e.g. \verb{//fi--didef3.dide.ic.ac.uk/tmp})} + +\item{drive_remote}{The place to mount the drive on the cluster. +We're probably going to mount things at Q: and T: already so +don't use those. And things like C: are likely to be used. +Perhaps there are some guidelines for this somewhere?} +} +\description{ +Describe a path mapping for use when setting up jobs on the cluster. +} +\author{ +Rich FitzJohn +} diff --git a/drivers/windows/tests/testthat.R b/drivers/windows/tests/testthat.R new file mode 100644 index 00000000..ec2dba42 --- /dev/null +++ b/drivers/windows/tests/testthat.R @@ -0,0 +1,4 @@ +library(testthat) +library(hermod.windows) + +test_check("hermod.windows") diff --git a/drivers/windows/tests/testthat/helper-config.R b/drivers/windows/tests/testthat/helper-config.R new file mode 100644 index 00000000..09bf26f1 --- /dev/null +++ b/drivers/windows/tests/testthat/helper-config.R @@ -0,0 +1,21 @@ +example_root <- function(mount_path, sub = "b/c") { + fs::dir_create(mount_path) + path <- file.path(mount_path, sub) + root <- suppressMessages(hermod::hermod_init(path)) + path <- normalize_path(path) + shares <- path_mapping("home", mount_path, "//host/share/path", "X:") + config <- hermod::hermod_configure("windows", shares = shares, root = root) + root +} + + +example_mounts <- function(root) { + remote <- c("\\\\fi--didef3\\other", + "\\\\fi--san03\\homes\\bob", + "\\\\fi--didenas1\\Project", + "\\\\fi--didef3\\tmp", + "\\\\wpia-hn\\newshare") + local <- file.path(root, c("other", "home", "proj", "temp", "sk")) + fs::dir_create(file.path(local, "sub")) + cbind(remote = remote, local = local) +} diff --git a/drivers/windows/tests/testthat/helper-hermod.R b/drivers/windows/tests/testthat/helper-hermod.R new file mode 100644 index 00000000..f85380ef --- /dev/null +++ b/drivers/windows/tests/testthat/helper-hermod.R @@ -0,0 +1,2 @@ +## Ensures that tests work if offline +cache$r_versions <- numeric_version(c("4.0.5", "4.1.3", "4.2.3", "4.3.0")) diff --git a/drivers/windows/tests/testthat/helper-web.R b/drivers/windows/tests/testthat/helper-web.R new file mode 100644 index 00000000..4887d5df --- /dev/null +++ b/drivers/windows/tests/testthat/helper-web.R @@ -0,0 +1,22 @@ +example_credentials <- function() { + credentials("bob", "secret") +} + + +mock_response <- function(code, ..., url = NULL, content = NULL) { + dat <- list(status_code = code, + url = url %||% "http://example.com/", + ...) + if (is.character(content)) { + dat$content <- charToRaw(paste(content, collapse = "\n")) + } else { + dat$content <- content + } + class(dat) <- "response" + dat +} + + +r6_private <- function(x) { + x[[".__enclos_env__"]]$private +} diff --git a/drivers/windows/tests/testthat/responses/load.rds b/drivers/windows/tests/testthat/responses/load.rds new file mode 100644 index 0000000000000000000000000000000000000000..06c1e3d261789ea1f0d9ab667930707aa5fc9874 GIT binary patch literal 1073 zcmV-11kU>(iwFP!000001MS=Qd)q`9z;VTK;*?Vuw-Wz`Be*nHG>+(3N^2B=bw3V=w=aYN&`f@!-*6E(h zb;(pkQDRD*uUIo-^A>!IqXSJuQz&N^id|j#VqVMXm9n+ma8>)svsyA0(sWNq)9H|= zGa*g)hBVz5()8?brc=pqrhB|^*TznJ4+X(bdk+PTo%SAPf}i#tW`dvY4{16Z&UD&) zSPy>Mds-g+wD+{UvD4m<(MC&;3>VeWd^!`QqjVkV-Y6ZV$EFo!x+2!w#L}Etwo??b zW+&F+TF{CF+M?I(U!PdooQC!Qwioo*{l4GH))$}a8JMY5*OWKI<`C=5TVfWr!q({A z2KL6tKnP`;qqtC}&$&_(x*;1`aS>AbKDRi)y zceOahERA%_R_k3L6+bwc1)^=REw;n<*a16YC+v(}uq$@M?$`r+VlV8CeXuX~!~W<( zHx57&DfA!>G1Q2~-#*MnKg6?k4i3aYI2ecEPz+!$4#PYgjw5g+j>6HHk7IBwj>GXd z0Sj;Jq{43FapJc+09G}hu7Jd5Y>JYK+ycnL4# z6}*bq@H*bWn|KRv;~l(<_wYVGz=!wTet>zn3 ziN6(lB#G6IB;)@l1^Y+EJYZc-JiR6sSIN`TO3hSteVkujhdnoP+S5y_{m=dfuQ{FR-Z20Gyb~f9 literal 0 HcmV?d00001 diff --git a/drivers/windows/tests/testthat/responses/load.txt b/drivers/windows/tests/testthat/responses/load.txt new file mode 100644 index 00000000..4599e024 --- /dev/null +++ b/drivers/windows/tests/testthat/responses/load.txt @@ -0,0 +1,228 @@ +Node Processor State Job ID Task ID CommandLine +-------------------- ---------------- -------- -------- ---------------------- +FI--DIDECLUST01 - 0 Idle +FI--DIDECLUST01 - 1 Idle +FI--DIDECLUST01 - 2 Idle +FI--DIDECLUST01 - 3 Idle +FI--DIDECLUST01 - 4 Idle +FI--DIDECLUST01 - 5 Idle +FI--DIDECLUST01 - 6 Idle +FI--DIDECLUST01 - 7 Idle +FI--DIDECLUST02 - 0 Idle +FI--DIDECLUST02 - 1 Idle +FI--DIDECLUST02 - 2 Idle +FI--DIDECLUST02 - 3 Idle +FI--DIDECLUST02 - 4 Idle +FI--DIDECLUST02 - 5 Idle +FI--DIDECLUST02 - 6 Idle +FI--DIDECLUST02 - 7 Idle +FI--DIDECLUST03 - 0 Idle +FI--DIDECLUST03 - 1 Idle +FI--DIDECLUST03 - 2 Idle +FI--DIDECLUST03 - 3 Idle +FI--DIDECLUST03 - 4 Idle +FI--DIDECLUST03 - 5 TaskRunning 3489804 1 call \\fi--san03.dide. +FI--DIDECLUST03 - 6 Idle +FI--DIDECLUST03 - 7 TaskRunning 3490619 1 call \\fi--san03.dide. +FI--DIDECLUST04 - 0 Idle +FI--DIDECLUST04 - 1 Idle +FI--DIDECLUST04 - 2 Idle +FI--DIDECLUST04 - 3 Idle +FI--DIDECLUST04 - 4 Idle +FI--DIDECLUST04 - 5 Idle +FI--DIDECLUST04 - 6 Idle +FI--DIDECLUST04 - 7 Idle +FI--DIDECLUST05 - 0 Offline +FI--DIDECLUST05 - 1 Offline +FI--DIDECLUST05 - 2 Offline +FI--DIDECLUST05 - 3 Offline +FI--DIDECLUST05 - 4 Offline +FI--DIDECLUST05 - 5 Offline +FI--DIDECLUST05 - 6 Offline +FI--DIDECLUST05 - 7 Offline +FI--DIDECLUST06 - 0 Idle +FI--DIDECLUST06 - 1 Idle +FI--DIDECLUST06 - 2 Idle +FI--DIDECLUST06 - 3 Idle +FI--DIDECLUST06 - 4 Idle +FI--DIDECLUST06 - 5 Idle +FI--DIDECLUST06 - 6 Idle +FI--DIDECLUST06 - 7 Idle +FI--DIDECLUST07 - 0 Idle +FI--DIDECLUST07 - 1 Idle +FI--DIDECLUST07 - 2 Idle +FI--DIDECLUST07 - 3 Idle +FI--DIDECLUST07 - 4 Idle +FI--DIDECLUST07 - 5 Idle +FI--DIDECLUST07 - 6 Idle +FI--DIDECLUST07 - 7 Idle +FI--DIDECLUST10 - 0 Idle +FI--DIDECLUST10 - 1 Idle +FI--DIDECLUST10 - 2 Idle +FI--DIDECLUST10 - 3 Idle +FI--DIDECLUST10 - 4 Idle +FI--DIDECLUST10 - 5 Idle +FI--DIDECLUST10 - 6 Idle +FI--DIDECLUST10 - 7 Idle +FI--DIDECLUST23 - 0 Idle +FI--DIDECLUST23 - 1 Idle +FI--DIDECLUST23 - 2 Idle +FI--DIDECLUST23 - 3 Idle +FI--DIDECLUST23 - 4 Idle +FI--DIDECLUST23 - 5 Idle +FI--DIDECLUST23 - 6 Idle +FI--DIDECLUST23 - 7 Idle +FI--DIDECLUST23 - 8 Idle +FI--DIDECLUST23 - 9 Idle +FI--DIDECLUST23 - 10 Idle +FI--DIDECLUST23 - 11 Idle +FI--DIDECLUST24 - 0 Idle +FI--DIDECLUST24 - 1 Idle +FI--DIDECLUST24 - 2 Idle +FI--DIDECLUST24 - 3 Idle +FI--DIDECLUST24 - 4 Idle +FI--DIDECLUST24 - 5 Idle +FI--DIDECLUST24 - 6 Idle +FI--DIDECLUST24 - 7 Idle +FI--DIDECLUST25 - 0 Idle +FI--DIDECLUST25 - 1 Idle +FI--DIDECLUST25 - 2 Idle +FI--DIDECLUST25 - 3 Idle +FI--DIDECLUST25 - 4 Idle +FI--DIDECLUST25 - 5 Idle +FI--DIDECLUST25 - 6 Idle +FI--DIDECLUST25 - 7 Idle +FI--DIDECLUST25 - 8 Idle +FI--DIDECLUST25 - 9 Idle +FI--DIDECLUST25 - 10 Idle +FI--DIDECLUST25 - 11 Idle +FI--DIDECLUST26 - 0 Idle +FI--DIDECLUST26 - 1 Idle +FI--DIDECLUST26 - 2 Idle +FI--DIDECLUST26 - 3 Idle +FI--DIDECLUST26 - 4 Idle +FI--DIDECLUST26 - 5 Idle +FI--DIDECLUST26 - 6 Idle +FI--DIDECLUST26 - 7 Idle +FI--DIDECLUST27 - 0 Idle +FI--DIDECLUST27 - 1 Idle +FI--DIDECLUST27 - 2 Idle +FI--DIDECLUST27 - 3 Idle +FI--DIDECLUST27 - 4 Idle +FI--DIDECLUST27 - 5 Idle +FI--DIDECLUST27 - 6 Idle +FI--DIDECLUST27 - 7 Idle +FI--DIDECLUST28 - 0 TaskRunning 3490620 1 call \\fi--san03.dide. +FI--DIDECLUST28 - 1 TaskRunning 3490621 1 call \\fi--san03.dide. +FI--DIDECLUST28 - 2 TaskRunning 3490634 1 call \\fi--san03.dide. +FI--DIDECLUST28 - 3 Idle +FI--DIDECLUST28 - 4 Idle +FI--DIDECLUST28 - 5 Idle +FI--DIDECLUST28 - 6 Idle +FI--DIDECLUST28 - 7 Idle +FI--DIDECLUST29 - 0 Idle +FI--DIDECLUST29 - 1 Idle +FI--DIDECLUST29 - 2 Idle +FI--DIDECLUST29 - 3 Idle +FI--DIDECLUST29 - 4 Idle +FI--DIDECLUST29 - 5 Idle +FI--DIDECLUST29 - 6 Idle +FI--DIDECLUST29 - 7 Idle +FI--DIDECLUST30 - 0 Idle +FI--DIDECLUST30 - 1 Idle +FI--DIDECLUST30 - 2 Idle +FI--DIDECLUST30 - 3 Idle +FI--DIDECLUST30 - 4 Idle +FI--DIDECLUST30 - 5 Idle +FI--DIDECLUST30 - 6 Idle +FI--DIDECLUST30 - 7 Idle +FI--DIDECLUST31 - 0 Idle +FI--DIDECLUST31 - 1 Idle +FI--DIDECLUST31 - 2 Idle +FI--DIDECLUST31 - 3 Idle +FI--DIDECLUST31 - 4 Idle +FI--DIDECLUST31 - 5 Idle +FI--DIDECLUST31 - 6 Idle +FI--DIDECLUST31 - 7 Idle +FI--DIDECLUST32 - 0 Idle +FI--DIDECLUST32 - 1 Idle +FI--DIDECLUST32 - 2 Idle +FI--DIDECLUST32 - 3 Idle +FI--DIDECLUST32 - 4 Idle +FI--DIDECLUST32 - 5 Idle +FI--DIDECLUST32 - 6 Idle +FI--DIDECLUST32 - 7 Idle +FI--DIDECLUST32 - 8 Idle +FI--DIDECLUST32 - 9 Idle +FI--DIDECLUST32 - 10 Idle +FI--DIDECLUST32 - 11 Idle +FI--DIDECLUST33 - 0 Idle +FI--DIDECLUST33 - 1 Idle +FI--DIDECLUST33 - 2 Idle +FI--DIDECLUST33 - 3 Idle +FI--DIDECLUST33 - 4 Idle +FI--DIDECLUST33 - 5 Idle +FI--DIDECLUST33 - 6 Idle +FI--DIDECLUST33 - 7 Idle +FI--DIDECLUST33 - 8 Idle +FI--DIDECLUST33 - 9 Idle +FI--DIDECLUST33 - 10 Idle +FI--DIDECLUST33 - 11 Idle +FI--DIDECLUSTHN - 0 Idle +FI--DIDECLUSTHN - 1 Idle +FI--DIDECLUSTHN - 2 Idle +FI--DIDECLUSTHN - 3 Idle +FI--DIDECLUSTHN - 4 Idle +FI--DIDECLUSTHN - 5 Idle +FI--DIDECLUSTHN - 6 Idle +FI--DIDECLUSTHN - 7 Idle +WPIA-DIDECLUS34 - 0 Idle +WPIA-DIDECLUS34 - 1 Idle +WPIA-DIDECLUS34 - 2 Idle +WPIA-DIDECLUS34 - 3 Idle +WPIA-DIDECLUS34 - 4 Idle +WPIA-DIDECLUS34 - 5 Idle +WPIA-DIDECLUS34 - 6 Idle +WPIA-DIDECLUS34 - 7 Idle +WPIA-DIDECLUS34 - 8 Idle +WPIA-DIDECLUS34 - 9 Idle +WPIA-DIDECLUS34 - 10 Idle +WPIA-DIDECLUS34 - 11 Idle +WPIA-DIDECLUS34 - 12 Idle +WPIA-DIDECLUS34 - 13 Idle +WPIA-DIDECLUS34 - 14 Idle +WPIA-DIDECLUS34 - 15 Idle +WPIA-DIDECLUS34 - 16 Idle +WPIA-DIDECLUS34 - 17 Idle +WPIA-DIDECLUS34 - 18 Idle +WPIA-DIDECLUS34 - 19 Idle +WPIA-DIDECLUS34 - 20 Idle +WPIA-DIDECLUS34 - 21 Idle +WPIA-DIDECLUS34 - 22 Idle +WPIA-DIDECLUS34 - 23 Idle +WPIA-DIDECLUS35 - 0 Idle +WPIA-DIDECLUS35 - 1 Idle +WPIA-DIDECLUS35 - 2 Idle +WPIA-DIDECLUS35 - 3 Idle +WPIA-DIDECLUS35 - 4 Idle +WPIA-DIDECLUS35 - 5 Idle +WPIA-DIDECLUS35 - 6 Idle +WPIA-DIDECLUS35 - 7 Idle +WPIA-DIDECLUS35 - 8 Idle +WPIA-DIDECLUS35 - 9 Idle +WPIA-DIDECLUS35 - 10 Idle +WPIA-DIDECLUS35 - 11 Idle +WPIA-DIDECLUS35 - 12 Idle +WPIA-DIDECLUS35 - 13 Idle +WPIA-DIDECLUS35 - 14 Idle +WPIA-DIDECLUS35 - 15 Idle +WPIA-DIDECLUS35 - 16 Idle +WPIA-DIDECLUS35 - 17 Idle +WPIA-DIDECLUS35 - 18 Idle +WPIA-DIDECLUS35 - 19 Idle +WPIA-DIDECLUS35 - 20 Idle +WPIA-DIDECLUS35 - 21 Idle +WPIA-DIDECLUS35 - 22 Idle +WPIA-DIDECLUS35 - 23 Idle + + diff --git a/drivers/windows/tests/testthat/responses/log.txt b/drivers/windows/tests/testthat/responses/log.txt new file mode 100644 index 00000000..6f22f53a --- /dev/null +++ b/drivers/windows/tests/testthat/responses/log.txt @@ -0,0 +1,2 @@ +
+ diff --git a/drivers/windows/tests/testthat/responses/status.txt b/drivers/windows/tests/testthat/responses/status.txt new file mode 100644 index 00000000..5fbbfba0 --- /dev/null +++ b/drivers/windows/tests/testthat/responses/status.txt @@ -0,0 +1,6 @@ +3490639 test Finished 1 core DIDE\bob 20210402094710 20210402094710 20210402094720 GeneralNodes +3490638 test_old Finished 1 core DIDE\bob 20210402093402 20210402093401 20210402093412 GeneralNodes +3490637 test_old Finished 1 core DIDE\bob 20210402093346 20210402093346 20210402093356 GeneralNodes +3490636 test_web Finished 1 core DIDE\bob 20210402092833 20210402092833 20210402092843 GeneralNodes +3490635 test Finished 1 core DIDE\bob 20210402091124 20210402091124 20210402091134 GeneralNodes + diff --git a/drivers/windows/tests/testthat/test-batch.R b/drivers/windows/tests/testthat/test-batch.R new file mode 100644 index 00000000..d604ca96 --- /dev/null +++ b/drivers/windows/tests/testthat/test-batch.R @@ -0,0 +1,64 @@ +test_that("batch data creates entries for share drives", { + mount <- withr::local_tempfile() + root <- example_root(mount, "b/c") + path_root <- root$path$root + config <- hermod::hermod_get_configuration("windows", root = root) + dat <- template_data(root$path$root, config, path_root) + + nms <- c("hostname", + "date", + "hermod_version", + "r_version", + "network_shares_create", + "network_shares_delete", + "hermod_workdir_drive", + "hermod_workdir_path", + "hermod_path_root_abs", + "cluster_name") + expect_setequal(names(dat), nms) + expect_true(all(vlapply(dat, function(x) is.character(x) && length(x) == 1))) + expect_match(dat$network_shares_create, + "net use X:", fixed = TRUE) + + expect_equal(dat$hermod_workdir_drive, "X:") + expect_equal(dat$hermod_workdir_path, "\\b\\c") + expect_equal(dat$hermod_path_root_abs, "X:\\b\\c") +}) + + +test_that("batch data can run from subdirectory of root", { + mount <- withr::local_tempfile() + root <- example_root(mount, "b/c") + path_root <- root$path$root + config <- hermod::hermod_get_configuration("windows", root = root) + path <- file.path(mount, "b/c/d") + fs::dir_create(path) + path <- normalize_path(path) + dat <- template_data(path, config, path_root) + expect_equal(dat$hermod_workdir_drive, "X:") + expect_equal(dat$hermod_workdir_path, "\\b\\c\\d") + expect_equal(dat$hermod_path_root_abs, "X:\\b\\c") +}) + + +test_that("batch data can not run outside root directory", { + mount <- withr::local_tempfile() + root <- example_root(mount, "b/c") + path_root <- root$path$root + config <- hermod::hermod_get_configuration("windows", root = root) + path <- file.path(mount, "b") + expect_error(template_data(path, config, path_root), + "Expected working directory to be within hermod root") +}) + + +test_that("can write a runner batch file", { + mount <- withr::local_tempfile() + root <- example_root(mount, "b/c") + path_root <- root$path$root + config <- hermod::hermod_get_configuration("windows", root = path_root) + id <- hermod::hermod_task_create_explicit(quote(sessionInfo()), + root = path_root) + write_batch_task_run(id, root$path$root, config, path_root) + expect_true(file.exists(file.path(root$path$tasks, id, "run.bat"))) +}) diff --git a/drivers/windows/tests/testthat/test-cluster.R b/drivers/windows/tests/testthat/test-cluster.R new file mode 100644 index 00000000..8939babb --- /dev/null +++ b/drivers/windows/tests/testthat/test-cluster.R @@ -0,0 +1,47 @@ +test_that("Can transform cluster names", { + expect_equal(cluster_name(NULL), "wpia-hn") + expect_equal(cluster_name("wpia-hn"), "wpia-hn") + expect_equal(cluster_name("sk"), "wpia-hn") + expect_equal(cluster_name("new"), "wpia-hn") + expect_equal(cluster_name("windows"), "wpia-hn") +}) + + +test_that("can list valid templates", { + expect_type(valid_templates("wpia-hn"), "character") + expect_true("AllNodes" %in% valid_templates("wpia-hn")) + expect_error(valid_templates("imperial"), + "Invalid cluster 'imperial'") +}) + + +test_that("can detect valid cores", { + expect_equal(valid_cores("wpia-hn"), 32) + expect_error(valid_cores("imperial"), "Invalid cluster 'imperial'") +}) + + +test_that("if r_versions cache is empty, call client", { + prev <- cache$r_versions + rm(list = "r_versions", envir = cache) + on.exit(cache$r_versions <- prev) + + versions <- numeric_version(c("4.2.3", "4.3.1")) + fetch <- mockery::mock(versions) + mockery::stub(r_versions, "r_versions_fetch", fetch) + expect_equal(r_versions(), versions) + expect_equal(cache$r_versions, versions) + mockery::expect_called(fetch, 1) + + expect_equal(r_versions(), versions) + mockery::expect_called(fetch, 1) +}) + + +test_that("fetch r versions", { + testthat::skip_if_offline() + dat <- r_versions_fetch() + expect_s3_class(dat, "numeric_version") + expect_true(numeric_version("4.3.0") %in% dat) + expect_true(length(dat) > 3) +}) diff --git a/drivers/windows/tests/testthat/test-config.R b/drivers/windows/tests/testthat/test-config.R new file mode 100644 index 00000000..1fa9187d --- /dev/null +++ b/drivers/windows/tests/testthat/test-config.R @@ -0,0 +1,41 @@ +test_that("Can create configuration", { + mount <- withr::local_tempfile() + path <- file.path(mount, "b", "c") + fs::dir_create(path) + shares <- path_mapping("home", mount, "//host/share/path", "X:") + config <- withr::with_dir(path, make_configuration(shares, "4.3.0")) + expect_setequal( + names(config), + c("cluster", "template", "shares", "r_version")) + expect_equal(config$cluster, "wpia-hn") + expect_equal(config$template, "AllNodes") + expect_equal(config$shares, list(shares)) + expect_equal(config$r_version, numeric_version("4.3.0")) +}) + + +test_that("Select a sensible r version", { + v <- r_versions() + vmax <- max(v) + vmid <- v[length(v) - 3] + expect_equal(select_r_version(vmax), vmax) + expect_error(select_r_version("3.6.0"), + "Unsupported R version: 3.6.0") + expect_equal(select_r_version(NULL, vmid), vmid) + expect_equal(select_r_version(NULL, "4.1.0"), numeric_version("4.1.3")) +}) + + +test_that("can configure a root", { + mount <- withr::local_tempfile() + path <- file.path(mount, "b", "c") + root <- suppressMessages(hermod::hermod_init(path)) + shares <- path_mapping("home", mount, "//host/share/path", "X:") + cmp <- withr::with_dir(path, make_configuration(shares, "4.3.0")) + + hermod::hermod_configure(driver = "windows", + shares = shares, + r_version = "4.3.0", + root = root) + expect_equal(hermod::hermod_get_configuration("windows", root), cmp) +}) diff --git a/drivers/windows/tests/testthat/test-dide-auth.R b/drivers/windows/tests/testthat/test-dide-auth.R new file mode 100644 index 00000000..4dee2d8a --- /dev/null +++ b/drivers/windows/tests/testthat/test-dide-auth.R @@ -0,0 +1,159 @@ +test_that("Require a sensible name", { + expect_error(check_username(""), "Invalid empty username") + expect_equal(check_username("bob"), "bob") + expect_equal(check_username("DIDE\\bob"), "bob") +}) + + +test_that("hide passwords on print", { + pw <- structure("secret", class = "password") + expect_equal(as.character(pw), "*******************") + expect_output(print(pw), "*******************", fixed = TRUE) +}) + + +test_that("informative error if credentials are not set", { + mock_key_get <- mockery::mock(stop("not found")) + mockery::stub(dide_credentials, "keyring::key_get", mock_key_get) + expect_error( + dide_credentials(), + "Did not find your DIDE credentials, please run 'dide_authenticate()'", + fixed = TRUE) + mockery::expect_called(mock_key_get, 1) + expect_equal(mockery::mock_args(mock_key_get)[[1]], + list("hermod/dide/username")) +}) + + +test_that("can fetch dide credentials", { + mock_key_get <- mockery::mock("alice", "secret") + mockery::stub(dide_credentials, "keyring::key_get", mock_key_get) + res <- dide_credentials() + expect_equal(res$username, "alice") + expect_equal(res$password, structure("secret", class = "password")) + mockery::expect_called(mock_key_get, 2) + expect_equal( + mockery::mock_args(mock_key_get), + list(list("hermod/dide/username"), + list("hermod/dide/password", username = "alice"))) +}) + + +test_that("can store credentials in keychain", { + ## This is pretty grim, but I've not seen another approach to this. + mock_keyring_is_locked <- mockery::mock(TRUE) + mock_keyring_unlock <- mockery::mock() + mock_guess <- mockery::mock("bob") + mock_readline <- mockery::mock("alice") + mock_key_set <- mockery::mock() + mock_key_get <- mockery::mock("secret") + mock_login <- mockery::mock(NULL) + mock_key_set_with_value <- mockery::mock() + + mockery::stub(dide_authenticate, "keyring::keyring_is_locked", + mock_keyring_is_locked) + mockery::stub(dide_authenticate, "keyring::keyring_unlock", + mock_keyring_unlock) + mockery::stub(dide_authenticate, "dide_guess_username", mock_guess) + mockery::stub(dide_authenticate, "readline_with_default", mock_readline) + mockery::stub(dide_authenticate, "keyring::key_set", mock_key_set) + mockery::stub(dide_authenticate, "keyring::key_get", mock_key_get) + mockery::stub(dide_authenticate, "api_client_login", mock_login) + mockery::stub(dide_authenticate, "keyring::key_set_with_value", + mock_key_set_with_value) + + result <- testthat::evaluate_promise(dide_authenticate()) + + expect_equal(result$result, credentials("alice", "secret")) + expect_match(result$messages, "Please enter your DIDE credentials", + all = FALSE) + + mockery::expect_called(mock_keyring_is_locked, 1) + mockery::expect_called(mock_keyring_unlock, 1) + mockery::expect_called(mock_guess, 1) + mockery::expect_called(mock_readline, 1) + expect_equal(mockery::mock_args(mock_readline)[[1]], + list("DIDE username", "bob")) + mockery::expect_called(mock_key_set, 1) + expect_equal(mockery::mock_args(mock_key_set)[[1]], + list("hermod/dide/password", username = "alice")) + mockery::expect_called(mock_key_get, 1) + expect_equal(mockery::mock_args(mock_key_get)[[1]], + list("hermod/dide/password", username = "alice")) + mockery::expect_called(mock_login, 1) + expect_equal(mockery::mock_args(mock_login)[[1]], + list("alice", "secret")) + mockery::expect_called(mock_key_set_with_value, 1) + expect_equal(mockery::mock_args(mock_key_set_with_value)[[1]], + list("hermod/dide/username", password = "alice")) +}) + + +test_that("delete username on error", { + mock_keyring_is_locked <- mockery::mock(FALSE) + mock_guess <- mockery::mock("bob") + mock_readline <- mockery::mock("alice") + mock_key_set <- mockery::mock() + mock_key_get <- mockery::mock("secret") + mock_login <- mockery::mock(stop("invalid credentials")) + mock_key_delete <- mockery::mock() + mock_key_set_with_value <- mockery::mock() + + mockery::stub(dide_authenticate, "keyring::keyring_is_locked", + mock_keyring_is_locked) + mockery::stub(dide_authenticate, "dide_guess_username", mock_guess) + mockery::stub(dide_authenticate, "readline_with_default", mock_readline) + mockery::stub(dide_authenticate, "keyring::key_set", mock_key_set) + mockery::stub(dide_authenticate, "keyring::key_get", mock_key_get) + mockery::stub(dide_authenticate, "api_client_login", mock_login) + mockery::stub(dide_authenticate, "keyring::key_delete", mock_key_delete) + mockery::stub(dide_authenticate, "keyring::key_set_with_value", + mock_key_set_with_value) + + err <- expect_error( + suppressMessages(dide_authenticate()), + "That username/password combination did not work, I'm afraid") + expect_equal( + err$body, + c(x = "invalid credentials", + i = "Please try again with 'dide_authenticate()'")) + + mockery::expect_called(mock_keyring_is_locked, 1) + mockery::expect_called(mock_guess, 1) + mockery::expect_called(mock_readline, 1) + expect_equal(mockery::mock_args(mock_readline)[[1]], + list("DIDE username", "bob")) + mockery::expect_called(mock_key_set, 1) + expect_equal(mockery::mock_args(mock_key_set)[[1]], + list("hermod/dide/password", username = "alice")) + mockery::expect_called(mock_key_get, 1) + expect_equal(mockery::mock_args(mock_key_get)[[1]], + list("hermod/dide/password", username = "alice")) + mockery::expect_called(mock_login, 1) + expect_equal(mockery::mock_args(mock_login)[[1]], + list("alice", "secret")) + mockery::expect_called(mock_key_delete, 1) + expect_equal(mockery::mock_args(mock_key_delete)[[1]], + list("hermod/dide/password", username = "alice")) + mockery::expect_called(mock_key_set_with_value, 0) +}) + + +test_that("guess username", { + mock_list <- mockery::mock(list(service = "x"), + list(service = c("x", "hermod/dide/username"))) + mock_get <- mockery::mock("alice") + mockery::stub(dide_guess_username, "keyring::key_list", mock_list) + mockery::stub(dide_guess_username, "keyring::key_get", mock_get) + + expect_equal(dide_guess_username(), get_system_username()) + mockery::expect_called(mock_list, 1) + mockery::expect_called(mock_get, 0) + + expect_equal(dide_guess_username(), "alice") + mockery::expect_called(mock_list, 2) + mockery::expect_called(mock_get, 1) + expect_equal(mockery::mock_args(mock_get)[[1]], list("hermod/dide/username")) + + expect_equal(mockery::mock_args(mock_list), list(list(), list())) +}) diff --git a/drivers/windows/tests/testthat/test-mounts.R b/drivers/windows/tests/testthat/test-mounts.R new file mode 100644 index 00000000..834d1c64 --- /dev/null +++ b/drivers/windows/tests/testthat/test-mounts.R @@ -0,0 +1,297 @@ +## Quite a bit of setup here, so a test of quite a bit of +## functionality in one go: +test_that("can locate root path among paths", { + tmp <- withr::local_tempfile() + mounts <- cbind(local = file.path(tmp, c("a", "b", "c")), + remote = c("\\\\server-1\\path", + "\\\\server-2\\homes\\b", + "\\\\server-2\\homes\\c")) + paths <- file.path(mounts[, "local"], c("sub", "dir")) + fs::dir_create(paths) + paths <- clean_path_local(paths) + mounts[, "local"] <- clean_path_local(mounts[, "local"]) + shares <- Map(path_mapping, + basename(mounts[, "local"]), + mounts[, "local"], + mounts[, "remote"], + c("X:", "Y:", "Z:")) + ## In this case, the user explicitly provides a share that contains + ## their working directory + expect_equal(dide_add_extra_root_share(shares, paths[[1]], mounts), + shares) + result <- path_mapping("root", mounts[1, "local"], mounts[1, "remote"], + "V:") + + ## More commonly, we work out where the working directory is from + ## their mounts: + if (!is_windows()) { + ## This test is hard to get right on windows, because the remote + ## path needs to be a drive, and it's not here generally. + expect_equal(dide_add_extra_root_share(shares[2], paths[[1]], mounts), + c(shares[2], list(result))) + } + ## Usually when we fail to find a working directory it's because + ## it's not on a network path: + expect_error( + dide_add_extra_root_share(shares, getwd(), mounts), + "Can't map local directory '.+'") + expect_error( + dide_add_extra_root_share(NULL, getwd(), mounts), + "Can't map local directory '.+'") + ## This is extremely unlikely: + expect_error( + dide_add_extra_root_share(NULL, paths[[1]], mounts[c(1, 1, 2, 3), ]), + "Having trouble determining the working root directory mount point") +}) + + +test_that("detect_mounts uses correct implementation", { + ## Pretty heavy mocking here! + mock_is_windows <- mockery::mock(TRUE, FALSE) + mock_dmw <- mockery::mock() + mock_dmu <- mockery::mock() + + mockery::stub(detect_mounts, "is_windows", mock_is_windows) + mockery::stub(detect_mounts, "detect_mounts_windows", mock_dmw) + mockery::stub(detect_mounts, "detect_mounts_unix", mock_dmu) + + detect_mounts() + mockery::expect_called(mock_is_windows, 1) + mockery::expect_called(mock_dmw, 1) + mockery::expect_called(mock_dmu, 0) + + detect_mounts() + mockery::expect_called(mock_is_windows, 2) + mockery::expect_called(mock_dmw, 1) + mockery::expect_called(mock_dmu, 1) +}) + + +test_that("return sensible data when no mounts found (linux)", { + skip_on_os("windows") + mock_system2 <- mockery::mock(character()) + mockery::stub(detect_mounts_unix, "system2", mock_system2) + res <- detect_mounts_unix() + expect_equal(res, cbind(remote = character(), local = character())) +}) + + +test_that("Parse return value into sensible output (linux)", { + skip_on_os("windows") + tmp <- withr::local_tempdir() + tmp <- normalize_path(tmp) + paths <- file.path(tmp, c("other", "home", "malaria")) + fs::dir_create(paths) + dat <- c( + "//fi--didef3/other on %s/other type cifs (rw,relatime)", + "//fi--san03/homes/bob on %s/home type cifs (rw,relatime)", + "//fi--didenas1/Malaria on %s/malaria type cifs (rw,relatime)") + dat <- vcapply(dat, function(x) sprintf(x, tmp), USE.NAMES = FALSE) + mock_system2 <- mockery::mock(dat) + mockery::stub(detect_mounts_unix, "system2", mock_system2) + res <- detect_mounts_unix() + cmp <- cbind(remote = c("\\\\fi--didef3\\other", + "\\\\fi--san03\\homes\\bob", + "\\\\fi--didenas1\\Malaria"), + local = paths) + expect_equal(res, cmp) +}) + + +test_that("Warn if given unexpected output (linux)", { + skip_on_os("windows") + tmp <- withr::local_tempdir() + tmp <- normalize_path(tmp) + paths <- file.path(tmp, c("other", "home", "malaria")) + fs::dir_create(paths) + dat <- c( + "//fi--didef3/other on %s/other type cifs (rw,relatime)", + "//fi--san03/homes/bob sur %s/home type cifs (rw,relatime)", + "//fi--didenas1/Malaria on %s/malaria type cifs (rw,relatime)") + dat <- vcapply(dat, function(x) sprintf(x, tmp), USE.NAMES = FALSE) + mock_system2 <- mockery::mock(dat) + mockery::stub(detect_mounts_unix, "system2", mock_system2) + expect_warning( + res <- detect_mounts_unix(), + "Ignoring mounts") + cmp <- cbind(remote = c("\\\\fi--didef3\\other", + "\\\\fi--didenas1\\Malaria"), + local = paths[-2]) + expect_equal(res, cmp) +}) + + +test_that("Can parse wmic output", { + x <- c("\r", + "Node,ConnectionState,LocalName,RemoteName,Status\r", + "BUILDERHV,Connected,q:,\\\\fi--san03\\homes\\bob,OK\r", + "BUILDERHV,Connected,T:,\\\\fi--didef3\\tmp,OK\r") + expect_equal( + wmic_parse(x), + cbind(remote = c("\\\\fi--san03\\homes\\bob", "\\\\fi--didef3\\tmp"), + local = c("q:", "T:"))) +}) + + +test_that("Can validate wmic output", { + x <- c("\r", + "node,connectionstate,localname,remotename,status\r", + "BUILDERHV,Connected,q:,\\\\fi--san03\\homes\\bob,OK\r", + "BUILDERHV,Connected,T:,\\\\fi--didef3\\tmp,OK\r") + expect_error( + wmic_parse(x), + "Failed to find expected names in wmic output: RemoteName, LocalName") +}) + + +test_that("detect_mounts_windows tries different methods in turn", { + err <- list(success = FALSE, + result = tryCatch(stop("some error"), error = identity)) + res <- list(success = TRUE, + result = cbind(remote = "\\\\fi--remote\\path", local = "Q:")) + mock_wmic_call <- mockery::mock(err, res) + mockery::stub(detect_mounts_windows, "wmic_call", mock_wmic_call) + + expect_equal(detect_mounts_windows(), res$result) + win_dir <- Sys.getenv("windir", "C:\\Windows") + mockery::expect_called(mock_wmic_call, 2) + expect_equal( + mockery::mock_args(mock_wmic_call), + list(list("csv"), + list(sprintf("%s\\System32\\wbem\\en-US\\csv", win_dir)))) +}) + + +test_that("detect_mounts_windows errors if no method found", { + err <- list(success = FALSE, result = "some error") + mock_wmic_call <- mockery::mock(err, cycle = TRUE) + mockery::stub(detect_mounts_windows, "wmic_call", mock_wmic_call) + expect_error( + detect_mounts_windows(), + "Could not determine windows mounts using wmic.+some error") + mockery::expect_called(mock_wmic_call, 3) + win_dir <- Sys.getenv("windir", "C:\\Windows") + expect_equal( + mockery::mock_args(mock_wmic_call), + list(list("csv"), + list(sprintf("%s\\System32\\wbem\\en-US\\csv", win_dir)), + list(sprintf("%s\\System32\\wbem\\en-GB\\csv", win_dir)))) +}) + + +test_that("wmic_call copes with command and parse errors", { + res_err <- structure(character(0), status = 1) + res_bad <- "lolno" + res_good <- c("\r", + "Node,ConnectionState,LocalName,RemoteName,Status\r", + "BUILDERHV,Connected,q:,\\\\fi--san03\\homes\\bob,OK\r", + "BUILDERHV,Connected,T:,\\\\fi--didef3\\tmp,OK\r") + + mock_system <- mockery::mock(stop("Error running command"), res_bad, res_good) + mockery::stub(wmic_call, "system_intern_check", mock_system) + + res1 <- wmic_call("csv") + res2 <- wmic_call("csv") + res3 <- wmic_call("csv") + + expect_equal( + res1, + list(success = FALSE, result = "Error running command")) + expect_equal( + res2, + list( + success = FALSE, + result = paste("Failed to find expected names in wmic output:", + "RemoteName, LocalName"))) + expect_equal( + res3, + list(success = TRUE, result = wmic_parse(res_good))) + + mockery::expect_called(mock_system, 3) + expect_equal( + mockery::mock_args(mock_system), + rep(list(list('wmic netuse list brief /format:"csv"')), 3)) +}) + + +test_that("Find an available drive", { + shares <- list(list(drive_remote = "V:"), + list(drive_remote = "W:")) + expect_equal(available_drive(shares, "X:"), "X:") + expect_equal(available_drive(shares, "/path"), "X:") + expect_equal(available_drive(list(), "/path"), "V:") +}) + + +test_that("Validate additional shares", { + path <- withr::local_tempfile() + mounts <- example_mounts(path) + shares <- Map(path_mapping, + c("other", "home", "project", "temp", "sk"), + mounts[, "local"], + mounts[, "remote"], + c("O:", "Q:", "P:", "T:", "K:"), + USE.NAMES = FALSE) + expect_silent(dide_check_shares(shares)) + expect_equal(dide_check_shares(shares[[1]]), shares[1]) + expect_error(dide_check_shares(c(shares, TRUE)), + "All elements of 'shares' must be a path_mapping") + expect_error(dide_check_shares(TRUE), + "Invalid input for 'shares'") + expect_null(dide_check_shares(list())) + expect_null(dide_check_shares(NULL)) +}) + + +test_that("Prevent duplicated drives", { + path <- withr::local_tempfile() + mounts <- example_mounts(path) + shares <- Map(path_mapping, + c("a", "b", "c"), + mounts[1:3, "local"], + mounts[1:3, "remote"], + c("X:", "Y:", "X:")) + expect_error( + dide_check_shares(shares), + "Duplicate remote drive names: X:") +}) + + +test_that("Remap nas regex - South Ken", { + expect_equal(use_app_on_nas_south_ken("\\\\wpia-hn/X"), "\\\\wpia-hn-app/X") + expect_equal(use_app_on_nas_south_ken("//wpia-hn/X"), "//wpia-hn-app/X") + expect_equal(use_app_on_nas_south_ken( + "\\\\wpia-hn.hpc.dide.ic.ac.uk\\X"), + "\\\\wpia-hn-app.hpc.dide.local\\X") + expect_equal(use_app_on_nas_south_ken( + "//wpia-hn.hpc.dide.ic.ac.uk/X"), + "//wpia-hn-app.hpc.dide.local/X") + expect_equal(use_app_on_nas_south_ken( + "\\\\wpia-hn.dide.local\\X"), + "\\\\wpia-hn-app.hpc.dide.local\\X") + expect_equal(use_app_on_nas_south_ken( + "//wpia-hn.dide.local/X"), + "//wpia-hn-app.hpc.dide.local/X") + expect_equal(use_app_on_nas_south_ken( + "\\\\wpia-hn.hpc.dide.local\\X"), + "\\\\wpia-hn-app.hpc.dide.local\\X") + expect_equal(use_app_on_nas_south_ken( + "//wpia-hn.hpc.dide.local/X"), + "//wpia-hn-app.hpc.dide.local/X") +}) + + +test_that("Check nas regex won't map cross-campus", { + expect_equal(use_app_on_nas_south_ken( + "\\\\fi--didenas1.dide.ic.ac.uk\\X"), "\\\\fi--didenas1.dide.ic.ac.uk\\X") + expect_equal(use_app_on_nas_south_ken( + "//fi--didenas3.dide.ic.ac.uk/X"), "//fi--didenas3.dide.ic.ac.uk/X") + expect_equal(use_app_on_nas_south_ken( + "\\\\fi--didenas4\\X"), "\\\\fi--didenas4\\X") + expect_equal(use_app_on_nas_south_ken( + "//fi--didenas5/X"), "//fi--didenas5/X") + expect_equal(use_app_on_nas_south_ken( + "\\\\fi--didenas1.dide.local\\X"), "\\\\fi--didenas1.dide.local\\X") + expect_equal(use_app_on_nas_south_ken( + "//fi--didenas3.dide.local/X"), "//fi--didenas3.dide.local/X") +}) diff --git a/drivers/windows/tests/testthat/test-paths.R b/drivers/windows/tests/testthat/test-paths.R new file mode 100644 index 00000000..6a1e96e5 --- /dev/null +++ b/drivers/windows/tests/testthat/test-paths.R @@ -0,0 +1,99 @@ +test_that("can create a path mapping", { + p <- getwd() + m <- path_mapping("home", p, "//fi--san03/homes/bob", "Q:") + expect_s3_class(m, "path_mapping") + str <- as.character(m) + expect_match(str, "\\(local\\) .+ => .+ \\(remote\\)") + expect_output(print(m), str, fixed = TRUE) +}) + + +test_that("can validate creation of path mapping", { + expect_error( + path_mapping("home", tempfile(), "//fi--san03/homes/bob", "Q:"), + "Local mount point does not exist: ") + expect_error( + path_mapping("home", "Q:", "Q://fi--san03/homes/bob", "Q:"), + "path_remote must be a network path, starting with") + expect_error( + path_mapping("home", getwd(), "//fi--san03/homes/bob", "Q"), + "drive_remote must be of the form 'X:'") +}) + + +test_that("Can clean a remote path", { + expect_equal( + clean_path_remote("//fi--san03/homes/bob"), + "\\\\fi--san03.dide.ic.ac.uk\\homes\\bob") + expect_equal( + clean_path_remote("//fi--san03.dide.local/homes/bob"), + "\\\\fi--san03.dide.ic.ac.uk\\homes\\bob") + expect_equal( + clean_path_remote("//fi--san03.dide.ic.ac.uk/homes/bob/"), + "\\\\fi--san03.dide.ic.ac.uk\\homes\\bob") +}) + + +test_that("Can deal with wpia-hn (.hpc) paths", { + answer <- "\\\\wpia-hn.hpc.dide.ic.ac.uk\\share\\data" + + expect_equal(clean_path_remote("//wpia-hn/share/data"), + answer) + expect_equal(clean_path_remote("//wpia-hn.dide.local/share/data"), + answer) + expect_equal(clean_path_remote("//wpia-hn.dide.ic.ac.uk/share/data"), + answer) + expect_equal(clean_path_remote("//wpia-hn.hpc/share/data"), + answer) + expect_equal(clean_path_remote("//wpia-hn.hpc.dide.local/share/data"), + answer) + expect_equal(clean_path_remote("//wpia-hn.hpc.dide.ic.ac.uk/share/data"), + answer) +}) + + +test_that("Can detect a path into a share", { + p <- dirname(getwd()) + t <- withr::local_tempdir() + t <- normalize_path(t) + shares <- list( + path_mapping("home", p, "//fi--san03/homes/bob", "Q:"), + path_mapping("temp", tempdir(), "//fi--san03/tmp", "T:")) + + x <- prepare_path(t, shares) + expect_equal(x$rel, basename(t)) + expect_s3_class(x, "path_mapping") + expect_equal(x[names(x) != "rel"], shares[[2]][]) + str <- as.character(x) + expect_match(str, "\\[rel: .+\\] \\(local\\) .+ => .+ => T: \\(remote\\)") +}) + + +test_that("prepare_path rejects nonexistant paths", { + expect_error( + prepare_path(tempfile(tmpdir = getwd()), list()), + "path does not exist:") +}) + + +test_that("prepare_path handles unmapped paths", { + expect_error( + prepare_path(getwd(), list()), + "did not find network mapping for path") + expect_null( + prepare_path(getwd(), list(), FALSE)) +}) + + +test_that("Can create a remote path", { + p <- dirname(getwd()) + t <- withr::local_tempdir() + t <- normalize_path(t) + shares <- list( + home = path_mapping("home", p, "//fi--san03/homes/bob", "Q:"), + temp = path_mapping("temp", tempdir(), "//fi--san03/tmp", "T:")) + res <- remote_path(t, shares) + expect_equal( + res, + paste0("\\\\fi--san03.dide.ic.ac.uk\\tmp\\", basename(t))) +}) diff --git a/drivers/windows/tests/testthat/test-util-assert.R b/drivers/windows/tests/testthat/test-util-assert.R new file mode 100644 index 00000000..fc53c169 --- /dev/null +++ b/drivers/windows/tests/testthat/test-util-assert.R @@ -0,0 +1,26 @@ +test_that("assert_scalar", { + expect_error(assert_scalar(NULL), "must be a scalar") + expect_error(assert_scalar(numeric(0)), "must be a scalar") + expect_error(assert_scalar(1:2), "must be a scalar") +}) + + +test_that("assert_character", { + expect_silent(assert_character("a")) + expect_error(assert_character(1), "must be a character") + expect_error(assert_character(TRUE), "must be a character") +}) + + +test_that("assert_integer", { + expect_silent(assert_scalar_integer(1L)) + expect_silent(assert_scalar_integer(1)) + expect_error(assert_scalar_integer(1.1), + "must be an integer") +}) + + +test_that("match_value", { + expect_error(match_value("foo", letters), "must be one of") + expect_silent(match_value("a", letters)) +}) diff --git a/drivers/windows/tests/testthat/test-util.R b/drivers/windows/tests/testthat/test-util.R new file mode 100644 index 00000000..39c20221 --- /dev/null +++ b/drivers/windows/tests/testthat/test-util.R @@ -0,0 +1,109 @@ +test_that("null-or-value works", { + expect_equal(1 %||% NULL, 1) + expect_equal(1 %||% 2, 1) + expect_equal(NULL %||% NULL, NULL) + expect_equal(NULL %||% 2, 2) +}) + + +test_that("sys_which throws on unknown exe", { + expect_error(sys_which("unknowncommand"), + "unknowncommand not found in $PATH", + fixed = TRUE) +}) + + +test_that("system_intern_check copes with R's weirdnesses", { + sys <- function(outcome) { + if (outcome == "success") { + "result" + } else if (outcome == "failure1") { + warning("failure") + structure("result", status = 1) + } else if (outcome == "failure2") { + stop("failure") + } + } + + mock_system <- mockery::mock(sys("success"), + sys("failure1"), + sys("failure2")) + mockery::stub(system_intern_check, "system", mock_system) + expect_equal(system_intern_check("some command"), "result") + expect_error(system_intern_check("some command"), "Error running command") + expect_error(system_intern_check("some command"), "failure") + + mockery::expect_called(mock_system, 3) + expect_equal(mockery::mock_args(mock_system), + rep(list(list("some command", intern = TRUE)), 3)) +}) + + +test_that("hermod file errors if files are not found", { + expect_equal(basename(hermod_windows_file("templates/task_run.bat")), + "task_run.bat") + expect_error(hermod_windows_file("template/task_run.bat")) +}) + + +test_that("can look up system username", { + mock_is_windows <- mockery::mock(TRUE, FALSE, cycle = TRUE) + mockery::stub(get_system_username, "is_windows", mock_is_windows) + + withr::with_envvar(c(USERNAME = NA, USER = NA), { + expect_equal(get_system_username(), NA_character_) + expect_equal(get_system_username(), NA_character_) + }) + + withr::with_envvar(c(USERNAME = "alice", USER = NA), { + expect_equal(get_system_username(), "alice") + expect_equal(get_system_username(), NA_character_) + }) + + withr::with_envvar(c(USERNAME = NA, USER = "bob"), { + expect_equal(get_system_username(), NA_character_) + expect_equal(get_system_username(), "bob") + }) + + withr::with_envvar(c(USERNAME = "alice", USER = "bob"), { + expect_equal(get_system_username(), "alice") + expect_equal(get_system_username(), "bob") + }) +}) + + +test_that("can validate interactive parameters", { + mock_readline <- mockery::mock("alice", "", cycle = TRUE) + mockery::stub(readline_with_default, "readline", mock_readline) + expect_equal( + readline_with_default("enter username", "bob"), + "alice") + expect_equal( + readline_with_default("enter username", "bob"), + "bob") + expect_equal( + readline_with_default("enter username", NA_character_), + "alice") + expect_error( + readline_with_default("enter username", NA_character_), + "A value must be provided") + + mockery::expect_called(mock_readline, 4) + expect_equal(mockery::mock_args(mock_readline)[[1]], + list("enter username (default: bob) > ")) + expect_equal(mockery::mock_args(mock_readline)[[2]], + list("enter username (default: bob) > ")) + expect_equal(mockery::mock_args(mock_readline)[[3]], + list("enter username > ")) + expect_equal(mockery::mock_args(mock_readline)[[4]], + list("enter username > ")) +}) + + +test_that("can transform a string", { + template <- "hello {{input}} world" + expect_equal(glue_whisker(template, list(input = "glue")), + "hello glue world") + expect_equal(glue_whisker(template, list(input = NULL)), + "hello world") +}) diff --git a/drivers/windows/tests/testthat/test-web-format.R b/drivers/windows/tests/testthat/test-web-format.R new file mode 100644 index 00000000..6f78dbb0 --- /dev/null +++ b/drivers/windows/tests/testthat/test-web-format.R @@ -0,0 +1,43 @@ +test_that("Can format the overall load", { + x <- list(cluster = "didehpc", + detail = NULL, + summary = data.frame( + name = c("fi--dideclusthn", "fi--didemrchnb"), + free = c(203, 850), + used = c(13, 930), + total = c(216, 1780), + percent_used = c(6, 52), + stringsAsFactors = FALSE), + overall = list(name = "didehpc", + free = 1053, + used = 943, + total = 1996, + percent_used = 47)) + class(x) <- "dide_clusterload" + expected <- c(" name free used total % used", + "--------------- ---- ---- ----- ------", + "fi--dideclusthn 203 13 216 6%", + " fi--didemrchnb 850 930 1780 52%", + "--------------- ---- ---- ----- ------", + " didehpc 1053 943 1996 47%") + str <- withr::with_options(list(crayon.enabled = FALSE), + format(x)) + expect_equal(str, expected) + str_col <- withr::with_options(list(crayon.enabled = TRUE), + format(x)) + ## TODO: some testthat change means that ansi colours are not forced + ## on anymore, and this fails. Test passes locally though. + ## > expect_true(any(crayon::has_style(str_col))) + expect_equal(crayon::strip_style(str_col), str) + + str2 <- withr::with_options(list(crayon.enabled = FALSE), + format(x, nodes = FALSE)) + expect_equal(str2, expected[c(1:2, 6)]) + + withr::with_options( + list(crayon.enabled = FALSE), + expect_equal(capture.output(print(x)), str)) + withr::with_options( + list(crayon.enabled = TRUE), + expect_equal(capture.output(print(x)), str_col)) +}) diff --git a/drivers/windows/tests/testthat/test-web-parse.R b/drivers/windows/tests/testthat/test-web-parse.R new file mode 100644 index 00000000..3b653d44 --- /dev/null +++ b/drivers/windows/tests/testthat/test-web-parse.R @@ -0,0 +1,172 @@ +test_that("can parse cancel return payloads", { + expect_equal( + client_parse_cancel("12345\tNOT_FOUND\n\n"), + c("12345" = "NOT_FOUND")) + expect_equal( + client_parse_cancel("12345\tNOT_FOUND\n\n12346\tNOT_FOUND\n\n"), + c("12345" = "NOT_FOUND", "12346" = "NOT_FOUND")) +}) + + +test_that("can parse load return payloads", { + txt <- read_lines("responses/load.txt") + res <- client_parse_load_cluster(txt, "fi--dideclusthn") + ## > saveRDS(res, "responses/load.rds", version = 2L) + expect_equal(res, readRDS("responses/load.rds")) +}) + + +test_that("can compute overall load", { + d1 <- readRDS("responses/load.rds") + d2 <- d1 + d2$overall$name <- "other" + d2$overall$free <- 100 + d2$overall$used <- 116 + d2$overall$percent_used <- 54 + res <- client_parse_load_overall(list(d1, d2)) + expect_equal(res$cluster, "didehpc") + expect_null(res$detail) + expect_equal( + res$summary, + data.frame(name = c("fi--dideclusthn", "other"), + free = c(203, 100), + used = c(13, 116), + total = 216, + percent_used = c(6, 54), + stringsAsFactors = FALSE)) + expect_equal( + res$overall, + list(name = "didehpc", + free = 303, + used = 129, + total = 432, + percent_used = 30)) +}) + + +test_that("can parse R versions", { + txt <- paste( + '{"software": [', + ' {"name": "R", "version": "3.6.0"},', + ' {"name": "R", "version": "3.6.1"},', + ' {"name": "other", "version": "1.2.3"},', + ' {"name": "R", "version": "3.6.3"},', + ' {"name": "R", "version": "4.0.2"},', + ' {"name": "R", "version": "4.0.3"}', + "]}", collapse = "\n") + expect_equal( + client_parse_r_versions(txt), + numeric_version(c("3.6.0", "3.6.1", "3.6.3", "4.0.2", "4.0.3"))) +}) + + +test_that("can parse headnodes payload", { + txt <- "fi--dideclusthn\nfi--didemrchnb\nfi--didelxhn\n" + expect_equal( + client_parse_headnodes(txt), + c("fi--dideclusthn", "fi--didemrchnb")) +}) + + +test_that("Can parse empty status payload", { + empty_time <- dide_time_parse(character()) + res <- client_parse_status("") + cmp <- data.frame(dide_id = character(0), + name = character(0), + status = character(0), + resources = character(0), + user = character(0), + time_start = empty_time, + time_submit = empty_time, + time_end = empty_time, + template = character(0), + stringsAsFactors = FALSE) + expect_equal(res, cmp) +}) + + +test_that("Can parse status payload", { + txt <- read_lines("responses/status.txt") + res <- client_parse_status(txt) + + t1 <- c("20210402094710", "20210402093402", "20210402093346", + "20210402092833", "20210402091124") + t2 <- c("20210402094710", "20210402093401", "20210402093346", + "20210402092833", "20210402091124") + t3 <- c("20210402094720", "20210402093412", "20210402093356", + "20210402092843", "20210402091134") + + cmp <- data.frame( + dide_id = c("3490639", "3490638", "3490637", "3490636", "3490635"), + name = c("test", "test_old", "test_old", "test_web", "test"), + status = "COMPLETE", + resources = "1 core", + user = "bob", + time_start = dide_time_parse(t1), + time_submit = dide_time_parse(t2), + time_end = dide_time_parse(t3), + template = "GeneralNodes", + stringsAsFactors = FALSE) + expect_equal(res, cmp) +}) + + +test_that("Handle parse failure", { + txt <- read_lines("responses/status.txt") + expect_error( + client_parse_status(sub("bob\\s+", "", txt)), + "Parse error; unexpected output from server") +}) + + +test_that("Can parse submission of a single job", { + expect_equal( + client_parse_submit("Job has been submitted. ID: 3490639.\n", 1L), + "3490639") + expect_error( + client_parse_submit("", 1L), + "Job submission has likely failed; could be a login error") + expect_error( + client_parse_submit("Job has been submitted. ID: 3490639.\n", 2L), + "Unexpected response length from server") + expect_message( + res <- client_parse_submit( + "Job has been submitted. ID: 3490639.\nother", 1L), + "Discarding additional response from server:\nother") + expect_equal(res, "3490639") +}) + + +test_that("Can parse logs", { + txt <- read_lines("responses/log.txt") + expect_equal( + client_parse_log(txt), + c("C:\\Users\\rfitzjoh>echo starting!", + "starting!", + "", + "C:\\Users\\rfitzjoh>sleep 10", + "", + "C:\\Users\\rfitzjoh>echo done!", + "done!")) +}) + + +test_that("Can parse cancel payload", { + expect_equal( + client_parse_cancel("3490640\tOK\n"), + setNames("OK", "3490640")) + expect_equal( + client_parse_cancel("3490640\tWRONG_STATE\n"), + setNames("WRONG_STATE", "3490640")) + expect_equal( + client_parse_cancel("3490640\tWRONG_STATE\n"), + setNames("WRONG_STATE", "3490640")) + s <- paste0("3490640\tWRONG_STATE\n3490641\tNOT_FOUND\n\n", + "3490642\tNOT_FOUND\n\n3490643\tNOT_FOUND\n\n") + expect_equal( + client_parse_cancel(s), + c("3490640" = "WRONG_STATE", + "3490641" = "NOT_FOUND", + "3490642" = "NOT_FOUND", + "3490643" = "NOT_FOUND")) +}) diff --git a/drivers/windows/tests/testthat/test-web-support.R b/drivers/windows/tests/testthat/test-web-support.R new file mode 100644 index 00000000..14c3a783 --- /dev/null +++ b/drivers/windows/tests/testthat/test-web-support.R @@ -0,0 +1,62 @@ +test_that("Check cluster usage", { + valid <- valid_clusters() + expect_silent(client_check("wpia-hn", valid)) + expect_error( + client_check("wpia-hn", character(0)), + "You do not have access to any cluster") + expect_error( + client_check("fi--dideclusthn", "wpia-hn"), + "You do not have access to 'fi--dideclusthn'; try 'wpia-hn'") + expect_error( + client_check("fi--didegpu", c("a", "b")), + "You do not have access to 'fi--didegpu'; try one of 'a', 'b'") +}) + + +test_that("Construct a submit body", { + p <- "\\\\fi--host\\\\path" + d <- client_body_submit(p, "name", "GeneralNodes", "fi--dideclusthn", + "Cores", 1, c("1", "2")) + expect_setequal( + names(d), + c("cluster", "template", "rc", "rt", "jn", "wd", "se", "so", + "jobs", "dep", "hpcfunc")) + expect_equal(d$cluster, encode64("fi--dideclusthn")) + expect_equal(d$template, encode64("GeneralNodes")) + expect_equal(d$rc, encode64("1")) + expect_equal(d$rt, encode64("Cores")) + expect_equal(d$wd, "") # we might set this in future though + expect_equal(d$se, "") # we might set this in future though + expect_equal(d$so, "") # we might set this in future though + expect_equal(d$jobs, encode64(sprintf('call "%s"', p))) + expect_equal(d$dep, encode64("1,2")) + expect_equal(d$hpcfunc, "submit") +}) + + +test_that("submission body validates path", { + p <- "\\\\fi--host\\\\path" + expect_error( + client_body_submit(gsub("\\", "/", p, fixed = TRUE), "name", "GeneralNodes", + "fi--dideclusthn", "Cores", 1, character(0)), + "All paths must be Windows network paths") +}) + + +test_that("Construct a cancel body", { + cluster <- "fi--dideclusthn" + expect_equal( + client_body_cancel("123456", cluster), + list(cluster = encode64(cluster), + hpcfunc = encode64("cancel"), + c123456 = "123456")) + expect_equal( + client_body_cancel(c("123456", "234567"), cluster), + list(cluster = encode64(cluster), + hpcfunc = encode64("cancel"), + c123456 = "123456", + c234567 = "234567")) + expect_error( + client_body_cancel(character(0), cluster), + "Need at least one task to cancel") +}) diff --git a/drivers/windows/tests/testthat/test-web.R b/drivers/windows/tests/testthat/test-web.R new file mode 100644 index 00000000..12a32f48 --- /dev/null +++ b/drivers/windows/tests/testthat/test-web.R @@ -0,0 +1,384 @@ +test_that("can fetch cached web client", { + mock_credentials <- mockery::mock(example_credentials()) + mockery::stub(get_web_client, "dide_credentials", mock_credentials) + cache$web_client <- NULL + on.exit(cache$web_client <- NULL) + + client <- get_web_client() + expect_false(client$logged_in()) + mockery::expect_called(mock_credentials, 1) + expect_identical(client, cache$web_client) + + expect_identical(get_web_client(), client) + mockery::expect_called(mock_credentials, 1) +}) + + +test_that("Can create api client", { + credentials <- example_credentials() + cl <- api_client$new(credentials) + expect_false(cl$logged_in()) + expect_equal(cl$username(), credentials$username) +}) + + +test_that("login sends sensible data", { + credentials <- example_credentials() + cl <- api_client$new(credentials) + mock_login <- mockery::mock(cycle = TRUE) + mock_post <- mockery::mock(mock_response(200), mock_response(403)) + mockery::stub(cl$login, "api_client_login", mock_login) + mockery::stub(cl$logged_in, "self$POST", mock_post) + + cl$login(public = TRUE) + expect_false(cl$logged_in()) + mockery::expect_called(mock_login, 0) + mockery::expect_called(mock_post, 0) + + cl$login() + mockery::expect_called(mock_login, 1) + expect_equal(mockery::mock_args(mock_login)[[1]], + unname(credentials)) + + expect_true(cl$logged_in()) + mockery::expect_called(mock_post, 1) + expect_equal(mockery::mock_args(mock_post)[[1]], + list("/_listheadnodes.php", list(user = ""))) + + cl$login(refresh = FALSE) + mockery::expect_called(mock_login, 1) + mockery::expect_called(mock_post, 1) + + cl$login(refresh = TRUE) + mockery::expect_called(mock_login, 2) + + expect_false(cl$logged_in()) + mockery::expect_called(mock_post, 2) +}) + + +test_that("logout uses correct endpoint", { + credentials <- example_credentials() + cl <- api_client$new(credentials) + private <- r6_private(cl) + private$has_logged_in <- TRUE + + mock_logout <- mockery::mock(cycle = TRUE) + mock_get <- mockery::mock(mock_response(200)) + mockery::stub(cl$logout, "self$GET", mock_get) + + cl$logout() + expect_false(private$has_logged_in) + mockery::expect_called(mock_get, 1) + expect_equal( + mockery::mock_args(mock_get)[[1]], + list("/logout.php", public = TRUE)) +}) + + +test_that("request handles http requests", { + verb <- mockery::mock(mock_response(200), + mock_response(403), + mock_response(400)) + credentials <- example_credentials() + cl <- api_client$new(credentials) + data <- list(a = 1, b = 2) + cl$request(verb, "/path/to", data = data, public = TRUE) + expect_error( + cl$request(verb, "/path/to", data = data, public = TRUE), + "Please login first") + expect_error( + cl$request(verb, "/path/to", data = data, public = TRUE), + "400") + + mockery::expect_called(verb, 3) + expect_equal( + mockery::mock_args(verb), + rep(list(list("https://mrcdata.dide.ic.ac.uk/hpc/path/to", + data = data)), 3)) +}) + + +test_that("GET forwards args to request", { + credentials <- example_credentials() + cl <- api_client$new(credentials) + mock_request <- mockery::mock() + mockery::stub(cl$GET, "self$request", mock_request) + cl$GET("/api/v1/cluster_software/", public = TRUE) + mockery::expect_called(mock_request, 1L) + expect_equal( + mockery::mock_args(mock_request)[[1]], + list(httr::GET, "/api/v1/cluster_software/", public = TRUE)) +}) + + +test_that("POST forwards args to request", { + credentials <- example_credentials() + cl <- api_client$new(credentials) + mock_request <- mockery::mock() + mockery::stub(cl$POST, "self$request", mock_request) + data <- list(a = "a", b = "b") + cl$POST("/_listheadnodes.php", data, public = TRUE) + mockery::expect_called(mock_request, 1L) + ## Many more options here than above: + expect_equal( + mockery::mock_args(mock_request)[[1]], + list(httr::POST, "/_listheadnodes.php", body = data, public = TRUE, + httr::accept("text/plain"), encode = "form")) +}) + + +test_that("Can send sensible login request", { + mock_post <- mockery::mock( + mock_response(403, content = "Some error"), + mock_response(200, + content = "

You don't seem to have any HPC access

"), + mock_response(200, + content = "Welcome")) + mockery::stub(api_client_login, "httr::POST", mock_post) + + expect_error( + api_client_login("username", "password"), "403") + expect_error( + api_client_login("username", "password"), + "You do not have HPC access - please contact Wes") + expect_silent(api_client_login("username", "password")) + + mockery::expect_called(mock_post, 3) + expect_equal( + mockery::mock_args(mock_post)[[1]], + list("https://mrcdata.dide.ic.ac.uk/hpc/index.php", + body = list(us = encode64("username"), + pw = encode64("password"), + hpcfunc = encode64("login")), + encode = "form")) +}) + + +test_that("Create client", { + credentials <- example_credentials() + cl <- web_client$new(credentials, login = FALSE) + expect_s3_class(cl, "web_client") + expect_false(cl$logged_in()) + expect_s3_class(cl$api_client(), "api_client") +}) + + +test_that("login uses client to login and logout", { + mock_client <- list( + login = mockery::mock(), + logout = mockery::mock()) + + cl <- web_client$new(login = FALSE, client = mock_client) + mockery::expect_called(mock_client$login, 0) + cl$login() + mockery::expect_called(mock_client$login, 1) + expect_equal(mockery::mock_args(mock_client$login), + list(list(refresh = TRUE))) + + cl <- web_client$new(login = TRUE, client = mock_client) + mockery::expect_called(mock_client$login, 2) + expect_equal(mockery::mock_args(mock_client$login), + rep(list(list(refresh = TRUE)), 2)) + + cl$logout() + mockery::expect_called(mock_client$logout, 1) + expect_equal(mockery::mock_args(mock_client$logout)[[1]], list()) +}) + + +test_that("client checks access", { + mock_client <- list( + login = function() NULL) + mock_headnodes <- mockery::mock( + character(0), + "other", + "wpia-hn", + cycle = TRUE) + cl <- web_client$new(cluster_default = "wpia-hn", client = mock_client) + mockery::stub(cl$check_access, "self$headnodes", mock_headnodes) + + expect_error( + cl$check_access(), + "You do not have access to any cluster") + expect_error( + cl$check_access(), + "You do not have access to 'wpia-hn'; try 'other'") + expect_silent(cl$check_access()) + + expect_error( + cl$check_access("wpia-hn"), + "You do not have access to any cluster") + expect_silent(cl$check_access("other")) + expect_silent(cl$check_access("wpia-hn")) +}) + + +test_that("submit sends correct payload", { + dide_id <- "12345" + content <- sprintf("Job has been submitted. ID: %s.\n", dide_id) + r <- mock_response(200, content = content) + mock_client <- list(POST = mockery::mock(r, cycle = TRUE)) + cl <- web_client$new(login = FALSE, client = mock_client) + path <- "\\\\host\\path" + + expect_equal( + cl$submit(path, "name", "template", depends_on = c("123", "456")), + dide_id) + mockery::expect_called(mock_client$POST, 1L) + expect_equal( + mockery::mock_args(mock_client$POST)[[1]], + list("/submit_1.php", + client_body_submit(path, "name", "template", "wpia-hn", + "Cores", 1, c("123", "456")))) + + expect_equal( + cl$submit(path, "name", "template", "fi--didemrchnb", "Nodes", 2, + depends_on = character()), + dide_id) + mockery::expect_called(mock_client$POST, 2L) + expect_equal( + mockery::mock_args(mock_client$POST)[[2]], + list("/submit_1.php", + client_body_submit(path, "name", "template", "fi--didemrchnb", + "Nodes", 2, character()))) +}) + + +test_that("cancel sends correct payload", { + dide_id <- "12345" + content <- sprintf("%s\tOK\n", dide_id) + r <- mock_response(200, content = content) + mock_client <- list(POST = mockery::mock(r, cycle = TRUE)) + cl <- web_client$new(login = FALSE, client = mock_client) + expect_equal(cl$cancel(dide_id), setNames("OK", dide_id)) + + mockery::expect_called(mock_client$POST, 1L) + expect_equal( + mockery::mock_args(mock_client$POST)[[1]], + list("/cancel.php", + client_body_cancel(dide_id, "wpia-hn"))) +}) + + +test_that("status sends correct payload", { + content <- read_lines("responses/status.txt") + r <- mock_response(200, content = content) + mock_client <- list(POST = mockery::mock(r), + username = mockery::mock("bob")) + cl <- web_client$new(login = FALSE, client = mock_client) + expect_equal(cl$status_user(), client_parse_status(content)) + + mockery::expect_called(mock_client$username, 1L) + expect_equal(mockery::mock_args(mock_client$username)[[1]], list()) + + expect_equal( + mockery::mock_args(mock_client$POST)[[1]], + list("/_listalljobs.php", + client_body_status("*", "bob", "wpia-hn"))) +}) + + +test_that("log sends correct payload", { + dide_id <- "12345" + content <- read_lines("responses/log.txt") + r <- mock_response(200, content = content) + mock_client <- list(POST = mockery::mock(r)) + cl <- web_client$new(login = FALSE, client = mock_client) + expect_equal(cl$log(dide_id), client_parse_log(content)) + + mockery::expect_called(mock_client$POST, 1L) + expect_equal( + mockery::mock_args(mock_client$POST)[[1]], + list("/showjobfail.php", + client_body_log(dide_id, "wpia-hn"))) +}) + + +test_that("status job sends correct payload", { + dide_id <- "12345" + r <- mock_response(200, content = "Running") + mock_client <- list(GET = mockery::mock(r)) + cl <- web_client$new(login = FALSE, client = mock_client) + expect_equal(cl$status_job(dide_id, "fi--didemrchnb"), + "RUNNING") + + mockery::expect_called(mock_client$GET, 1L) + expect_equal( + mockery::mock_args(mock_client$GET)[[1]], + list("/api/v1/get_job_status/", + query = list(scheduler = "fi--didemrchnb", + jobid = dide_id))) +}) + + +test_that("headnodes sends correct payload", { + content <- paste0(valid_clusters(), "\n", collapse = "") + r <- mock_response(200, content = content) + mock_client <- list(POST = mockery::mock(r, cycle = TRUE)) + cl <- web_client$new(login = FALSE, client = mock_client) + expect_null(r6_private(cl)$headnodes_) + + expect_equal(cl$headnodes(), valid_clusters()) + expect_equal(r6_private(cl)$headnodes_, valid_clusters()) + mockery::expect_called(mock_client$POST, 1L) + expect_equal( + mockery::mock_args(mock_client$POST)[[1]], + list("/_listheadnodes.php", list(user = ""))) + + expect_equal(cl$headnodes(), valid_clusters()) + mockery::expect_called(mock_client$POST, 1L) + + expect_equal(cl$headnodes(TRUE), valid_clusters()) + mockery::expect_called(mock_client$POST, 2L) + expect_equal(mockery::mock_args(mock_client$POST)[[1]], + mockery::mock_args(mock_client$POST)[[2]]) +}) + + +test_that("load endpoints are correct", { + content <- read_lines("responses/load.txt") + r <- mock_response(200, content = content) + mock_client <- list(POST = mockery::mock(r, cycle = TRUE)) + + cl <- web_client$new(login = FALSE, client = mock_client) + private <- r6_private(cl) + private$headnodes_ <- c("wpia-hn", "fi--didemrchnb") + + cmp1 <- client_parse_load_cluster(content, "wpia-hn") + cmp2 <- client_parse_load_overall( + lapply(private$headnodes_, client_parse_load_cluster, txt = content)) + expect_equal(cl$load_node(), cmp1) + expect_equal(cl$load_overall(), cmp2) + + expect_output( + expect_equal( + withVisible(cl$load_show()), list(value = cmp1, visible = FALSE)), + "wpia-dideclus35") + expect_output( + expect_equal( + withVisible(cl$load_show(TRUE)), list(value = cmp2, visible = FALSE)), + "didehpc") +}) + + +test_that("version endpoint can be called", { + client <- web_client$new("bob") + versions <- client$r_versions() + expect_s3_class(versions, "numeric_version") +}) + + +test_that("version endpoint is correct", { + content <- '{"software": [ + {"name": "R", "version": "4.0.5"}, + {"name": "R", "version": "4.1.3"}]}' + r <- mock_response(200, content = content) + mock_client <- list(GET = mockery::mock(r, cycle = TRUE)) + + cl <- web_client$new(login = FALSE, client = mock_client) + private <- r6_private(cl) + res <- cl$r_versions() + + expect_equal(res, numeric_version(c("4.0.5", "4.1.3"))) +}) diff --git a/tmp.R b/tmp.R deleted file mode 100644 index 4dfadd83..00000000 --- a/tmp.R +++ /dev/null @@ -1,40 +0,0 @@ -path <- tempfile() -hermod_init(path) -hermod_configure(root = path) - - -## Run from a network share -unlink(c("hermod.json", "hermod"), recursive = TRUE) - -pkgload::load_all("~/Documents/Projects/cluster/hermod") -dide_potato(NULL) - -shares <- path_mapping("home", - "/home/rfitzjoh/net/home", - "//fi--san03.dide.ic.ac.uk/homes/rfitzjoh", - "Q:") -dide_potato(NULL) - -hermod_init(".") -hermod_configure() - - - - - - -id <- hermod_task_create_explicit(quote(sessionInfo())) - -config <- didehpc_config("~/.smbcredentials") -root <- hermod_root(".") -write_batch_task_run(root, config, id) - -cl <- web_client$new(config$credentials, login = TRUE) - -path_batch <- file.path("//fi--didef3.dide.ic.ac.uk/tmp", - "hermod-example/hermod/tasks", id, - "batch.bat") -res <- cl$submit(windows_path(path_batch), "hermod!", "GeneralNodes") - -hermod_task_status(id) -hermod_task_result(id) From 59c3e5b14e95f9007b3d2c921eeb8c320ded0318 Mon Sep 17 00:00:00 2001 From: Rich FitzJohn Date: Thu, 30 Nov 2023 14:04:46 +0000 Subject: [PATCH 2/3] Trigger windows check --- .../{R-CMD-check.yaml => check-hermod.yaml} | 0 .github/workflows/check-windows.yaml | 56 +++++++++++++++++++ 2 files changed, 56 insertions(+) rename .github/workflows/{R-CMD-check.yaml => check-hermod.yaml} (100%) create mode 100644 .github/workflows/check-windows.yaml diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/check-hermod.yaml similarity index 100% rename from .github/workflows/R-CMD-check.yaml rename to .github/workflows/check-hermod.yaml diff --git a/.github/workflows/check-windows.yaml b/.github/workflows/check-windows.yaml new file mode 100644 index 00000000..5300f2b7 --- /dev/null +++ b/.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: R-CMD-check + +jobs: + R-CMD-check: + 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 From 4d73e1626b6a30e44fb2c8697f4b022818eeb165 Mon Sep 17 00:00:00 2001 From: Rich FitzJohn Date: Thu, 30 Nov 2023 14:08:07 +0000 Subject: [PATCH 3/3] Easier to interpret names --- .github/workflows/check-hermod.yaml | 4 ++-- .github/workflows/check-windows.yaml | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/.github/workflows/check-hermod.yaml b/.github/workflows/check-hermod.yaml index 758f8664..58a017f6 100644 --- a/.github/workflows/check-hermod.yaml +++ b/.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 }}) diff --git a/.github/workflows/check-windows.yaml b/.github/workflows/check-windows.yaml index 5300f2b7..03a08d2b 100644 --- a/.github/workflows/check-windows.yaml +++ b/.github/workflows/check-windows.yaml @@ -6,10 +6,10 @@ on: pull_request: branches: [main, master] -name: R-CMD-check +name: check-windows jobs: - R-CMD-check: + check-windows: runs-on: ${{ matrix.config.os }} name: ${{ matrix.config.os }} (${{ matrix.config.r }})