Merge pull request #3 from mrc-ide/mrc-5105

mrc-5105: Add has_modifications flag to report list endpoint

R/api.R

@@ -33,17 +33,24 @@ root <- function() {
 
 ##' @porcelain 
 ##'   GET /report/list => json(report_list)
-##'   query hash :: string
+##'   query ref :: string
 ##'   state root :: root
-report_list <- function(root, hash) {
-  contents <- gert::git_ls(root, ref = hash)
+report_list <- function(root, ref) {
+  contents <- gert::git_ls(root, ref = ref)
   re <- "^src/([^/]+)/(\\1|orderly)\\.(yml|R)$"
   nms <- sub(re, "\\1", 
              grep(re, contents$path, value = TRUE, perl = TRUE),
              perl = TRUE)
   last_changed <- function(nm) {
     max(contents$modified[startsWith(contents$path, sprintf("src/%s", nm))])
   }
+  updated_time <- vnapply(nms, last_changed, USE.NAMES = FALSE)
+  modified_sources <- git_get_modified(ref, relative_dir = "src/", repo = root)
+  modified_reports <- unique(first_dirname(modified_sources))
+  has_modifications <- vlapply(nms, function(report_name) {
+    report_name %in% modified_reports
+  }, USE.NAMES = FALSE)
   data.frame(name = nms, 
-             updated_time = vnapply(nms, last_changed, USE.NAMES = FALSE))
+             updated_time = updated_time,
+             has_modifications = has_modifications)
 }

R/git.R

@@ -0,0 +1,41 @@
+git_run <- function(args, repo = NULL, check = FALSE) {
+  git <- sys_which("git")
+  if (!is.null(repo)) {
+    args <- c("-C", repo, args)
+  }
+  res <- system3(git, args)
+  if (check && !res$success) {
+    stop(sprintf("Error code %d running command:\n%s",
+                 res$code, paste0("  > ", res$output, collapse = "\n")))
+  }
+  res
+}
+
+
+git_get_default_branch <- function(repo = NULL) {
+  # This is assuming remote origin exists. We'll get an error if it
+  # doesn't. But this should be safe for us as we'll always have cloned
+  # this from GitHub.
+  origin <- gert::git_remote_info("origin", repo = repo)
+  origin$head
+}
+
+
+git_get_modified <- function(ref, base = NULL, 
+                             relative_dir = NULL, repo = NULL) {
+  if (is.null(base)) {
+    base <- git_get_default_branch(repo)
+  }
+  if (is.null(relative_dir)) {
+    relative <- ""
+    additional_args <- ""
+  } else {
+    relative <- sprintf("--relative=%s", relative_dir)
+    additional_args <- sprintf("-- %s", relative_dir)
+  }
+  git_run(
+    c("diff", "--name-only", relative,
+      sprintf("%s...%s", base, gert::git_commit_id(ref, repo = repo)),
+      additional_args),
+    repo = repo, check = TRUE)$output
+}

R/porcelain.R

@@ -14,7 +14,7 @@
         "GET",
         "/report/list",
         report_list,
-        porcelain::porcelain_input_query(hash = "string"),
+        porcelain::porcelain_input_query(ref = "string"),
         porcelain::porcelain_state(root = state$root),
         returning = porcelain::porcelain_returning_json("report_list"),
         validate = validate)

R/util.R

@@ -18,6 +18,43 @@ vcapply <- function(...) {
 }
 
 
-vnapply <- function(X, FUN, ...) { # nolint
-  vapply(X, FUN, numeric(1), ...)
+vnapply <- function(...) {
+  vapply(FUN.VALUE = numeric(1), ...)
+}
+
+
+vlapply <- function(...) {
+  vapply(FUN.VALUE = logical(1), ...)
+}
+
+
+system3 <- function(command, args) {
+  res <- suppressWarnings(system2(command, args, stdout = TRUE, stderr = TRUE))
+  code <- attr(res, "status") %||% 0
+  attr(res, "status") <- NULL
+  list(success = code == 0,
+       code = code,
+       output = res)
+}
+
+
+sys_which <- function(name) {
+  path <- Sys.which(name)
+  if (!nzchar(path)) {
+    stop(sprintf("Did not find '%s'", name), call. = FALSE)
+  }
+  unname(path)
+}
+
+
+first_dirname <- function(paths) {
+  first_dir <- function(path) {
+    if (basename(path) == path) {
+      dir <- path
+    } else {
+      dir <- first_dirname(dirname(path))
+    }
+    dir
+  }
+  vcapply(paths, first_dir, USE.NAMES = FALSE)
 }

inst/schema/report_list.json

@@ -5,7 +5,10 @@
       "type": "object",
       "properties": {
         "name": { "type": "string" },
-        "updated_time": { "type": "number" }
-      }
+        "updated_time": { "type": "number" },
+        "has_modifications": { "type": "boolean" }
+      },
+      "additionalPropertes": false,
+      "required": [ "name", "updated_time", "has_modifications" ]
     }
 }

