From becd209b808a36f477e54f9a1374ed4f6710506e Mon Sep 17 00:00:00 2001 From: Rich FitzJohn Date: Fri, 7 Jul 2023 16:29:14 +0100 Subject: [PATCH] Allow custom locations to be added --- DESCRIPTION | 2 +- R/outpack_config.R | 10 ++++- R/outpack_location.R | 34 +++++++++++++++- R/outpack_misc.R | 2 +- R/util.R | 10 +++++ inst/outpack/schema/config.json | 2 +- man/outpack_location_add.Rd | 15 +++++++ tests/testthat/test-outpack-location.R | 56 ++++++++++++++++++++++++++ tests/testthat/test-util.R | 12 ++++++ 9 files changed, 137 insertions(+), 6 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 72467985..9c897d06 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: orderly2 Title: Orderly Next Generation -Version: 1.99.1 +Version: 1.99.2 Authors@R: c(person("Rich", "FitzJohn", role = c("aut", "cre"), email = "rich.fitzjohn@gmail.com"), person("Robert", "Ashton", role = "aut"), diff --git a/R/outpack_config.R b/R/outpack_config.R index 6be5b587..57606df9 100644 --- a/R/outpack_config.R +++ b/R/outpack_config.R @@ -217,8 +217,14 @@ config_serialise <- function(config, path) { config$logging <- lapply(config$logging, scalar) prepare_location <- function(loc) { + args <- loc$args[[1]] + if (length(args) == 0) { + args <- set_names(list(), character()) + } else { + args <- lapply(args, scalar) + } c(lapply(loc[setdiff(names(loc), "args")], scalar), - list(args = lapply(loc$args[[1]], scalar))) + list(args = args)) } config$location <- lapply(seq_len(nrow(config$location)), function(i) { prepare_location(config$location[i, ]) @@ -229,8 +235,8 @@ config_serialise <- function(config, path) { config_update <- function(config, root) { - root$config <- config config_write(config, root$path) + root$config <- config root } diff --git a/R/outpack_location.R b/R/outpack_location.R index e585057f..b9b0223b 100644 --- a/R/outpack_location.R +++ b/R/outpack_location.R @@ -28,6 +28,21 @@ ##' * `url`: The location of the server, including protocol, for ##' example `http://example.com:8080` ##' +##' **Custom locations**: +##' +##' All outpack implementations are expected to support path and http +##' locations, with the standard arguments above. But we expect that +##' some implementations will support custom locations, and that the +##' argument lists for these may vary between implementations. To +##' allow this, you can pass a location of type "custom" with a list +##' of arguments. We expect an argument 'driver' to be present among +##' this list. For an example of this in action, see the +##' [`outpack.sharepoint`](https://mrc-ide.github.io/outpack.sharepoint) +##' package. +##' +##' *Be warned that we may change this interface in future, in which +##' case you may need to update your configuration.* +##' ##' @section Warning: ##' ##' The API here may change as we move to support different types of @@ -376,7 +391,18 @@ location_driver <- function(location_id, root) { args <- root$config$location$args[[i]] switch(type, path = outpack_location_path$new(args$path), - http = outpack_location_http$new(args$url)) + http = outpack_location_http$new(args$url), + custom = outpack_location_custom(args)) +} + + +outpack_location_custom <- function(args) { + driver <- check_symbol_from_str(args$driver, "args$driver") + driver <- getExportedValue(driver$namespace, driver$symbol) + if (inherits(driver, "R6ClassGenerator")) { + driver <- driver$new + } + do.call(driver, args[names(args) != "driver"]) } @@ -575,6 +601,8 @@ new_location_entry <- function(name, priority, type, args) { required <- "path" } else if (type == "http") { required <- "url" + } else if (type == "custom") { + required <- "driver" } if (length(args) > 0) { assert_is(args, "list") @@ -586,6 +614,10 @@ new_location_entry <- function(name, priority, type, args) { paste(squote(msg), collapse = ", "))) } + if (type == "custom") { + check_symbol_from_str(args$driver, "args$driver") + } + location_id <- paste(as.character(openssl::rand_bytes(4)), collapse = "") ## NOTE: make sure this matches the order in config_read data_frame(name = name, diff --git a/R/outpack_misc.R b/R/outpack_misc.R index ae4a930e..c29af665 100644 --- a/R/outpack_misc.R +++ b/R/outpack_misc.R @@ -2,7 +2,7 @@ local <- "local" orphan <- "orphan" location_reserved_name <- c(local, orphan) -location_types <- c(local, orphan, "path", "http") +location_types <- c(local, orphan, "path", "http", "custom") re_id <- "^([0-9]{8}-[0-9]{6}-[[:xdigit:]]{8})$" diff --git a/R/util.R b/R/util.R index 2015d154..1fb339f7 100644 --- a/R/util.R +++ b/R/util.R @@ -373,3 +373,13 @@ error_near_match <- function(title, x, hint, join, possibilities) { } err } + + +check_symbol_from_str <- function(str, name) { + assert_scalar_character(str, name) + dat <- strsplit(str, "(?<=[^:])::(?=[^:])", perl = TRUE)[[1]] + if (length(dat) != 2) { + stop(sprintf("Expected fully qualified name for '%s'", name)) + } + list(namespace = dat[[1]], symbol = dat[[2]]) +} diff --git a/inst/outpack/schema/config.json b/inst/outpack/schema/config.json index aeef99f0..1ccb6bcd 100644 --- a/inst/outpack/schema/config.json +++ b/inst/outpack/schema/config.json @@ -57,7 +57,7 @@ "type": "number" }, "type": { - "enum": ["http", "local", "orphan", "path"] + "type": "string" } }, "required": ["name", "id", "priority", "type"] diff --git a/man/outpack_location_add.Rd b/man/outpack_location_add.Rd index 86fe7a15..259b8253 100644 --- a/man/outpack_location_add.Rd +++ b/man/outpack_location_add.Rd @@ -65,6 +65,21 @@ authentication. \item \code{url}: The location of the server, including protocol, for example \verb{http://example.com:8080} } + +\strong{Custom locations}: + +All outpack implementations are expected to support path and http +locations, with the standard arguments above. But we expect that +some implementations will support custom locations, and that the +argument lists for these may vary between implementations. To +allow this, you can pass a location of type "custom" with a list +of arguments. We expect an argument 'driver' to be present among +this list. For an example of this in action, see the +\href{https://mrc-ide.github.io/outpack.sharepoint}{\code{outpack.sharepoint}} +package. + +\emph{Be warned that we may change this interface in future, in which +case you may need to update your configuration.} } \section{Warning}{ diff --git a/tests/testthat/test-outpack-location.R b/tests/testthat/test-outpack-location.R index ab701f45..0a85ca0c 100644 --- a/tests/testthat/test-outpack-location.R +++ b/tests/testthat/test-outpack-location.R @@ -735,3 +735,59 @@ test_that("validate arguments to path locations", { "Fields missing from args: 'url'") expect_equal(outpack_location_list(root = root), "local") }) + + +test_that("can load a custom location driver", { + skip_if_not_installed("mockery") + mock_driver <- mockery::mock("value") + mock_gev <- mockery::mock(mock_driver) + mockery::stub(outpack_location_custom, "getExportedValue", mock_gev) + args <- list(driver = "foo::bar", a = 1, b = "other") + expect_equal(outpack_location_custom(args), "value") + + mockery::expect_called(mock_gev, 1) + expect_equal(mockery::mock_args(mock_gev)[[1]], list("foo", "bar")) + + mockery::expect_called(mock_driver, 1) + expect_equal(mockery::mock_args(mock_driver)[[1]], list(a = 1, b = "other")) +}) + + +test_that("can load a custom location driver using an R6 generator", { + skip_if_not_installed("mockery") + mock_driver <- structure( + list(new = mockery::mock("value")), + class = "R6ClassGenerator") + mock_gev <- mockery::mock(mock_driver) + mockery::stub(outpack_location_custom, "getExportedValue", mock_gev) + args <- list(driver = "foo::bar", a = 1, b = "other") + expect_equal(outpack_location_custom(args), "value") + + mockery::expect_called(mock_gev, 1) + expect_equal(mockery::mock_args(mock_gev)[[1]], list("foo", "bar")) + + mockery::expect_called(mock_driver$new, 1) + expect_equal(mockery::mock_args(mock_driver$new)[[1]], + list(a = 1, b = "other")) +}) + + +test_that("can add a custom outpack location", { + skip_if_not_installed("mockery") + root <- create_temporary_root() + args <- list(driver = "foo::bar", a = 1, b = 2) + outpack_location_add("a", "custom", args = args, root = root) + + loc <- as.list(root$config$location[2, ]) + expect_equal(loc$name, "a") + expect_equal(loc$type, "custom") + expect_equal(loc$args[[1]], list(driver = "foo::bar", a = 1, b = 2)) + + mock_outpack_location_custom <- mockery::mock("value") + mockery::stub(location_driver, "outpack_location_custom", + mock_outpack_location_custom) + expect_equal(location_driver(loc$id, root), "value") + mockery::expect_called(mock_outpack_location_custom, 1) + expect_equal(mockery::mock_args(mock_outpack_location_custom)[[1]], + list(list(driver = "foo::bar", a = 1, b = 2))) +}) diff --git a/tests/testthat/test-util.R b/tests/testthat/test-util.R index 86d1fd97..779abda5 100644 --- a/tests/testthat/test-util.R +++ b/tests/testthat/test-util.R @@ -165,3 +165,15 @@ test_that("can get near matches", { near_match("apple", x, 2, 3), c("apples", "applez", "appell")) }) + + +test_that("validate namespaced symbol strings", { + expect_equal(check_symbol_from_str("a::b", "x"), + list(namespace = "a", symbol = "b")) + expect_error(check_symbol_from_str("b", "x"), + "Expected fully qualified name for 'x'") + expect_error(check_symbol_from_str("a:::b", "x"), + "Expected fully qualified name for 'x'") + expect_error(check_symbol_from_str("a::b::c", "x"), + "Expected fully qualified name for 'x'") +})