Merge pull request #4 from mrc-ide/mrc-5087

mrc 5087: Add endpoint to list parameters on a report

DESCRIPTION

@@ -18,7 +18,7 @@ Imports:
     gert (>= 2.0.1),
     ids,
     jsonlite,
-    orderly2,
+    orderly2 (>= 1.99.13),
     porcelain,
     R6,
     redux,

R/api.R

@@ -37,7 +37,7 @@ root <- function() {
 ##'   state root :: root
 report_list <- function(root, ref) {
   contents <- gert::git_ls(root, ref = ref)
-  re <- "^src/([^/]+)/(\\1|orderly)\\.(yml|R)$"
+  re <- "^src/([^/]+)/(\\1|orderly)\\.R$"
   nms <- sub(re, "\\1", 
              grep(re, contents$path, value = TRUE, perl = TRUE),
              perl = TRUE)
@@ -54,3 +54,19 @@ report_list <- function(root, ref) {
              updated_time = updated_time,
              has_modifications = has_modifications)
 }
+
+
+##' @porcelain
+##'   GET /report/<name:string>/parameters => json(report_parameters)
+##'   query ref :: string
+##'   state root :: root
+report_parameters <- function(root, ref, name) {
+  params <- get_report_parameters(name, ref, root)
+  lapply(names(params), function(param_name) {
+    value <- params[[param_name]]
+    list(
+      name = scalar(param_name),
+      value = if (is.null(value)) value else scalar(as.character(value))
+    )
+  })
+}

R/porcelain.R

@@ -18,5 +18,15 @@
         porcelain::porcelain_state(root = state$root),
         returning = porcelain::porcelain_returning_json("report_list"),
         validate = validate)
+    },
+    "GET /report/<name:string>/parameters" = function(state, validate) {
+      porcelain::porcelain_endpoint$new(
+        "GET",
+        "/report/<name:string>/parameters",
+        report_parameters,
+        porcelain::porcelain_input_query(ref = "string"),
+        porcelain::porcelain_state(root = state$root),
+        returning = porcelain::porcelain_returning_json("report_parameters"),
+        validate = validate)
     })
 }

R/reports.R

@@ -0,0 +1,23 @@
+get_report_parameters <- function(name, ref, root) {
+  path <- get_orderly_script_path(name, ref, root)
+  sha <- gert::git_commit_id(ref, repo = root)
+  contents <- git_run(
+    c("show", sprintf("%s:%s", sha, path)), repo = root, check = TRUE
+  )$output
+  exprs <- parse(text = contents)
+  orderly2::orderly_parse_expr(exprs, filename = basename(path))$parameters
+}
+
+
+get_orderly_script_path <- function(name, ref, root) {
+  contents <- gert::git_ls(root, ref = ref)
+  re <- sprintf("^src/%s/(%s|orderly)\\.R$", name, name)
+  matches <- grep(re, contents$path, value = TRUE, perl = TRUE)
+  if (length(matches) != 1) {
+    num <- length(matches)
+    cli::cli_abort(
+      c("Found {num} valid orderly script{?s}. There must be one and only one.",
+        setNames(matches, rep("*", length(matches)))))
+  }
+  matches
+}

inst/schema/report_parameters.json

@@ -0,0 +1,13 @@
+{
+    "$schema": "http://json-schema.org/draft-07/schema#",
+    "type": "array",
+    "items": {
+        "type": "object",
+        "properties": {
+            "name": { "type": "string" },
+            "value": { "type": [ "string", "null" ] }
+        },
+        "required": [ "name", "value" ],
+        "additionalProperties": false
+    }
+}

tests/testthat/helper-orderly-runner.R

