tests/testthat/test-location.R

In orderly: Lightweight Reproducible Reporting

test_that("No locations except local by default", {
  root <- create_temporary_root()
  expect_equal(orderly_location_list(root = root), "local")
  expect_equal(
    orderly_location_list(TRUE, root = root),
    data_frame(name = "local",
               type = "local",
               args = I(list(set_names(list(), character())))))
})


test_that("Can add a location", {
  root <- list()
  for (name in c("a", "b", "c")) {
    root[[name]] <- create_temporary_root()
  }

  orderly_location_add_path("b", path = root$b$path, root = root$a)
  expect_setequal(orderly_location_list(root = root$a), c("local", "b"))

  orderly_location_add_path("c", path = root$c$path, root = root$a)
  expect_setequal(orderly_location_list(root = root$a), c("local", "b", "c"))

  res <- orderly_location_list(verbose = TRUE, root = root$a)
  expect_equal(res$name, c("local", "b", "c"))
  expect_equal(res$type, c("local", "path", "path"))
  expect_equal(res$args, I(list(set_names(list(), character()),
                                list(path = root$b$path),
                                list(path = root$c$path))))
})


test_that("Can't add a location with reserved name", {
  root <- create_temporary_root()
  upstream <- create_temporary_root()

  expect_error(
    orderly_location_add_path("local", path = upstream$path, root = root),
    "Cannot add a location with reserved name 'local'")
})


test_that("Can't add a location with existing name", {
  root <- list()
  for (name in c("a", "b", "c")) {
    root[[name]] <- create_temporary_root()
  }

  orderly_location_add_path("upstream", path = root$b$path, root = root$a)
  expect_error(
    orderly_location_add_path("upstream", path = root$c$path, root = root$a),
    "A location with name 'upstream' already exists")
  expect_equal(orderly_location_list(root = root$a),
               c("local", "upstream"))
})


test_that("Require that (for now) locations must be paths", {
  root <- create_temporary_root()
  expect_equal(orderly_location_list(root = root), "local")

  other <- temp_file()
  expect_error(
    orderly_location_add_path("other", other, root = root),
    "Directory does not exist:")
  fs::dir_create(other)
  expect_error(
    orderly_location_add_path("other", other, root = root),
    "Did not find existing orderly (or outpack) root in",
    fixed = TRUE)
})


test_that("Can rename a location", {
  root <- list()
  for (name in c("a", "b")) {
    root[[name]] <- create_temporary_root()
  }

  orderly_location_add_path("b", path = root$b$path, root = root$a)
  expect_setequal(orderly_location_list(root = root$a), c("local", "b"))

  orderly_location_rename("b", "c", root = root$a)
  expect_setequal(orderly_location_list(root = root$a), c("local", "c"))
  expect_setequal(orderly_config(root$a)$location$name, c("local", "c"))
})


test_that("Can't rename a location using an existent name", {
  root <- list()
  for (name in c("a", "b", "c")) {
    root[[name]] <- create_temporary_root()
  }

  orderly_location_add_path("b", path = root$b$path, root = root$a)
  orderly_location_add_path("c", path = root$c$path, root = root$a)

  expect_error(orderly_location_rename("b", "c", root$a),
               "A location with name 'c' already exists")
  expect_error(orderly_location_rename("b", "local", root$a),
               "A location with name 'local' already exists")
})


test_that("Can't rename a  non-existent location", {
  root <- create_temporary_root()
  expect_equal(orderly_location_list(root = root), "local")

  expect_error(orderly_location_rename("a", "b", root),
               "No location with name 'a' exists")
})


test_that("Can't rename default locations", {
  root <- create_temporary_root()

  expect_error(orderly_location_rename("local", "desktop", root),
               "Cannot rename default location 'local'")
  expect_error(orderly_location_rename("orphan", "removed", root),
               "Cannot rename default location 'orphan'")
})


test_that("Can remove a location", {
  root <- list()
  for (name in c("a", "b", "c")) {
    root[[name]] <- create_temporary_root()
  }

  orderly_location_add_path("b", path = root$b$path, root = root$a)
  orderly_location_add_path("c", path = root$c$path, root = root$a)
  expect_setequal(orderly_location_list(root = root$a), c("local", "b", "c"))

  id <- create_random_packet(root$b)
  orderly_location_fetch_metadata(root = root$a)

  # remove a location without packets
  expect_silent(orderly_location_remove("c", root = root$a))
  expect_setequal(orderly_location_list(root = root$a),
                  c("local", "b"))

  # remove a location with packets
  expect_message(orderly_location_remove("b", root = root$a),
                 "Orphaning 1 packet")
  expect_setequal(orderly_location_list(root = root$a),
                  c("local", "orphan"))

  config <- orderly_config(root$a)
  expect_equal(root$a$index$data()$location$location, "orphan")
})


