Merge pull request #26 from mrc-ide/mrc-4802

Add support for collecting logs

NAMESPACE

@@ -14,6 +14,8 @@ export(task_cancel)
 export(task_create_explicit)
 export(task_create_expr)
 export(task_eval)
+export(task_log_show)
+export(task_log_value)
 export(task_result)
 export(task_status)
 export(task_submit)

R/configure.R

@@ -59,6 +59,11 @@ hipercow_configure <- function(driver, ..., root = NULL) {
 ##' @param status Fetch a task status. Takes a vector of ids and
 ##'   returns a vector of the same length of statuses.
 ##'
+##' @param log Fetch the task log. Takes a single task id and an
+##'   integer (the number of lines already known) and returns a
+##'   character vector of new logs.  Return `NULL` (and not a zero
+##'   length character vector) if a log is not available.
+##'
 ##' @param result Fetch a task result.  If needed, copies the result
 ##'   file into the current hipercow root.  Assume that a result is
 ##'   available (i.e., we've already checked that the task status is
@@ -75,11 +80,12 @@ hipercow_configure <- function(driver, ..., root = NULL) {
 ##'   function will trigger running conan to provision a library.
 ##'
 ##' @export
-hipercow_driver <- function(configure, submit, status, result, cancel,
+hipercow_driver <- function(configure, submit, status, log, result, cancel,
                           provision) {
   structure(list(configure = configure,
                  submit = submit,
                  status = status,
+                 log = log,
                  result = result,
                  cancel = cancel,
                  provision = provision),

R/task.R

@@ -344,6 +344,46 @@ task_result <- function(id, root = NULL) {
 }
 
 
+##' Get the task log, if the task has produced one.  Tasks run by the
+##' `windows` driver will generally produce a log.  A log might be
+##' quite long, and you might want to print it to screen in its
+##' entirity (`task_log_show`), return it as character vector
+##' (`task_log_value`).
+##'
+##' @title Get task result
+##'
+##' @inheritParams task_status
+##'
+##' @return The value of the queued expression
+##'
+##' @rdname task_log
+##' @export
+task_log_show <- function(id, root = NULL) {
+  result <- task_log_fetch(id, root)
+  if (is.null(result)) {
+    cli::cli_alert_danger("No logs for task '{id}' (yet?)")
+  } else if (length(result) == 0) {
+    cli::cli_alert_danger("Empty logs for task '{id}' (so far?)")
+  } else {
+    cat(paste0(result, "\n", collapse = ""))
+  }
+}
+
+
+##' @rdname task_log
+##' @export
+task_log_value <- function(id, root = NULL) {
+  task_log_fetch(id, root)
+}
+
+
+task_log_fetch <- function(id, root) {
+  driver <- task_get_driver(id, root = root)
+  dat <- hipercow_driver_prepare(driver, root, environment())
+  dat$driver$log(id, dat$config, root$path$root)
+}
+
+
 ##' Cancel one or more tasks
 ##'
 ##' @title Cancel tasks

drivers/windows/R/constants.R

@@ -1,4 +1,5 @@
 # nolint start
 BATCH_RUN <- "run.bat"
 DIDE_ID <- "dide_id"
+TASK_LOG <- "log"
 # nolint end

drivers/windows/R/driver.R

@@ -3,6 +3,7 @@ hipercow_driver_windows <- function() {
     configure = windows_configure,
     submit = windows_submit,
     status = windows_status,
+    log = windows_log,
     result = windows_result,
     cancel = windows_cancel,
     provision = windows_provision)
@@ -57,6 +58,15 @@ windows_result <- function(id, config, path_root) {
 }
 
 
+## TODO: It would be nice to offer the ability to hit the DIDE bit of
+## log; I expect that pbs will have something similar though and it
+## might be worth waiting until we know what the looks like and then
+## adding an additional function that calls the API?
+windows_log <- function(id, config, path_root) {
+  readlines_if_exists(file.path(path_root, "hipercow", "tasks", id, TASK_LOG))
+}
+
+
 windows_cancel <- function(id, config, path_root) {
   path_dide_id <- file.path(path_root, "hipercow", "tasks", id, DIDE_ID)
   dide_id <- vcapply(path_dide_id, readLines, USE.NAMES = FALSE)

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

@@ -135,3 +135,21 @@ test_that("can cancel a bunch of tasks, in reverse order", {
   expect_equal(mockery::mock_args(mock_client$cancel)[[1]],
                list(c("1236", "1235", "1234")))
 })
+
+
+test_that("can read a task log", {
+  mount <- withr::local_tempfile()
+  root <- example_root(mount, "b/c")
+  path_root <- root$path$root
+  config <- root$config$windows
+  id <- withr::with_dir(
+    path_root,
+    hipercow::task_create_explicit(quote(sessionInfo()), submit = FALSE))
+
+  path_log <- file.path(path_root, "hipercow", "tasks", id, "log")
+  expect_null(windows_log(id, config, path_root))
+  file.create(path_log)
+  expect_equal(windows_log(id, config, path_root), character())
+  writeLines(c("a", "b", "c"), path_log)
+  expect_equal(windows_log(id, config, path_root), c("a", "b", "c"))
+})

tests/testthat/helper-hipercow.R

@@ -16,6 +16,7 @@ elsewhere_driver <- function() {
     configure = elsewhere_configure,
     submit = elsewhere_submit,
     status = elsewhere_status,
+    log = elsewhere_log,
     result = elsewhere_result,
     cancel = elsewhere_cancel,
     provision = elsewhere_provision)
@@ -52,6 +53,12 @@ elsewhere_status <- function(id, config, path_root) {
 }
 
 
+elsewhere_log <- function(id, config, path_root) {
+  path <- file.path(config$path, "hipercow", "tasks", id, "elsewhere_log")
+  if (file.exists(path)) readLines(path) else NULL
+}
+
+
 elsewhere_result <- function(id, config, path_root) {
   src <- file.path(config$path, "hipercow", "tasks", id, "result")
   dst <- file.path(path_root, "hipercow", "tasks", id, "result")

tests/testthat/test-interface.R

@@ -290,3 +290,32 @@ test_that("prevent autosubmission when more than one driver configured", {
     "Submitted task")
   expect_equal(task_status(id, root = root), "submitted")
 })
+
+
+test_that("can read logs", {
+  elsewhere_register()
+  path_here <- withr::local_tempdir()
+  path_there <- withr::local_tempdir()
+  init_quietly(path_here)
+  init_quietly(path_there)
+  suppressMessages(
+    hipercow_configure("elsewhere", path = path_there, root = path_here))
+  suppressMessages(
+    id <- withr::with_dir(path_here, task_create_explicit(quote(sqrt(2)))))
+
+  expect_null(task_log_value(id, path_here))
+  expect_message(task_log_show(id, path_here),
+                 "No logs for task '.+'")
+
+  path_log <- file.path(path_there, "hipercow", "tasks", id, "elsewhere_log")
+
+  file.create(path_log)
+  expect_equal(task_log_value(id, path_here), character())
+  expect_message(task_log_show(id, path_here),
+                 "Empty logs for task '.+'")
+
+  writeLines(c("a", "b"), path_log)
+  expect_equal(task_log_value(id, path_here), c("a", "b"))
+  expect_output(task_log_show(id, path_here),
+                "a\nb")
+})