Allow custom locations to be added

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 = "[email protected]"),
              person("Robert", "Ashton", role = "aut"),

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
 }
 

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,

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})$"
 
 

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]])
+}

inst/outpack/schema/config.json

@@ -57,7 +57,7 @@
                         "type": "number"
                     },
                     "type": {
-                        "enum": ["http", "local", "orphan", "path"]
+                        "type": "string"
                     }
                 },
                 "required": ["name", "id", "priority", "type"]

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)))
+})

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'")
+})