test_that("Removing a location orphans packets only from that location", {
  root <- list()
  for (name in c("a", "b", "c")) {
    root[[name]] <- create_temporary_root()
  }

  orderly_location_add_path("c", path = root$c$path, root = root$b)
  orderly_location_add_path("b", path = root$b$path, root = root$a)
  orderly_location_add_path("c", path = root$c$path, root = root$a)
  expect_setequal(orderly_location_list(root = root$a), c("local", "b", "c"))
  expect_setequal(orderly_location_list(root = root$b), c("local", "c"))

  id1 <- create_random_packet(root$c)
  id2 <- create_random_packet(root$b)
  orderly_location_fetch_metadata(root = root$b)
  suppressMessages(orderly_location_pull(id1, root = root$b))
  orderly_location_fetch_metadata(root = root$a)

  # id1 should now be found in both b and c
  index <- root$a$index$data()
  expect_equal(index$location$location[index$location$packet == id1],
               c("b", "c"))

  # id2 should just be found in b
  expect_equal(index$location$location[index$location$packet == id2], "b")

  # remove location b
  expect_message(
    orderly_location_remove("b", root = root$a),
    "Orphaning 1 packet")
  expect_setequal(orderly_location_list(root = root$a),
                  c("local", "orphan", "c"))

  # id1 should now only be found in c
  index <- root$a$index$data()
  expect_equal(index$location$location[index$location$packet == id1], "c")

  # id2 should be orphaned
  expect_equal(index$location$location[index$location$packet == id2], "orphan")
})


test_that("re-adding a location de-orphans packets", {
  root <- list()
  for (name in c("a", "b", "c")) {
    root[[name]] <- create_temporary_root()$path
  }

  orderly_location_add_path("b", path = root$b, root = root$a)
  orderly_location_add_path("c", path = root$c, root = root$a)

  id_b <- replicate(2, create_random_packet(root$b))
  id_c <- replicate(3, create_random_packet(root$c))
  orderly_location_fetch_metadata(root = root$a)

  expect_message(orderly_location_remove("b", root = root$a),
                 "Orphaning 2 packets")
  expect_equal(nrow(root_open(root$a, FALSE)$index$location(orphan)), 2)
  expect_message(orderly_location_remove("c", root = root$a),
                 "Orphaning 3 packets")
  expect_equal(nrow(root_open(root$a, FALSE)$index$location(orphan)), 5)

  orderly_location_add_path("b", path = root$b, root = root$a)
  expect_message(orderly_location_fetch_metadata(root = root$a),
                 "De-orphaning 2 packets")

  expect_equal(nrow(root_open(root$a, FALSE)$index$location(orphan)), 3)
})


test_that("Can't remove default locations", {
  root <- create_temporary_root()

  expect_error(orderly_location_remove("local",  root),
               "Cannot remove default location 'local'")
  expect_error(orderly_location_remove("orphan", root),
               "Cannot remove default location 'orphan'")
})


test_that("Can't remove non-existent location", {
  root <- create_temporary_root()

  expect_error(orderly_location_remove("b",  root),
               "No location with name 'b' exists")
})


test_that("can pull metadata from a file base location", {
  root_upstream <- create_temporary_root(use_file_store = TRUE)

  ids <- vcapply(1:3, function(i) create_random_packet(root_upstream$path))
  root_downstream <- create_temporary_root(use_file_store = TRUE)

  orderly_location_add_path("upstream", path = root_upstream$path,
                            root = root_downstream)
  expect_equal(orderly_location_list(root = root_downstream),
               c("local", "upstream"))

  orderly_location_fetch_metadata("upstream", root = root_downstream)

  ## Sensible tests here will be much easier to write once we have a
  ## decent query interface.
  index <- root_downstream$index$data()
  expect_length(index$metadata, 3)
  expect_setequal(names(index$metadata), ids)
  expect_mapequal(index$metadata, root_upstream$index$data()$metadata)

  expect_s3_class(index$location, "data.frame")
  expect_setequal(index$location$packet, ids)
  expect_equal(index$location$location, rep("upstream", 3))
})


test_that("can pull empty metadata", {
  root_upstream <- create_temporary_root(use_file_store = TRUE)
  root_downstream <- create_temporary_root(use_file_store = TRUE)

  orderly_location_add_path("upstream", path = root_upstream$path,
                            root = root_downstream)
  orderly_location_fetch_metadata("upstream", root = root_downstream)

  index <- root_downstream$index$data()
  expect_length(index$metadata, 0)
  ## This is what we need to improve, everywhere
  expect_s3_class(index$location, "data.frame")
})


test_that("pull metadata from subset of locations", {
  root <- list()
  root$a <- create_temporary_root(use_file_store = TRUE)
  for (name in c("x", "y", "z")) {
    root[[name]] <- create_temporary_root(use_file_store = TRUE)
    orderly_location_add_path(name, path = root[[name]]$path, root = root$a)
  }

  expect_equal(orderly_location_list(root = root$a),
               c("local", "x", "y", "z"))

  ## NOTE: This is a little slow (0.2s) with about half of that coming
  ## from the call to utils::sessionInfo which gets bogged down
  ## reading DESCRIPTION files from disk - we might be better off
  ## replacing that with something a bit simpler. Also seeing some
  ## bottlenecks coming potentially from fs (fs::dir_create - looks
  ## like a known bug)
  ids <- list()
  for (name in c("x", "y", "z")) {
    ids[[name]] <- vcapply(1:3, function(i) create_random_packet(root[[name]]))
  }

  location_name <- c("x", "y", "z")

  orderly_location_fetch_metadata(c("x", "y"), root = root$a)
  index <- root$a$index$data()
  expect_setequal(names(index$metadata), c(ids$x, ids$y))
  expect_equal(index$location$location, rep(location_name[1:2], each = 3))
  expect_equal(index$metadata[ids$x],
               root$x$index$data()$metadata)
  expect_equal(index$metadata[ids$y],
               root$y$index$data()$metadata)

  orderly_location_fetch_metadata(root = root$a)
  index <- root$a$index$data()
  expect_setequal(names(index$metadata), c(ids$x, ids$y, ids$z))
  expect_equal(index$location$location, rep(location_name, each = 3))
  expect_equal(index$metadata[ids$z],
               root$z$index$data()$metadata)
})


