detect_mount <- function() {
if (is_windows()) {
detect_mount_windows()
} else {
detect_mount_unix()
}
}
detect_mount_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_mount_unix <- function() {
mount <- sys_which("mount")
type <- if (Sys.info()[["sysname"]] == "Darwin") "smbfs" else "cifs"
re <- paste(
"//(?<user>[^@]*@)?(?<host>[^/]*)/(?<path>.*?)\\s+on\\s+(?<local>.+?)",
"(?<extra>.+)$")
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 = 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 <- 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_paddington <- function(path_remote) {
# If we're NOT already accessing this path by infiniband,
# but we could be, then add -app to the server name the cluster
# will use.
if (!(grepl("^[/\\\\]{2}fi--didenas[1345]-app", path_remote))) {
path_remote <-
sub("^([/\\\\]{2}fi--didenas[1345])\\b", "\\1-app",
path_remote)
}
path_remote <-
sub("^([/\\\\]{2}fi--didenas[1345]-app)\\.dide\\.ic\\.ac\\.uk|\\.dide\\.local\\b", "\\1.dide.local",
path_remote)
path_remote
}
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)
}
path_remote <-
sub("^([/\\\\]{2}wpia-hn-app)\\.hpc\\.dide\\.ic\\.ac\\.uk|\\.hpc\\.dide\\.local\\b",
"\\1.hpc.dide.local",
path_remote)
path_remote <- gsub("wpia-hn-app.dide.local", "wpia-hn-app.hpc.dide.local",
path_remote)
path_remote
}
## Normalisation
## This function will detect home, temp and if the current working
## directory is not in one of those then continue on to detect the cwd
## too.
dide_detect_mount <- function(mounts, shares, home, temp,
workdir, username, remap_nas, cluster) {
ret <- list()
## These two have a bit of logic, and will try to guess as best they
## can the right thing to do:
ret$home <- dide_detect_mount_home(home, mounts, username)
ret$temp <- dide_detect_mount_temp(temp, mounts)
ret <- c(ret, dide_detect_mount_check_shares(shares))
remote <- vcapply(ret, "[[", "drive_remote", USE.NAMES = FALSE)
dups <- unique(remote[duplicated(remote)])
if (length(dups) > 0L) {
stop("Duplicate remote drive names: ", paste(dups, collapse = ", "))
}
ret <- dide_detect_mount_find_workdir(ret, workdir, mounts)
if (remap_nas) {
for (i in seq_along(ret)) {
if (identical(cluster, "fi--didemrchnb")) {
ret[[i]]$path_remote <- use_app_on_nas_paddington(ret[[i]]$path_remote)
} else {
ret[[i]]$path_remote <- use_app_on_nas_south_ken(ret[[i]]$path_remote)
}
}
}
ret
}
dide_detect_mount_home <- function(home, mounts, username) {
if (is.null(home)) {
## Try to detect where home is currently mounted because Oliver
## keeps his on O.
re <- "^\\\\\\\\(qdrive|fi--san03)(\\.dide\\.ic\\.ac\\.uk)?\\\\homes\\\\"
is_home <- grepl(re, tolower(mounts[, "remote"]))
if (sum(is_home) == 1L) {
home <- path_mapping("home", mounts[is_home, "local"],
mounts[is_home, "remote"], "Q:")
} else if (sum(is_home) > 1L) {
stop(sprintf(
"I am confused about your home directory; there are %d choices:\n%s",
sum(is_home),
paste(sprintf(" - %s => %s",
mounts[is_home, "local"],
mounts[is_home, "remote"]), collapse = "\n")))
} else {
## For now, require that home is given otherwise there are a few
## things that might not work. This might actually be OK but
## needs testing I think. Test this with passing FALSE through
## and see what I can make break
stop("I can't find your home directory! Please mount it")
}
} else {
if (identical(home, FALSE)) {
home <- NULL
} else if (is.character(home)) {
home <- path_mapping("home", home, dide_home(username), "Q:")
} else if (!inherits(home, "path_mapping")) {
stop("Unexpected type for 'home'")
}
}
home
}
dide_detect_mount_temp <- function(temp, mounts) {
if (is.null(temp)) {
is_temp <- string_starts_with(tolower(mounts[, "remote"]),
"\\\\fi--didef3\\tmp")
if (sum(is_temp) == 1L) {
temp <- path_mapping("temp", mounts[is_temp, "local"],
dide_temp(""), "T:")
} else if (sum(is_temp) > 1L) {
stop(sprintf(
"I am confused about your temp directory; there are %d choices:\n%s",
sum(is_temp),
paste(sprintf(" - %s => %s",
mounts[is_temp, "local"],
mounts[is_temp, "remote"]), collapse = "\n")))
}
} else {
if (inherits(temp, "character")) {
temp <- path_mapping("temp", temp, dide_temp(""), "T:")
} else if (!inherits(temp, "path_mapping")) {
stop("Unexpected type for 'temp'")
}
}
temp
}
dide_detect_mount_check_shares <- function(shares) {
if (length(shares) == 0) {
return(NULL)
}
if (inherits(shares, "path_mapping")) {
ret <- setNames(list(shares), shares$name)
} else if (is.list(shares)) {
if (!all(vlapply(shares, inherits, "path_mapping"))) {
stop("All elements of 'shares' must be a path_mapping")
}
ret <- shares
} else {
stop("Invalid input for 'shares'")
}
ret
}
dide_detect_mount_find_workdir <- function(mapping, workdir, mounts) {
if (is.null(workdir)) {
workdir <- getwd()
}
## TODO: this tolower should be windows/mac only, because case is
## important otherwise. However, we'll map against lowercase later.
workdir <- tolower(workdir)
mapped <- vcapply(mapping, "[[", "path_local")
ok <- vlapply(tolower(mapped), string_starts_with, x = workdir)
if (!any(ok)) {
i <- (nzchar(mounts[, "local"]) &
vlapply(tolower(mounts[, "local"]), string_starts_with, x = workdir))
if (sum(i) == 1L) {
drive <- available_drive(mapping, mounts[i, "local"])
workdir_map <- path_mapping("workdir", mounts[i, "local"],
mounts[i, "remote"], drive)
mapping <- c(mapping, list(workdir = workdir_map))
} else if (sum(i) > 1L) {
stop("Having trouble determining the working directory mount point")
} else {
## NOTE: This needs to be checked later when firing up the
## queue, but I believe that it is.
message(sprintf("Running out of place: %s is not on a network share",
workdir))
}
}
mapping
}
## 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]], ":")
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.