@@ -69,14 +69,11 @@ copy_examples <- function(examples, path_src) {
 
 helper_add_git <- function(path) {
   gert::git_init(path)
-  gert::git_add(".", repo = path)
-  user <- "author <author@example.com>"
-  sha <- gert::git_commit("initial", author = user, committer = user,
-                          repo = path)
+  sha <- git_add_and_commit(path)
   branch <- gert::git_branch(repo = path)
   url <- "https://example.com/git"
   gert::git_remote_add(url, repo = path)
-  list(path = path, user = user, branch = branch, sha = sha, url = url)
+  list(path = path, branch = branch, sha = sha, url = url)
 }
 
 
@@ -88,11 +85,16 @@ initialise_git_repo <- function() {
 }
 
 
-create_new_commit <- function(path, new_file = "new", message = "new message") {
-  writeLines("new file", file.path(path, new_file))
+git_add_and_commit <- function(path) {
   gert::git_add(".", repo = path)
   user <- "author <author@example.com>"
-  gert::git_commit(message, author = user, committer = user, repo = path)
+  gert::git_commit("new commit", author = user, committer = user, repo = path)
+}
+
+
+create_new_commit <- function(path, new_file = "new") {
+  writeLines("new file", file.path(path, new_file))
+  git_add_and_commit(path)
 }
 
 

tests/testthat/test-api.R

@@ -34,9 +34,7 @@ test_that("can list orderly reports", {
   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>")
+  sha <- git_add_and_commit(repo$local)
 
   ## Can list items from this sha
   other_res <- endpoint$run(sha)
@@ -54,3 +52,22 @@ test_that("can list orderly reports", {
   expect_equal(first_commit_res$status_code, 200)
   expect_equal(first_commit_res$data, res$data)
 })
+
+
+test_that("can get parameters for a report", {
+  repo <- test_prepare_orderly_remote_example(c("data", "parameters"))
+  endpoint <- orderly_runner_endpoint("GET", "/report/<name:string>/parameters", 
+                                      repo$local)
+
+  res <- endpoint$run("HEAD", "data")
+  expect_equal(res$status_code, 200)
+  expect_equal(res$data, list())
+
+  res <- endpoint$run("HEAD", "parameters")
+  expect_equal(res$status_code, 200)
+  expect_equal(res$data, list(
+    list(name = scalar("a"), value = NULL),
+    list(name = scalar("b"), value = scalar("2")),
+    list(name = scalar("c"), value = NULL))
+  )
+})

tests/testthat/test-git.R

@@ -25,10 +25,7 @@ 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)
+  git_add_and_commit(repo$local)
 
   log <- gert::git_log(repo = repo$local)
   expect_equal(git_get_modified(log$commit[[2]], repo = repo$local),

tests/testthat/test-reports.R

@@ -0,0 +1,45 @@
+test_that("can get orderly script name", {
+  root <- test_prepare_orderly_example(c("data", "parameters"))
+  git_info <- helper_add_git(root)
+  expect_equal(get_orderly_script_path("data", "HEAD", root), "src/data/data.R")
+  expect_equal(get_orderly_script_path("parameters", "HEAD", root), 
+               "src/parameters/orderly.R")
+
+  file.copy(file.path(root, "src", "data", "data.R"),
+            file.path(root, "src", "data", "orderly.R"))
+  git_add_and_commit(root)
+
+  expect_error(
+    get_orderly_script_path("data", "HEAD", root), 
+    "Found 2 valid orderly scripts. There must be one and only one.")
+})
+
+
+test_that("can get report parameters", {
+  root <- test_prepare_orderly_example(c("data", "parameters"))
+  git_info <- helper_add_git(root)
+
+  params <- get_report_parameters("data", "HEAD", root)
+  expect_null(params)
+
+  params <- get_report_parameters("parameters", "HEAD", root)
+  expect_equal(params, list(a = NULL,
+                            b = 2,
+                            c = NULL))
+
+  ## Works with a specific git hash
+  params_src <- file.path(root, "src", "parameters", "orderly.R")
+  contents <- readLines(params_src)
+  contents <- c("orderly2::orderly_parameters(a = 'default', b = 2, c = NULL)", 
+                contents[-1])
+  writeLines(contents, params_src)
+  sha <- git_add_and_commit(root)
+
+  params_new <- get_report_parameters("parameters", sha, root)
+  expect_equal(params_new, list(a = "default",
+                                b = 2,
+                                c = NULL))
+
+  params_old <- get_report_parameters("parameters", git_info$sha, root)
+  expect_equal(params, params_old)
+})

tests/testthat/test-util.R

@@ -17,4 +17,4 @@ 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

@@ -18,6 +18,7 @@ test_that("can run server", {
                package_version_string("orderly.runner"))
 })
 
+
 test_that("can list reports", {
   r <- bg$request("GET", "/report/list?ref=HEAD")
   expect_equal(httr::status_code(r), 200)
@@ -28,3 +29,26 @@ test_that("can list reports", {
   reports <- vcapply(dat$data, "[[", "name")
   expect_true(all(c("data", "parameters") %in% reports))
 })
+
+
+test_that("can get parameters", {
+  r <- bg$request("GET", "/report/data/parameters?ref=HEAD")
+  expect_equal(httr::status_code(r), 200)
+
+  dat <- httr::content(r)
+  expect_equal(dat$status, "success")
+  expect_null(dat$errors)
+  expect_equal(dat$data, list())
+
+  r <- bg$request("GET", "/report/parameters/parameters?ref=HEAD")
+  expect_equal(httr::status_code(r), 200)
+
+  dat <- httr::content(r)
+  expect_equal(dat$status, "success")
+  expect_null(dat$errors)
+  expect_equal(dat$data, list(
+    list(name = "a", value = NULL),
+    list(name = "b", value = "2"),
+    list(name = "c", value = NULL)
+  ))
+})