test_that("Can't pull metadata from an unknown location", {
  root <- create_temporary_root()
  expect_error(
    orderly_location_fetch_metadata("upstream", root = root),
    "Unknown location: 'upstream'")
})


test_that("No-op to pull metadata from no locations", {
  root <- create_temporary_root()
  expect_silent(orderly_location_fetch_metadata("local", root = root))
  expect_silent(orderly_location_fetch_metadata(root = root))
})


test_that("Can pull metadata through chain of locations", {
  root <- list()
  for (name in c("a", "b", "c", "d")) {
    root[[name]] <- create_temporary_root()
  }

  ## More interesting topology, with a chain of locations, but d also
  ## knowing directly about an earlier location
  ## > a -> b -> c -> d
  ## >      `--------/
  orderly_location_add_path("a", path = root$a$path, root = root$b)
  orderly_location_add_path("b", path = root$b$path, root = root$c)
  orderly_location_add_path("b", path = root$b$path, root = root$d)
  orderly_location_add_path("c", path = root$c$path, root = root$d)

  ## Create a packet and make sure it's in both b and c
  id1 <- create_random_packet(root$a)
  orderly_location_fetch_metadata(root = root$b)
  suppressMessages(orderly_location_pull(id1, root = root$b))
  orderly_location_fetch_metadata(root = root$c)
  suppressMessages(orderly_location_pull(id1, root = root$c))

  ## And another in just 'c'
  id2 <- create_random_packet(root$c)

  ## Then when we pull from d it will simultaneously learn about the
  ## packet from both locations:
  orderly_location_fetch_metadata(root = root$d)
  index <- root$d$index$data()

  ## Metadata is correct
  expect_length(index$metadata, 2)
  expect_equal(names(index$metadata), c(id1, id2))
  expect_equal(index$metadata, root$c$index$data()$metadata)

  ## Location information contains both sources
  expect_equal(nrow(index$location), 3)
  expect_equal(index$location$packet, c(id1, id1, id2))

  expect_equal(index$location$location, c("b", "c", "c"))
})


test_that("can pull a packet from one location to another, using file store", {
  root <- list()
  for (name in c("src", "dst")) {
    root[[name]] <- create_temporary_root(use_file_store = TRUE)
  }

  id <- create_random_packet(root$src)
  orderly_location_add_path("src", path = root$src$path, root = root$dst)
  orderly_location_fetch_metadata(root = root$dst)
  suppressMessages(orderly_location_pull(id, root = root$dst))

  index <- root$dst$index$data()
  expect_equal(index$unpacked, id)
  expect_true(file.exists(
    file.path(root$dst$path, "archive", "data", id, "data.rds")))
  meta <- outpack_metadata_core(id, root$dst)
  expect_true(all(root$dst$files$exists(meta$files$hash)))
})


test_that("can error where a query returns no packets", {
  root <- list()
  for (name in c("src", "dst")) {
    root[[name]] <- create_temporary_root()
  }

  id <- create_random_packet(root$src)
  orderly_location_add_path("src", path = root$src$path, root = root$dst)
  expect_error(
    orderly_location_pull(NULL, name = "data", root = root$dst),
    "No packets found in query, so cannot pull anything")
  expect_error(
    orderly_location_pull("latest", name = "data", root = root$dst),
    "No packets found in query, so cannot pull anything")
})


test_that("can pull a packet from one location to another, archive only", {
  root <- list()
  for (name in c("src", "dst")) {
    root[[name]] <- create_temporary_root()
  }

  id <- create_random_packet(root$src)
  orderly_location_add_path("src", path = root$src$path, root = root$dst)
  orderly_location_fetch_metadata(root = root$dst)
  suppressMessages(orderly_location_pull(id, root = root$dst))

  index <- root$dst$index$data()
  expect_equal(index$unpacked, id)
  expect_true(file.exists(
    file.path(root$dst$path, "archive", "data", id, "data.rds")))
})