tests/testthat/helper-orderly-runner.R

@@ -4,16 +4,19 @@ orderly_runner_endpoint <- function(method, path, root, validate = TRUE) {
                                         validate = validate)
 }
 
+
 create_temporary_root <- function(...) {
   path <- tempfile()
   withr::defer_parent(unlink(path, recursive = TRUE))
   suppressMessages(orderly2::orderly_init(path, ...))
 }
 
+
 new_queue_quietly <- function(root, ...) {
   suppressMessages(Queue$new(root, ...))
 }
 
+
 start_queue_workers_quietly <- function(n_workers,
                                         controller, env = parent.frame()) {
   suppressMessages(
@@ -22,6 +25,7 @@ start_queue_workers_quietly <- function(n_workers,
   withr::defer(rrq::rrq_worker_stop(controller = controller), env = env)
 }
 
+
 skip_if_no_redis <- function() {
   available <- redux::redis_available()
   if (!available) {
@@ -30,6 +34,7 @@ skip_if_no_redis <- function() {
   invisible(available)
 }
 
+
 test_prepare_orderly_example <- function(examples, ...) {
   tmp <- tempfile()
   withr::defer_parent(unlink(tmp, recursive = TRUE))
@@ -38,6 +43,20 @@ test_prepare_orderly_example <- function(examples, ...) {
   as.character(fs::path_norm(tmp))
 }
 
+
+test_prepare_orderly_remote_example <- function(examples, ...) {
+  path_remote <- test_prepare_orderly_example(examples, ...)
+  helper_add_git(path_remote)
+  path_local <- tempfile()
+  withr::defer_parent(unlink(path_local, recursive = TRUE))
+  gert::git_clone(path_remote, path_local)
+  list(
+    remote = path_remote,
+    local = path_local
+  )
+}
+
+
 copy_examples <- function(examples, path_src) {
   fs::dir_create(path_src)
 
@@ -47,6 +66,7 @@ copy_examples <- function(examples, path_src) {
   }
 }
 
+
 helper_add_git <- function(path) {
   gert::git_init(path)
   gert::git_add(".", repo = path)
@@ -58,3 +78,28 @@ helper_add_git <- function(path) {
   gert::git_remote_add(url, repo = path)
   list(path = path, user = user, branch = branch, sha = sha, url = url)
 }
+
+
+initialise_git_repo <- function() {
+  t <- tempfile()
+  dir.create(t)
+  writeLines(c("# Example", "", "example repo"), file.path(t, "README.md"))
+  helper_add_git(t)
+}
+
+
+create_new_commit <- function(path, new_file = "new", message = "new message") {
+  writeLines("new file", file.path(path, new_file))
+  gert::git_add(".", repo = path)
+  user <- "author <author@example.com>"
+  gert::git_commit(message, author = user, committer = user, repo = path)
+}
+
+
+create_new_branch <- function(path, branch_name = "other") {
+  initial_branch <- gert::git_branch(repo = path)
+  gert::git_branch_create(branch_name, repo = path)
+  commit_sha <- create_new_commit(path, branch_name)
+  gert::git_branch_checkout(initial_branch, repo = path)
+  list(branch = branch_name, sha = commit_sha)
+}

tests/testthat/test-api.R

@@ -21,30 +21,36 @@ test_that("Can construct the api", {
 
 
 test_that("can list orderly reports", {
-  path <- test_prepare_orderly_example(c("data", "parameters"))
-  repo <- helper_add_git(path)
-  endpoint <- orderly_runner_endpoint("GET", "/report/list", path)
+  repo <- test_prepare_orderly_remote_example(c("data", "parameters"))
+  endpoint <- orderly_runner_endpoint("GET", "/report/list", repo$local)
 
-  res <- endpoint$run(repo$branch)
+  res <- endpoint$run(gert::git_branch(repo$local))
   expect_equal(res$status_code, 200)
   expect_setequal(res$data$name, c("data", "parameters"))
   expect_true(all(res$data$updated_time > (Sys.time() - 100)))
-
-  ## Delete a report on a 2nd branch
-  gert::git_branch_create("other", repo = path)
-  unlink(file.path(path, "src", "data"), recursive = TRUE)
-  gert::git_add(".", repo = path)
-  sha <- gert::git_commit("Remove data report", repo = path,
+  expect_false(all(res$data$has_modifications))
+
+  ## Add a report on a 2nd branch
+  gert::git_branch_create("other", repo = repo$local)
+  fs::dir_copy(file.path(repo$local, "src", "parameters"), 
+               file.path(repo$local, "src", "parameters2"))
+  gert::git_add(".", repo = repo$local)
+  sha <- gert::git_commit("Add report data2", repo = repo$local,
                           author = "Test User <test.user@example.com>")
 
   ## Can list items from this sha
   other_res <- endpoint$run(sha)
   expect_equal(other_res$status_code, 200)
-  expect_equal(other_res$data$name, "parameters")
+  params2 <- other_res$data[other_res$data$name == "parameters2", ]
+  existing <- other_res$data[other_res$data$name != "parameters2", ]
+  expect_equal(existing, res$data)
+  expect_equal(nrow(params2), 1)
+  expect_true(params2$has_modifications)
 
   ## We can still see all reports on main branch
-  first_commit_res <- endpoint$run(repo$sha)
+  commits <- gert::git_log(repo = repo$local)$commit
+  first_commit <- commits[length(commits)]
+  first_commit_res <- endpoint$run(first_commit)
   expect_equal(first_commit_res$status_code, 200)
-  expect_setequal(first_commit_res$data$name, 
-                  c("data", "parameters"))
+  expect_equal(first_commit_res$data, res$data)
 })

tests/testthat/test-git.R

@@ -0,0 +1,50 @@
+test_that("handle failure", {
+  testthat::skip_on_cran()
+  repo <- initialise_git_repo()
+  r <- git_run("unknown-command", repo = repo$path)
+  expect_false(r$success)
+  expect_error(
+    git_run("unknown-command", repo = repo$path, check = TRUE),
+    r$output, fixed = TRUE)
+})
+
+
+test_that("can get default branch when remote origin is set", {
+  testthat::skip_on_cran()
+  repo <- initialise_git_repo()
+  expect_null(git_get_default_branch(repo$path))
+  git_run(c("symbolic-ref",
+            "refs/remotes/origin/HEAD",
+            "refs/remotes/origin/main"),
+          repo = repo$path)
+  expect_equal(git_get_default_branch(repo$path), "refs/remotes/origin/main")
+})
+
+
+test_that("can get files which have been modified", {
+  testthat::skip_on_cran()
+  repo <- test_prepare_orderly_remote_example("data")
+  copy_examples("parameters", repo$local)
+  gert::git_add(".", repo = repo$local)
+  user <- "author <author@example.com>"
+  gert::git_commit("add parameters", author = user, committer = user, 
+                   repo = repo$local)
+
+  log <- gert::git_log(repo = repo$local)
+  expect_equal(git_get_modified(log$commit[[2]], repo = repo$local),
+               character(0))
+  expect_equal(git_get_modified(log$commit[[1]], repo = repo$local),
+               "src/parameters/orderly.R")
+  expect_equal(git_get_modified(log$commit[[1]], relative = "src/", 
+                                repo = repo$local),
+               "parameters/orderly.R")
+  expect_equal(git_get_modified(log$commit[[1]], base = log$commit[[2]],
+                                repo = repo$local),
+               "src/parameters/orderly.R")
+  expect_equal(git_get_modified(log$commit[[2]], base = log$commit[[1]],
+                                repo = repo$local),
+               character(0))
+  expect_equal(git_get_modified(log$commit[[2]], base = log$commit[[2]],
+                                repo = repo$local),
+               character(0))
+})

tests/testthat/test-util.R

@@ -4,3 +4,17 @@ test_that("null-or-value works", {
   expect_equal(NULL %||% NULL, NULL)
   expect_equal(NULL %||% 2, 2)
 })
+
+
+test_that("first_dirname gets the first dir part of the filename", {
+  expect_equal(
+    first_dirname(c("test/file/name.txt", "test", ".", "testing/file.txt")),
+    c("test", "test", ".", "testing"))
+})
+
+
+test_that("sys_which", {
+  prog <- "a-path-that-does-not-exist"
+  expect_error(sys_which(prog),
+               "Did not find 'a-path-that-does-not-exist'")
+})

tests/testthat/test-zzz-e2e.R

@@ -19,7 +19,7 @@ test_that("can run server", {
 })
 
 test_that("can list reports", {
-  r <- bg$request("GET", "/report/list?hash=HEAD")
+  r <- bg$request("GET", "/report/list?ref=HEAD")
   expect_equal(httr::status_code(r), 200)
 
   dat <- httr::content(r)