Merge pull request #188 from mrc-ide/mrc-5900

Verify location before addition

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: orderly2
 Title: Orderly Next Generation
-Version: 1.99.48
+Version: 1.99.49
 Authors@R: c(person("Rich", "FitzJohn", role = c("aut", "cre"),
                     email = "[email protected]"),
              person("Robert", "Ashton", role = "aut"),

R/location.R

@@ -75,26 +75,27 @@
 ##' @param args Arguments to the location driver. The arguments here
 ##'   will vary depending on the type used, see Details.
 ##'
+##' @param verify Logical, indicating if we should verify that the
+##'   location can be used before adding.
+##'
 ##' @inheritParams orderly_metadata
 ##'
 ##' @return Nothing
 ##' @export
-orderly_location_add <- function(name, type, args, root = NULL) {
+orderly_location_add <- function(name, type, args, verify = TRUE, root = NULL) {
   root <- root_open(root, require_orderly = FALSE)
-  assert_scalar_character(name, call = environment())
+  assert_scalar_character(name)
+  assert_scalar_logical(verify)
 
   if (name %in% location_reserved_name) {
     cli::cli_abort("Cannot add a location with reserved name '{name}'")
   }
 
   location_check_new_name(root, name, environment())
-  match_value(type, setdiff(location_types, location_reserved_name),
-              call = environment())
+  match_value(type, setdiff(location_types, location_reserved_name))
 
-  loc <- new_location_entry(name, type, args, call = environment())
   if (type == "path") {
     assert_scalar_character(args$path, name = "path")
-    root_open(args$path, require_orderly = FALSE)
   } else if (type == "http") {
     assert_scalar_character(args$url, name = "url")
   } else if (type == "packit") {
@@ -105,12 +106,23 @@ orderly_location_add <- function(name, type, args, root = NULL) {
     if (!is.null(args$token) && !is.null(args$save_token)) {
       cli::cli_abort("Cannot specify both 'token' and 'save_token'")
     }
+    if (is.null(args$save_token)) {
+      args$save_token <- is.null(args$token)
+    }
+  }
+  loc <- new_location_entry(name, type, args, call = environment())
+
+  if (verify) {
+    cli_alert_info("Testing location")
+    location_driver_create(type, args)$verify()
+    cli_alert_success("Location configured successfully")
   }
 
   config <- root$config
   config$location <- rbind(config$location, loc)
   rownames(config$location) <- NULL
   config_update(config, root)
+  cli_alert_success("Added location '{name}' ({type})")
   invisible()
 }
 
@@ -122,9 +134,9 @@ orderly_location_add <- function(name, type, args, root = NULL) {
 ##'   be unreliable.
 ##'
 ##' @export
-orderly_location_add_path <- function(name, path, root = NULL) {
+orderly_location_add_path <- function(name, path, verify = TRUE, root = NULL) {
   args <- list(path = path)
-  orderly_location_add(name, "path", args, root = root)
+  orderly_location_add(name, "path", args, verify = verify, root = root)
 }
 
 
@@ -134,9 +146,9 @@ orderly_location_add_path <- function(name, path, root = NULL) {
 ##'   example `http://example.com:8080`
 ##'
 ##' @export
-orderly_location_add_http <- function(name, url, root = NULL) {
+orderly_location_add_http <- function(name, url, verify = TRUE, root = NULL) {
   args <- list(url = url)
-  orderly_location_add(name, "http", args, root = root)
+  orderly_location_add(name, "http", args, verify = verify, root = root)
 }
 
 
@@ -153,9 +165,10 @@ orderly_location_add_http <- function(name, url, root = NULL) {
 ##'
 ##' @export
 orderly_location_add_packit <- function(name, url, token = NULL,
-                                        save_token = NULL, root = NULL) {
+                                        save_token = NULL,
+                                        verify = TRUE, root = NULL) {
   args <- list(url = url, token = token, save_token = save_token)
-  orderly_location_add(name, "packit", args, root = root)
+  orderly_location_add(name, "packit", args, verify = verify, root = root)
 }
 
 
@@ -483,6 +496,11 @@ location_driver <- function(location_name, root) {
   i <- match(location_name, root$config$location$name)
   type <- root$config$location$type[[i]]
   args <- root$config$location$args[[i]]
+  location_driver_create(type, args)
+}
+
+
+location_driver_create <- function(type, args) {
   location <- switch(type,
                      path = orderly_location_path$new,
                      http = orderly_location_http$new,
@@ -794,28 +812,16 @@ location_build_push_plan <- function(packet_id, location_name, root) {
 ## This validation probably will need generalising in future as we add
 ## new types. The trick is going to be making sure that we can support
 ## different location types in different target languages effectively.
-new_location_entry <- function(name, type, args, call = NULL) {
-  match_value(type, location_types, call = call)
-  required <- NULL
-  if (type == "path") {
-    required <- "path"
-  } else if (type == "http") {
-    required <- "url"
-  } else if (type == "packit") {
-    required <- "url"
-  } else if (type == "custom") {
-    required <- "driver"
-  }
+new_location_entry <- function(name, type, args, call = parent.frame()) {
+  match_value(type, location_types)
   if (length(args) > 0) {
-    assert_is(args, "list", call = call)
-    assert_named(args, call = call)
-  }
-  msg <- setdiff(required, names(args))
-  if (length(msg) > 0) {
-    cli::cli_abort("Field{?s} missing from args: {squote(msg)}")
+    assert_is(args, "list")
+    assert_named(args)
   }
-
   if (type == "custom") {
+    if (is.null(args$driver)) {
+      cli::cli_abort("Field missing from args: 'driver'")
+    }
     check_symbol_from_str(args$driver, "args$driver")
   }
 

R/location_http.R

@@ -8,6 +8,22 @@ orderly_location_http <- R6::R6Class(
       self$client <- outpack_http_client$new(url, authorise)
     },
 
+    verify = function() {
+      ## This should never end up triggering the assertion here as
+      ## http_client_handle_error() in the client will convert
+      ## unsuccessful requests into an error already, but this should
+      ## serve as a reasonable backstop.
+      ##
+      ## The act of making the request will force validation, which is
+      ## the most likely source of errors (along with getting the URL
+      ## wrong).
+      stopifnot(identical(self$client$request("/")$status, "success"))
+    },
+
+    authorise = function() {
+      self$client$authorise()
+    },
+
     list = function() {
       dat <- self$client$request("/metadata/list")$data
       data_frame(

R/location_packit.R

@@ -52,7 +52,7 @@ packit_authorisation <- function(base_url, token, save_token) {
   key <- rlang::hash(list(base_url = base_url, token = token))
 
   if (is.null(auth_cache[[key]])) {
-    cli::cli_alert_info("Logging in to {base_url}")
+    cli_alert_info("Logging in to {base_url}")
     if (is.null(token)) {
       token <- do_oauth_device_flow(base_url, cache_disk = save_token)
     }
@@ -62,7 +62,7 @@ packit_authorisation <- function(base_url, token, save_token) {
       login_url,
       function(r) http_body_json(r, list(token = scalar(token))))
 
-    cli::cli_alert_success("Logged in successfully")
+    cli_alert_success("Logged in successfully")
 
     auth_cache[[key]] <- list("Authorization" = paste("Bearer", res$token))
   }

R/location_path.R

@@ -10,6 +10,10 @@ orderly_location_path <- R6::R6Class(
       private$root <- root_open(path, require_orderly = FALSE)
     },
 
+    verify = function() {
+      ## No implementation needed as we verify the root in initialize()
+    },
+
     list = function() {
       private$root$index$location(local)[c("packet", "time", "hash")]
     },

tests/testthat/test-location-packit.R

@@ -1,4 +1,5 @@
 test_that("can authenticate with existing GitHub token", {
+  withr::local_options(orderly.quiet = FALSE)
   clear_auth_cache()
   withr::defer(clear_auth_cache())
 
@@ -43,6 +44,7 @@ test_that("can authenticate with existing Packit token", {
 
 
 test_that("can authenticate using device flow", {
+  withr::local_options(orderly.quiet = FALSE)
   clear_auth_cache()
   withr::defer(clear_auth_cache())
 
@@ -70,7 +72,9 @@ test_that("can authenticate using device flow", {
   expect_equal(args[[1]]$body$type, "json")
 })
 
+
 test_that("location_packit uses authentication", {
+  withr::local_options(orderly.quiet = FALSE)
   clear_auth_cache()
   withr::defer(clear_auth_cache())