test_that("detect and avoid modified files in source repository", {
  root <- list()
  for (name in c("src", "dst")) {
    root[[name]] <- create_temporary_root()
  }

  tmp <- fs::dir_create(temp_file())

  saveRDS(runif(10), file.path(tmp, "a.rds"))
  saveRDS(runif(10), file.path(tmp, "b.rds"))
  id <- character(2)
  for (i in seq_along(id)) {
    p <- outpack_packet_start_quietly(tmp, "data", root = root$src)
    outpack_packet_end_quietly(p)
    id[[i]] <- p$id
  }

  orderly_location_add_path("src", path = root$src$path, root = root$dst)
  orderly_location_fetch_metadata(root = root$dst)

  ## Corrupt the file in the first id by truncating it:
  forcibly_truncate_file(
    file.path(root$src$path, "archive", "data", id[[1]], "a.rds"))

  ## Then pull
  res <- testthat::evaluate_promise(
    orderly_location_pull(id[[1]], root = root$dst))

  expect_match(res$messages, "Rejecting file from archive 'a.rds' in 'data/",
               all = FALSE)

  expect_equal(
    hash_file(file.path(root$dst$path, "archive", "data", id[[1]], "a.rds")),
    hash_file(file.path(root$src$path, "archive", "data", id[[2]], "a.rds")))
  expect_equal(
    hash_file(file.path(root$dst$path, "archive", "data", id[[1]], "b.rds")),
    hash_file(file.path(root$src$path, "archive", "data", id[[2]], "b.rds")))
})


test_that("Do not unpack a packet twice", {
  root <- list()
  for (name in c("src", "dst")) {
    root[[name]] <- create_temporary_root()
  }

  id <- create_random_packet(root$src)
  orderly_location_add_path("src", path = root$src$path, root = root$dst)
  orderly_location_fetch_metadata(root = root$dst)
  expect_equal(
    suppressMessages(orderly_location_pull(id, root = root$dst)),
    id)

  expect_equal(
    suppressMessages(orderly_location_pull(id, root = root$dst)),
    character(0))
})


test_that("Sensible error if packet not known", {
  root <- list()
  for (name in c("src", "dst")) {
    root[[name]] <- create_temporary_root()
  }

  id <- create_random_packet(root$src)
  orderly_location_add_path("src", path = root$src$path, root = root$dst)
  err <- expect_error(
    suppressMessages(orderly_location_pull(id, root = root$dst)),
    sprintf("Failed to find packet '%s'", id),
    fixed = TRUE)
  expect_match(err$body[[1]], "Looked in location 'src'")
  expect_match(err$body[[2]],
               "Do you need to run.+orderly_location_fetch_metadata")
})


test_that("Sensible error if dependent packet not known", {
  root <- list()
  for (name in c("a", "b", "c")) {
    root[[name]] <- create_temporary_root(require_complete_tree = name != "b")
  }

  id <- create_random_packet_chain(root$a, 5)
  orderly_location_add_path("a", path = root$a$path, root = root$b)
  orderly_location_fetch_metadata(root = root$b)
  suppressMessages(orderly_location_pull(id[[5]], root = root$b))

  orderly_location_add_path("b", path = root$b$path,
                       root = root$c)
  orderly_location_fetch_metadata(root = root$c)

  err <- expect_error(
    suppressMessages(orderly_location_pull(id[[5]], root = root$c)),
    sprintf("Failed to find packet '%s'", id[[4]]))
  ## This needs work. The shoddy pluralisation is the least of the
  ## issue, see mrc-4513; however, this situation is rare in most
  ## likely uses.
  expect_equal(
    err$body,
    c(i = "Looked in location 'b'",
      i = paste("1 missing packets were requested as dependencies of",
                sprintf("the ones you asked for: '%s'", id[[4]]))))
})


test_that("Can pull a tree recursively", {
  root <- list()
  for (name in c("src", "dst")) {
    root[[name]] <- create_temporary_root()
  }

  ## This just does a simple graph a -> b -> c
  id <- as.list(create_random_packet_chain(root$src, 3))

  orderly_location_add_path("src", path = root$src$path, root = root$dst)
  orderly_location_fetch_metadata(root = root$dst)
  expect_equal(suppressMessages(
    orderly_location_pull(id$c, recursive = TRUE, root = root$dst)),
    c(id$a, id$b, id$c))

  index <- root$dst$index$data()
  expect_equal(index$unpacked,
               root$src$index$data()$unpacked)

  expect_equal(suppressMessages(
    orderly_location_pull(id$c, recursive = TRUE, root = root$dst)),
    character(0))
})


test_that("Can resolve locations", {
  root <- list()
  for (name in c("dst", "a", "b", "c", "d")) {
    root[[name]] <- create_temporary_root()
    if (name != "dst") {
      orderly_location_add_path(name, path = root[[name]]$path, root = root$dst)
    }
  }

  expect_equal(
    location_resolve_valid(NULL, root$dst, FALSE, FALSE, FALSE),
    c("a", "b", "c", "d"))
  expect_equal(
    location_resolve_valid(NULL, root$dst, TRUE, FALSE, FALSE),
    c("local", "a", "b", "c", "d"))
  expect_equal(
    location_resolve_valid(NULL, root$dst, TRUE, TRUE, FALSE),
    c("local", "a", "b", "c", "d"))
  expect_equal(
    location_resolve_valid(c("a", "b", "local", "d"), root$dst,
                           FALSE, FALSE, FALSE),
    c("a", "b", "d"))
  expect_equal(
    location_resolve_valid(c("a", "b", "local", "d"), root$dst,
                           TRUE, FALSE, FALSE),
    c("a", "b", "local", "d"))

  expect_error(
    location_resolve_valid(TRUE, root$dst, TRUE, FALSE, FALSE),
    "Invalid input for 'location'; expected NULL or a character vector")

  expect_error(
    location_resolve_valid("other", root$dst, TRUE, FALSE, FALSE),
    "Unknown location: 'other'")
  expect_error(
    location_resolve_valid(c("a", "b", "f", "g"), root$dst, TRUE, FALSE, FALSE),
    "Unknown locations: 'f' and 'g'")
})


