Skip to content

Commit

Permalink
Merge pull request #193 from mrc-ide/gh-143
Browse files Browse the repository at this point in the history 
Gh 143
  • Loading branch information
@richfitz
richfitz authored Oct 23, 2024
2 parents 71ac8d5 + f201d63 commit 2b5e8a2
Show file tree
Hide file tree
Showing 5 changed files with 190 additions and 27 deletions.
2 changes: 1 addition & 1 deletion DESCRIPTION
View file
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
Package: orderly2
Title: Orderly Next Generation
Version: 1.99.50
Version: 1.99.51
Authors@R: c(person("Rich", "FitzJohn", role = c("aut", "cre"),
email = "[email protected]"),
person("Robert", "Ashton", role = "aut"),
Expand Down
91 changes: 79 additions & 12 deletions R/location.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -471,48 +471,115 @@ orderly_location_pull_packet <- function(expr,
##'
##' @title Push tree to location
##'
##' @param packet_id One or more packets to push to the server
##' @param expr An expression to search for. Often this will be a
##' vector of ids, but you can use a query here.
##'
##' @param location The name of a location to push to (see
##' [orderly2::orderly_location_list] for possible values).
##'
##' @param dry_run Logical, indicating if we should print a summary
##' but not make any changes.
##'
##' @inheritParams orderly_metadata
##' @inheritParams orderly_search
##'
##' @return Invisibly, details on the information that was actually
##' moved (which might be more or less than what was requested,
##' depending on the dependencies of packets and what was already
##' known on the other location).
##'
##' @export
orderly_location_push <- function(packet_id, location, root = NULL) {
orderly_location_push <- function(expr, location, name = NULL, dry_run = FALSE,
root = NULL) {
root <- root_open(root, require_orderly = FALSE)
assert_scalar_logical(dry_run)
location_name <- location_resolve_valid(location, root,
include_local = FALSE,
include_orphan = FALSE,
allow_no_locations = FALSE,
environment())
plan <- location_build_push_plan(packet_id, location_name, root)
if (expr_is_literal_id(expr, name)) {
ids <- expr
err <- setdiff(ids, root$index$unpacked())
if (length(err)) {
cli::cli_abort("Trying to push unknown packet{?s}: {squote(err)}")
}
} else {
ids <- orderly_search(expr, name = name, root = root)
if (length(ids) == 0) {
cli_alert_warning("Query returned no packets to push")
}
}

plan <- location_build_push_plan(ids, location_name, root)

if (length(plan$files) == 0 && length(plan$packet_id) == 0) {
cli_alert_success("Nothing to push, everything up to date")
} else {
cli_alert_info(
paste("Pushing {length(plan$files)} file{?s} for",
"{length(plan$packet_id)} packet{?s}"))
if (dry_run) {
cli_alert_info("Not making any changes, as 'dry_run = TRUE'")
} else {
driver <- location_driver(location_name, root)
location_push_files(plan$files, driver, root)
location_push_metadata(plan$packet_id, driver, root)
orderly_location_pull_metadata(location_name, root)
}
}

invisible(plan)
}

if (length(plan$files) > 0 || length(plan$packet_id) > 0) {
driver <- location_driver(location_name, root)
for (hash in plan$files) {

location_push_files <- function(files, driver, root) {
n_files <- length(files)
if (n_files == 0) {
cli_alert_info("No files needed, all are available at location")
} else {
size <- "(unknown)"
cli_progress_bar(
format = paste(
"{cli::pb_spin} Pushing file {cli::pb_current} / {cli::pb_total}",
"({size})"),
format_done = paste(
"{cli::col_green(cli::symbol$tick)} Uploaded {cli::pb_total} files",
"in {cli::pb_elapsed}"),
total = n_files,
clear = FALSE)
for (hash in files) {
src <- find_file_by_hash(root, hash)
if (is.null(src)) {
cli::cli_abort(
c("Did not find suitable file, can't push this packet",
i = paste("The original file has been changed or deleted.",
"Details are above")))
}
size <- pretty_bytes(fs::file_size(src))
cli_progress_update()
driver$push_file(src, hash)
}
for (id in plan$packet_id) {
path <- file.path(root$path, ".outpack", "metadata", id)
hash <- get_metadata_hash(id, root)
driver$push_metadata(id, hash, path)
}
}
}

invisible(plan)

location_push_metadata <- function(ids, driver, root) {
id <- "(unknown)"
cli_progress_bar(
format = paste(
"{cli::pb_spin} Pushing packet {id} {cli::pb_current} / {cli::pb_total}"),
format_done = paste(
"{cli::col_green(cli::symbol$tick)} Uploaded {cli::pb_total} packets",
"in {cli::pb_elapsed}"),
total = length(ids),
clear = FALSE)
for (id in ids) {
path <- file.path(root$path, ".outpack", "metadata", id)
hash <- get_metadata_hash(id, root)
cli_progress_update()
driver$push_metadata(id, hash, path)
}
}


Expand Down
15 changes: 15 additions & 0 deletions R/util.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -724,6 +724,21 @@ cli_alert_warning <- function(..., .envir = parent.frame()) {
}
}

cli_progress_bar <- function(..., .envir = parent.frame(), immediate = TRUE) {
if (immediate) {
withr::local_options(cli.progress_show_after = 0, .local_envir = .envir)
}
if (!orderly_quiet()) {
cli::cli_progress_bar(..., .envir = .envir)
}
}

cli_progress_update <- function(..., .envir = parent.frame()) {
if (!orderly_quiet()) {
cli::cli_progress_update(..., .envir = .envir)
}
}

# Given a character vector, missing names are filled using the value.
fill_missing_names <- function(x) {
if (is.null(names(x))) {
Expand Down
18 changes: 16 additions & 2 deletions man/orderly_location_push.Rd
View file

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

91 changes: 79 additions & 12 deletions tests/testthat/test-location-path.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -184,15 +184,15 @@ test_that("Import complete tree via push into server", {
server <- create_temporary_root(use_file_store = TRUE, path_archive = NULL)
orderly_location_add_path("server", path = server$path, root = client)

plan <- orderly_location_push(ids[[4]], "server", client)
plan <- orderly_location_push(ids[[4]], "server", root = client)

idx_c <- client$index$data()
idx_s <- server$index$data()

expect_equal(idx_s$metadata, idx_c$metadata)
expect_equal(idx_s$unpacked, idx_c$unpacked)
expect_equal(idx_s$location$packet, idx_c$location$packet)
expect_equal(idx_s$location$hash, idx_c$location$hash)
expect_equal(idx_s$location$packet, idx_c$unpacked)
expect_setequal(idx_s$location$hash, idx_c$location$hash)

expect_setequal(plan$packet_id, ids)
files_used <- lapply(ids, function(id) client$index$metadata(id)$files$hash)
Expand All @@ -208,7 +208,7 @@ test_that("Import packets into root with archive as well as store", {
path_archive = "archive")
orderly_location_add_path("server", path = server$path, root = client)

plan <- orderly_location_push(ids[[4]], "server", client)
plan <- orderly_location_push(ids[[4]], "server", root = client)

expect_equal(
sort(withr::with_dir(server$path, fs::dir_ls("archive", recurse = TRUE))),
Expand Down Expand Up @@ -257,7 +257,7 @@ test_that("Can only push into a root with a file store", {
server <- create_temporary_root()
orderly_location_add_path("server", path = server$path, root = client)
expect_error(
orderly_location_push(ids[[2]], "server", client),
orderly_location_push(ids[[2]], "server", root = client),
"Can't push files into this server, as it does not have a file store")
})

Expand All @@ -267,8 +267,8 @@ test_that("pushing twice does nothing", {
ids <- create_random_packet_chain(client, 4)
server <- create_temporary_root(use_file_store = TRUE, path_archive = NULL)
orderly_location_add_path("server", path = server$path, root = client)
plan1 <- orderly_location_push(ids[[4]], "server", client)
plan2 <- orderly_location_push(ids[[4]], "server", client)
plan1 <- orderly_location_push(ids[[4]], "server", root = client)
plan2 <- orderly_location_push(ids[[4]], "server", root = client)
expect_equal(plan2, list(packet_id = character(), files = character()))
})

Expand All @@ -283,7 +283,7 @@ test_that("push overlapping tree", {
suppressMessages(orderly_location_pull_packet(id_base, root = client))

ids <- create_random_packet_chain(client, 3, id_base)
plan <- orderly_location_push(ids[[3]], "server", client)
plan <- orderly_location_push(ids[[3]], "server", root = client)

expect_setequal(plan$packet_id, ids)
expect_setequal(names(server$index$data()$metadata), c(id_base, ids))
Expand All @@ -297,15 +297,15 @@ test_that("Push single packet", {
server <- create_temporary_root(use_file_store = TRUE, path_archive = NULL)
orderly_location_add_path("server", path = server$path, root = client)

plan <- orderly_location_push(id, "server", client)
plan <- orderly_location_push(id, "server", root = client)

idx_c <- client$index$data()
idx_s <- server$index$data()

expect_equal(idx_s$metadata, idx_c$metadata)
expect_equal(idx_s$unpacked, idx_c$unpacked)
expect_equal(idx_s$location$packet, idx_c$location$packet)
expect_equal(idx_s$location$hash, idx_c$location$hash)
expect_equal(idx_s$location$packet, idx_c$unpacked)
expect_setequal(idx_s$location$hash, idx_c$location$hash)

expect_equal(plan$packet_id, id)
files_used <- lapply(id, function(id) client$index$metadata(id)$files$hash)
Expand Down Expand Up @@ -356,7 +356,7 @@ test_that("Fail to push sensibly if files have been changed", {
forcibly_truncate_file(path)

expect_error(
suppressMessages(orderly_location_push(ids[[4]], "server", client)),
suppressMessages(orderly_location_push(ids[[4]], "server", root = client)),
"Did not find suitable file, can't push this packet")
})

Expand Down Expand Up @@ -408,3 +408,70 @@ test_that("provide hint when wrong relative path given", {
expect_equal(err$body[[2]],
"Consider passing '../b' instead")
})


test_that("Dry run does not push", {
client <- create_temporary_root()
id1 <- create_random_packet(client, parameters = list(a = 1))
id2 <- create_random_packet(client, parameters = list(a = 2))
id3 <- create_random_packet(client, parameters = list(a = 1))

server <- create_temporary_root(use_file_store = TRUE, path_archive = NULL)
orderly_location_add_path("server", path = server$path, root = client)

withr::local_options(orderly.quiet = FALSE)
res <- evaluate_promise(
orderly_location_push("parameter:a == 1", "server",
dry_run = TRUE, root = client))
expect_length(res$result$packet_id, 2)
expect_length(orderly_search(root = server), 0)
expect_length(res$messages, 2)
expect_match(res$messages[[1]], "Pushing 2 files for 2 packets")
expect_match(res$messages[[2]], "Not making any changes, as 'dry_run = TRUE'")
})


test_that("Inform if query matches nothing", {
client <- create_temporary_root()
server <- create_temporary_root(use_file_store = TRUE, path_archive = NULL)
orderly_location_add_path("server", path = server$path, root = client)
withr::local_options(orderly.quiet = FALSE)

res1 <- evaluate_promise(
orderly_location_push("parameter:a == 1", "server", root = client))
expect_length(res1$messages, 2)
expect_match(res1$messages[[1]], "Query returned no packets to push")
expect_match(res1$messages[[2]], "Nothing to push, everything up to date")
expect_equal(res1$result, list(packet_id = character(), files = character()))

res2 <- evaluate_promise(
orderly_location_push(character(), "server", root = client))
expect_length(res2$messages, 1)
expect_equal(res2$messages[[1]], res1$messages[[2]])
expect_equal(res2$result, res1$result)
})


test_that("prevent pushing unknown packets", {
client <- create_temporary_root()
server <- create_temporary_root(use_file_store = TRUE, path_archive = NULL)
orderly_location_add_path("server", path = server$path, root = client)

expect_error(
orderly_location_push("20241023-131946-0260c975", "server", root = client),
"Trying to push unknown packet: '20241023-131946-0260c975'")
})


test_that("pull metadata after push", {
client <- create_temporary_root()
id1 <- create_random_packet(client, parameters = list(a = 1))
id2 <- create_random_packet(client, parameters = list(a = 2))
id3 <- create_random_packet(client, parameters = list(a = 1))

server <- create_temporary_root(use_file_store = TRUE, path_archive = NULL)
orderly_location_add_path("server", path = server$path, root = client)

plan <- orderly_location_push("parameter:a == 1", "server", root = client)
expect_length(orderly_search(location = "server", root = client), 2)
})

0 comments on commit 2b5e8a2

Please sign in to comment.