From 6327adc2f4188a9f4a185b5f8c266f177052f51b Mon Sep 17 00:00:00 2001
From: Rich FitzJohn <r.fitzjohn@imperial.ac.uk>
Date: Thu, 30 May 2024 16:14:35 +0100
Subject: [PATCH] Better handling of failed push due to corrupt packets

---
 DESCRIPTION                         |  2 +-
 R/location.R                        | 10 ++++++++--
 R/outpack_root.R                    | 18 ++++++++++++++----
 tests/testthat/test-location-path.R | 18 ++++++++++++++++++
 4 files changed, 41 insertions(+), 7 deletions(-)

diff --git a/DESCRIPTION b/DESCRIPTION
index 74c440e4..733ff5df 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,6 +1,6 @@
 Package: orderly2
 Title: Orderly Next Generation
-Version: 1.99.14
+Version: 1.99.15
 Authors@R: c(person("Rich", "FitzJohn", role = c("aut", "cre"),
                     email = "rich.fitzjohn@gmail.com"),
              person("Robert", "Ashton", role = "aut"),
diff --git a/R/location.R b/R/location.R
index e25d4088..ba0247f3 100644
--- a/R/location.R
+++ b/R/location.R
@@ -392,8 +392,14 @@ orderly_location_push <- function(packet_id, location, root = NULL,
   if (length(plan$files) > 0 || length(plan$packet_id) > 0) {
     driver <- location_driver(location_name, root)
     for (hash in plan$files) {
-      ## TODO: mrc-4505 - needs work
-      driver$push_file(find_file_by_hash(root, hash), hash)
+      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")))
+      }
+      driver$push_file(src, hash)
     }
     for (id in plan$packet_id) {
       path <- file.path(root$path, ".outpack", "metadata", id)
diff --git a/R/outpack_root.R b/R/outpack_root.R
index c676f116..7044fa05 100644
--- a/R/outpack_root.R
+++ b/R/outpack_root.R
@@ -120,17 +120,27 @@ find_file_by_hash <- function(root, hash) {
   for (id in index$unpacked) {
     meta <- index$metadata[[id]]
     for (i in which(meta$files$hash == hash)) {
-      path <- file.path(path_archive, meta$name, id, meta$files$path[[i]])
-      if (file.exists(path) && hash_file(path, algorithm) == hash) {
+      filename <- meta$files$path[[i]]
+      path <- file.path(path_archive, meta$name, id, filename)
+      if (!file.exists(path)) {
+        cli::cli_alert_warning(
+          "Missing file from archive '{filename}' in '{meta$name}/{id}'")
+        next
+      }
+      hash_found <- hash_file(path, algorithm)
+      if (file.exists(path) && hash_found == hash) {
         return(path)
       }
-      p <- meta$files$path[[i]]
       ## Not actually a warning; formats in a way that works within
       ## the overal logging. What is not obvious is that this is
       ## potentially coming from a remote and that's not always clear,
       ## so we need a way of nesting output
       cli::cli_alert_warning(
-        "Rejecting file from archive '{p}' in '{meta$name}/{id}'")
+        "Rejecting file from archive '{filename}' in '{meta$name}/{id}'")
+      cli::cli_alert_info(
+        "Expected ({cli::symbol$tick}) and found ({cli::symbol$cross}) hashes:")
+      cli::cli_alert_success(hash)
+      cli::cli_alert_danger(hash_found)
     }
   }
 
diff --git a/tests/testthat/test-location-path.R b/tests/testthat/test-location-path.R
index a951dd6c..c7e88ff6 100644
--- a/tests/testthat/test-location-path.R
+++ b/tests/testthat/test-location-path.R
@@ -350,3 +350,21 @@ test_that("Can read metadata files with a trailing newline", {
   expected_hash <- packets[packets$packet == id]$hash
   expect_no_error(hash_validate_data(data, expected_hash))
 })
+
+
+test_that("Fail to push sensibly if files have been changed", {
+  client <- create_temporary_root()
+  ids <- create_random_packet_chain(client, 4)
+
+  server <- create_temporary_root(use_file_store = TRUE, path_archive = NULL)
+  orderly_location_add("server", "path", list(path = server$path),
+                       root = client)
+
+  ## Corrupt one file:
+  path <- file.path(client$path, "archive", "b", ids[["b"]], "script.R")
+  append_lines(path, "# anything")
+
+  expect_error(
+    suppressMessages(orderly_location_push(ids[[4]], "server", client)),
+    "Did not find suitable file, can't push this packet")
+})