test_that("informative error message when no locations configured", {
  root <- create_temporary_root()
  expect_equal(
    location_resolve_valid(NULL, root, FALSE, FALSE, TRUE),
    character(0))
  expect_error(
    location_resolve_valid(NULL, root, FALSE, FALSE, FALSE),
    "No suitable location found")
  expect_error(
    orderly_location_pull(outpack_id(), root = root),
    "No suitable location found")
})


test_that("Can filter locations", {
  root <- list()
  for (name in c("dst", "a", "b", "c", "d")) {
    root[[name]] <- create_temporary_root()
    if (name != "dst") {
      orderly_location_add_path(name, path = root[[name]]$path, root = root$dst)
    }
  }

  ids_a <- vcapply(1:3, function(i) create_random_packet(root$a$path))
  orderly_location_add_path("a", path = root$a$path, root = root$b)
  orderly_location_fetch_metadata(root = root$b)
  suppressMessages(orderly_location_pull(ids_a, root = root$b))

  ids_b <- c(ids_a,
             vcapply(1:3, function(i) create_random_packet(root$b$path)))
  ids_c <- vcapply(1:3, function(i) create_random_packet(root$c$path))
  orderly_location_add_path("a", path = root$a$path, root = root$d)
  orderly_location_add_path("c", path = root$c$path, root = root$d)
  orderly_location_fetch_metadata(root = root$d)
  suppressMessages(orderly_location_pull(ids_a, root = root$d))
  suppressMessages(orderly_location_pull(ids_c, root = root$d))
  ids_d <- c(ids_c,
             vcapply(1:3, function(i) create_random_packet(root$d$path)))

  orderly_location_fetch_metadata(root = root$dst)

  ids <- unique(c(ids_a, ids_b, ids_c, ids_d))
  expected <- function(ids, location_name) {
    data_frame(packet = ids,
               location = location_name)
  }
  locs <- function(location) {
    location_resolve_valid(location, root$dst,
                           include_local = FALSE,
                           include_orphan = FALSE,
                           allow_no_locations = FALSE)
  }

  plan <- location_build_pull_plan(ids, NULL, NULL, root = root$dst)
  expect_equal(plan$files$location, rep(c("a", "b", "c", "d"), each = 3))

  ## Invert order, now prefers 'd'
  plan <- location_build_pull_plan(ids, locs(c("d", "c", "b", "a")), NULL,
                                   root = root$dst)
  expect_equal(plan$files$location, rep(c("d", "b"), c(9, 3)))

  ## Drop redundant locations
  plan <- location_build_pull_plan(ids, locs(c("b", "d")), NULL,
                                   root = root$dst)
  expect_equal(plan$files$location, rep(c("b", "d"), each = 6))

  ## Some corner cases:
  plan <- location_build_pull_plan(ids_a[[1]], NULL, NULL, root = root$dst)
  expect_equal(plan$files$location, "a")
  plan <- location_build_pull_plan(character(), NULL, NULL, root = root$dst)
  expect_equal(
    plan,
    list(packet_id = character(),
         files = data_frame(hash = character(),
                            size = numeric(),
                            location = character()),
         hash = set_names(character(), character()),
         info = list(n_extra = 0, n_skip = 0, n_total = 0)))

  ## Failure to find things:
  err <- expect_error(
    location_build_pull_plan(ids, c("a", "b", "c"), NULL, root = root$dst),
    "Failed to find packets")
  expect_match(err$body[[1]], "Looked in locations 'a', 'b', and 'c'")
  expect_match(err$body[[2]],
               "Do you need to run.+orderly_location_fetch_metadata")
})


test_that("can pull from multiple locations with multiple files", {
  root <- list()
  for (name in c("dst", "a", "b")) {
    root[[name]] <- create_temporary_root()
    if (name != "dst") {
      orderly_location_add_path(name, path = root[[name]]$path, root = root$dst)
    }
  }

  ids_a <- create_random_packet(root$a$path, n_files = 1)
  ids_b <- create_random_packet(root$b$path, n_files = 2)

  orderly_location_fetch_metadata(root = root$dst)
  suppressMessages(
    orderly_location_pull(NULL, name = "data", root = root$dst))

  ## It has pulled both packets, and correct number of files
  expect_setequal(
    list.files(file.path(root$dst$path, "archive", "data")),
    c(ids_a, ids_b))
  expect_equal(
    list.files(file.path(root$dst$path, "archive", "data", ids_a)),
    "data.rds")
  expect_setequal(
    list.files(file.path(root$dst$path, "archive", "data", ids_b)),
    c("data.rds", "data2.rds"))
})


test_that("nonrecursive pulls are prevented by configuration", {
  root <- list()
  for (name in c("src", "dst")) {
    root[[name]] <- create_temporary_root(require_complete_tree = TRUE)
  }

  id <- create_random_packet_chain(root$src, 3)

  expect_error(
    orderly_location_pull(id[["c"]], recursive = FALSE, root = root$dst),
    "'recursive' must be TRUE (or NULL) with your configuration",
    fixed = TRUE)
})


test_that("if recursive pulls are required, pulls are recursive by default", {
  root <- list()
  for (name in c("src", "shallow", "deep")) {
    root[[name]] <- create_temporary_root(
      require_complete_tree = name == "deep")
  }

  id <- create_random_packet_chain(root$src, 3)

  for (r in root[c("shallow", "deep")]) {
    orderly_location_add_path("src", path = root$src$path, root = r)
    orderly_location_fetch_metadata(root = r)
  }

  suppressMessages(
    orderly_location_pull(id[["c"]], recursive = NULL,
                                 root = root$shallow))
  expect_equal(root$shallow$index$data()$unpacked, id[["c"]])

  suppressMessages(
    orderly_location_pull(id[["c"]], recursive = NULL,
                                 root = root$deep))
  expect_setequal(root$deep$index$data()$unpacked, id)
})


test_that("can't add unknown location type", {
  root <- create_temporary_root()
  expect_error(
    orderly_location_add("other", "magic", list(arg = 1), root = root),
    "'type' must be one of 'path', 'http'")
})


test_that("validate arguments to path locations", {
  root <- create_temporary_root()
  expect_error(
    orderly_location_add("other", "path", list(root = "mypath"),
                         root = root),
    "'path' must be a scalar")
  expect_equal(orderly_location_list(root = root), "local")
})


test_that("validate arguments to http locations", {
  root <- create_temporary_root()
  expect_error(
    orderly_location_add("other", "http", list(server = "example.com"),
                         root = root),
    "'url' must be a scalar")
  expect_equal(orderly_location_list(root = root), "local")
})


test_that("validate arguments to packit locations", {
  root <- create_temporary_root()
  expect_error(
    orderly_location_add("other", "packit", list(server = "example.com"),
                         root = root),
    "'url' must be a scalar")

  expect_error(
    orderly_location_add_packit("other",
                                url = "example.com",
                                token = 123,
                                verify = FALSE,
                                root = root),
    "Expected 'token' to be character", fixed = TRUE)

  expect_error(
    orderly_location_add_packit("other",
                                url = "example.com",
                                save_token = "value",
                                verify = FALSE,
                                root = root),
    "Expected 'save_token' to be logical", fixed = TRUE)

  expect_error(
    orderly_location_add_packit("other",
                                url = "example.com",
                                token = "xx",
                                save_token = TRUE,
                                verify = FALSE,
                                root = root),
    "Cannot specify both 'token' and 'save_token'", fixed = TRUE)

  expect_equal(orderly_location_list(root = root), "local")
})


test_that("can add a packit location", {
  skip_if_not_installed("mockery")
  root <- create_temporary_root()
  orderly_location_add_packit("other",
                              url = "https://example.com",
                              token = "abc123",
                              verify = FALSE,
                              root = root)
  expect_equal(orderly_location_list(root = root), c("local", "other"))

  mock_driver <- mockery::mock()
  mockery::stub(location_driver, "location_driver_create", mock_driver)

  dr <- location_driver("other", root)

  mockery::expect_called(mock_driver, 1)
  expect_equal(
    mockery::mock_args(mock_driver)[[1]],
    list("packit",
         list(url = "https://example.com",
              token = "abc123",
              save_token = FALSE),
         root))
})

test_that("can add a packit location without a token", {
  skip_if_not_installed("mockery")
  root <- create_temporary_root()
  orderly_location_add_packit("other",
                              url = "https://example.com",
                              verify = FALSE,
                              root = root)
  expect_equal(
    orderly_config(root)$location$args[[2]],
    list(url = "https://example.com", token = NULL, save_token = TRUE))
  expect_equal(orderly_location_list(root = root), c("local", "other"))

  mock_driver <- mockery::mock()
  mockery::stub(location_driver, "location_driver_create", mock_driver)

  dr <- location_driver("other", root)

  mockery::expect_called(mock_driver, 1)
  expect_equal(
    mockery::mock_args(mock_driver)[[1]],
    list("packit",
         list(url = "https://example.com", token = NULL, save_token = TRUE),
         root))
})

test_that("cope with trailing slash in url if needed", {
  loc <- orderly_location_packit("https://example.com/", "abc123")
  expect_equal(loc$client$url, "https://example.com/api/outpack")
})


test_that("can create an outpack location", {
  loc <- orderly_location_http$new("https://example.com", NULL)
  expect_equal(loc$client$url, "https://example.com")
})


test_that("strip trailing slash from outpack url", {
  loc <- orderly_location_http$new("https://example.com/", NULL)
  expect_equal(loc$client$url, "https://example.com")
})


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(orderly_location_custom, "getExportedValue", mock_gev)
  expect_equal(orderly_location_custom(driver = "foo::bar", a = 1, b = "other"),
               "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(orderly_location_custom, "getExportedValue", mock_gev)
  expect_equal(orderly_location_custom(driver = "foo::bar", a = 1, b = "other"),
               "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)
  orderly_location_add("a", "custom", args = args, verify = FALSE, 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_orderly_location_driver_create <- mockery::mock("value")
  mockery::stub(location_driver, "location_driver_create",
                mock_orderly_location_driver_create)
  expect_equal(location_driver(loc$name, root), "value")
  mockery::expect_called(mock_orderly_location_driver_create, 1)
  expect_equal(mockery::mock_args(mock_orderly_location_driver_create)[[1]],
               list("custom", list(driver = "foo::bar", a = 1, b = 2), root))
})


test_that("custom drivers require a 'driver' argument", {
  root <- create_temporary_root()
  expect_error(
    orderly_location_add("a", "custom", args = list(), root = root),
    "Field missing from args: 'driver'")
})


test_that("can pull packets as a result of a query", {
  root <- list()
  for (name in c("src", "dst")) {
    root[[name]] <- create_temporary_root(use_file_store = TRUE)
  }
  ids <- vcapply(1:3, function(i) {
    create_random_packet(root$src$path, parameters = list(i = i))
  })
  orderly_location_add_path("src", path = root$src$path, root = root$dst$path)
  ids_moved <- suppressMessages(
    orderly_location_pull(
      "parameter:i < 3",
      name = "data",
      fetch_metadata = TRUE,
      root = root$dst$path))
  expect_setequal(ids_moved, ids[1:2])
})


test_that("handle metadata where the hash does not match reported", {
  here <- create_temporary_root()
  there <- create_temporary_root()
  orderly_location_add_path("server", path = there$path, root = here)
  id <- create_random_packet(there)

  path_metadata <- file.path(there$path, ".outpack", "metadata", id)
  json <- jsonlite::prettify(read_string(path_metadata))
  writeLines(json, path_metadata)

  err <- expect_error(
    orderly_location_fetch_metadata(root = here),
    "Hash of metadata for '.+' from 'server' does")
  expect_equal(
    unname(err$message),
    sprintf("Hash of metadata for '%s' from 'server' does not match!", id))
  expect_equal(names(err$body), c("x", "i", "x", "i"))
  expect_match(err$body[[3]], "This is bad news")
  expect_match(err$body[[4]], "remove this location")
})


test_that("handle metadata where two locations differ in hash for same id", {
  root <- list()
  for (name in c("a", "b", "us")) {
    root[[name]] <- create_temporary_root()
  }

  id <- outpack_id()
  create_random_packet(root$a, id = id)
  create_random_packet(root$b, id = id)

  orderly_location_add_path("a", path = root$a$path, root = root$us)
  orderly_location_add_path("b", path = root$b$path, root = root$us)

  orderly_location_fetch_metadata(location = "a", root = root$us)
  err <- expect_error(
    orderly_location_fetch_metadata(location = "b", root = root$us),
    "Location 'b' has conflicting metadata")
  expect_equal(names(err$body), c("x", "i", "i", "i"))
  expect_match(err$body[[1]],
               "We have been offered metadata from 'b' that has a different")
  expect_match(err$body[[2]], sprintf("Conflicts for: '%s'", id))
  expect_match(err$body[[3]], "please let us know")
  expect_match(err$body[[4]], "remove this location")
})


test_that("avoid duplicated metadata", {
  skip_if_not_installed("mockery")
  here <- create_temporary_root()
  there <- create_temporary_root()
  orderly_location_add_path("server", path = there$path, root = here)
  id <- create_random_packet(there)

  driver <- location_driver("server", root = here)
  mock_driver <- list(list = function(x) rbind(driver$list(), driver$list()))
  mock_location_driver <- mockery::mock(mock_driver)

  mockery::stub(location_fetch_metadata, "location_driver",
                mock_location_driver)
  err <- expect_error(
    location_fetch_metadata("server", root = here),
    "Duplicate metadata reported from location 'server'")
  expect_equal(names(err$body), c("x", "i", "i"))
  expect_equal(err$body[[1]],
               sprintf("Duplicate data returned for packets '%s'", id))
  expect_equal(err$body[[2]],
               "This is a bug in your location server, please report it")
  expect_match(err$body[[3]], "remove this location")
})


test_that("skip files in the file store", {
  root <- list()
  for (name in c("src", "dst")) {
    root[[name]] <- create_temporary_root(use_file_store = TRUE)
  }

  id <- create_random_packet_chain(root$src, 3)
  orderly_location_add_path("src", path = root$src$path, root = root$dst)
  orderly_location_fetch_metadata(root = root$dst)
  suppressMessages(orderly_location_pull(id[[1]], root = root$dst))

  withr::with_options(list(orderly.quiet = FALSE), {
    res <- testthat::evaluate_promise(
      orderly_location_pull(id[[2]], root = root$dst))
    expect_match(res$messages, "Found 1 file in the file store", all = FALSE)
    expect_match(res$messages, "Need to fetch 2 files.+from 1 location",
                 all = FALSE)
  })
})


test_that("skip files known elsewhere on disk", {
  root <- list()
  for (name in c("src", "dst")) {
    root[[name]] <- create_temporary_root(use_file_store = FALSE)
  }

  id <- create_random_packet_chain(root$src, 3)
  orderly_location_add_path("src", path = root$src$path, root = root$dst)
  orderly_location_fetch_metadata(root = root$dst)
  suppressMessages(orderly_location_pull(id[[1]], root = root$dst))

  withr::with_options(list(orderly.quiet = FALSE), {
    res <- testthat::evaluate_promise(
      orderly_location_pull(id[[2]], root = root$dst))
    expect_match(res$messages, "Found 1 file on disk", all = FALSE)
    expect_match(res$messages, "Need to fetch 2 files.+from 1 location",
                 all = FALSE)
  })
})


test_that("can prune orphans from tree", {
  root <- list()
  for (name in c("here", "there")) {
    root[[name]] <- create_temporary_root()
  }
  orderly_location_add_path("there", path = root$there$path, root = root$here)
  id <- create_random_packet_chain(root$there, 5)
  orderly_location_fetch_metadata(root = root$here)
  expect_message(
    orderly_location_remove("there", root = root$here),
    "Orphaning 5 packets")

  expect_setequal(orderly_location_list(root = root$here),
                  c("local", "orphan"))
  expect_equal(root$here$index$data()$location$location,
               rep("orphan", 5))

  expect_message(
    orderly_prune_orphans(root = root$here),
    "Pruning 5 orphan packets")

  expect_setequal(orderly_location_list(root = root$here),
                  c("local", "orphan"))
  expect_equal(root$here$index$data()$location$location,
               character())
})


test_that("don't prune referenced orphans", {
  root <- create_temporary_root()
  id <- create_random_packet_chain(root, 3)
  fs::dir_delete(file.path(root$path, "archive", "a"))
  fs::dir_delete(file.path(root$path, "archive", "c"))
  suppressMessages(orderly_validate_archive(action = "orphan", root = root))
  expect_equal(nrow(root$index$location(orphan)), 2)

  res <- evaluate_promise(orderly_prune_orphans(root = root))
  expect_equal(res$result, id[[3]])
  expect_length(res$messages, 2)
  expect_match(
    res$messages[[1]],
    "Can't prune 1 orphan packet, as it is referenced by other packets")
  expect_match(
    res$messages[[2]],
    "Pruning 1 orphan packet")

  res <- evaluate_promise(orderly_prune_orphans(root = root))
  expect_equal(res$result, character())
  expect_length(res$messages, 1)
  expect_match(
    res$messages[[1]],
    "Can't prune 1 orphan packet, as it is referenced by other packets")
})


test_that("early exit if no orphans", {
  root <- create_temporary_root()
  id <- create_random_packet_chain(root, 3)
  expect_silent(res <- orderly_prune_orphans(root = root))
  expect_equal(res, character())
})


test_that("be chatty when pulling packets", {
  withr::local_options(orderly.quiet = FALSE)
  here <- create_temporary_root()
  there <- create_temporary_root()
  res <- evaluate_promise(
    orderly_location_add_path("server", path = there$path, root = here))
  expect_length(res$messages, 3)
  expect_match(res$messages[[1]],
               "Testing location")
  expect_match(res$messages[[2]],
               "Location configured successfully")
  expect_match(res$messages[[3]],
               "Added location 'server' (path)", fixed = TRUE)

  res <- evaluate_promise(orderly_location_fetch_metadata(root = here))
  expect_length(res$messages, 2)
  expect_match(res$messages[[1]],
               "Fetching metadata from 1 location: 'server'")
  expect_match(res$messages[[2]],
               "No metadata found at 'server'")

  id1 <- create_random_packet(there)
  id2 <- create_random_packet(there)

  res <- evaluate_promise(orderly_location_fetch_metadata(root = here))
  expect_length(res$messages, 2)
  expect_match(res$messages[[1]],
               "Fetching metadata from 1 location: 'server'")
  expect_match(res$messages[[2]],
               "Found 2 packets at 'server', of which 2 are new")

  res <- evaluate_promise(orderly_location_fetch_metadata(root = here))
  expect_length(res$messages, 2)
  expect_match(res$messages[[2]],
               "Found 2 packets at 'server', of which 0 are new")

  id3 <- create_random_packet(there)
  res <- evaluate_promise(orderly_location_fetch_metadata(root = here))
  expect_length(res$messages, 2)
  expect_match(res$messages[[2]],
               "Found 3 packets at 'server', of which 1 is new")
})


test_that("verify location on addition", {
  root <- create_temporary_root()
  path <- tempfile()

  expect_error(
    orderly_location_add_path("upstream", path = path, root = root))
  expect_equal(orderly_location_list(root = root), "local")

  expect_no_error(
    orderly_location_add_path("upstream", path = path, verify = FALSE,
                              root = root))
  expect_equal(orderly_location_list(root = root), c("local", "upstream"))
})


test_that("print list of pulled packets", {
  withr::local_options(orderly.quiet = FALSE)
  root <- list()
  for (name in c("src", "dst")) {
    root[[name]] <- create_temporary_root()
  }

  id <- create_random_packet(root$src)
  suppressMessages({
    orderly_location_add_path("src", path = root$src$path, root = root$dst)
    orderly_location_fetch_metadata(root = root$dst)
  })

  msgs <- capture_messages(
    orderly_location_pull(id, root = root$dst))
  expect_match(msgs, sprintf("Pulling 1 packet: '%s'", id),
               all = FALSE, fixed = TRUE)
  expect_match(msgs, "Unpacked 1 packet",
               all = FALSE, fixed = TRUE)

  msgs <- capture_messages(
    orderly_location_pull(id, root = root$dst))
  expect_match(msgs, sprintf("Pulling 1 packet: '%s'", id),
               all = FALSE, fixed = TRUE)
  expect_match(msgs, "Nothing to do, everything is available locally",
               all = FALSE, fixed = TRUE)
})