Merge pull request #92 from mrc-ide/mrc-3052

Add support for validating packets

NAMESPACE

@@ -39,4 +39,5 @@ export(orderly_search)
 export(orderly_search_options)
 export(orderly_shared_resource)
 export(orderly_strict_mode)
+export(orderly_validate_archive)
 importFrom(R6,R6Class)

R/location.R

@@ -152,32 +152,22 @@ orderly_location_remove <- function(name, root = NULL, locate = TRUE) {
                  name))
   }
   location_check_exists(root, name)
-  config <- root$config
 
   index <- root$index$data()
   known_here <- index$location$packet[index$location$location == name]
   known_elsewhere <- index$location$packet[index$location$location != name]
   only_here <- setdiff(known_here, known_elsewhere)
 
   if (length(only_here) > 0) {
-    if (!location_exists(root, "orphan")) {
-      config$location <- rbind(
-        config$location,
-        new_location_entry(orphan, "orphan", NULL))
-      rownames(config$location) <- NULL
-    }
-
     mark_packets_orphaned(name, only_here, root)
   }
 
   location_path <- file.path(root$path, ".outpack", "location", name)
   if (fs::dir_exists(location_path)) {
     fs::dir_delete(location_path)
   }
-  ## This forces a rebuild of the index, and is the only call with
-  ## rebuild() anywhere; it can probably be relaxed if the refresh was
-  ## more careful, but this is a rare operation.
   root$index$rebuild()
+  config <- root$config
   config$location <- config$location[config$location$name != name, ]
   config_update(config, root)
   invisible()
@@ -728,13 +718,30 @@ location_exists <- function(root, name) {
 
 
 mark_packets_orphaned <- function(location, packet_id, root) {
+  if (!location_exists(root, "orphan")) {
+    config <- root$config
+    config$location <- rbind(
+      config$location,
+      new_location_entry(orphan, "orphan", NULL))
+    rownames(config$location) <- NULL
+    config_update(config, root)
+  }
   src <- file.path(root$path, ".outpack", "location", location, packet_id)
   dest <- file.path(root$path, ".outpack", "location", "orphan", packet_id)
   fs::dir_create(dirname(dest))
   fs::file_move(src, dest)
 }
 
 
+drop_local_packet <- function(packet_id, root) {
+  location <- root$index$location(NULL)
+  known_at <- location$location[location$packet == packet_id]
+  if (!any(known_at != local)) {
+    mark_packets_orphaned(local, packet_id, root)
+  }
+}
+
+
 ## This approach may be suboptimal in the case where the user does not
 ## already have a file store, as it means that files will be copied
 ## around and hashed more than ideal:

R/outpack_hash.R

@@ -32,6 +32,7 @@ hash_validate_file <- function(path, expected, body = NULL, call = NULL) {
 }
 
 
+
 hash_validate_data <- function(data, expected, name = deparse(substitute(x)),
                                body = NULL, call = NULL) {
   hash_validate(rehash(data, hash_data, expected), expected, name,

R/outpack_index.R

@@ -36,7 +36,11 @@ outpack_index <- R6::R6Class(
 
     location = function(name) {
       self$refresh()
-      private$data_$location[private$data_$location$location %in% name, ]
+      if (is.null(name)) {
+        private$data_$location
+      } else {
+        private$data_$location[private$data_$location$location %in% name, ]
+      }
     },
 
     unpacked = function() {

R/validate.R

@@ -0,0 +1,127 @@
+##' Validate unpacked packets. Over time, expect this function to
+##' become more fully featured, validating more.
+##'
+##' The actions that we can take on finding an invalid packet are:
+##'
+##' * `inform` (the default): just print information about the problem
+##'
+##' * `orphan`: mark the packet as orphaned within the metadata, but
+##'   do not touch the files in your archive (by default the directory
+##'   `archive/`) - this is a safe option and will leave you in a
+##'   consistent state without deleting anything.
+##'
+##' * `delete`: in addition to marking the packet as an orphan, also
+##'   delete the files from your archive.
+##'
+##' Later, we will add a "repair" option to try and fix broken
+##' packets.
+##'
+##' The validation interacts with the option
+##' `core.require_complete_tree`; if this option is `TRUE`, then a
+##' packet is only valid if all its (recursive) dependencies are also
+##' valid, so the action will apply to packets that have also had
+##' their upstream dependencies invalidated.  This validation will
+##' happen even if the query implied by `...` does not include these
+##' packets if a complete tree is required.
+##'
+##' The validation will also interact with `core.use_file_store` once
+##' repair is supported, as this becomes trivial.
+##'
+##' @title Validate unpacked packets.
+##'
+##' @param ... Either arguments that a search can be constructed from
+##'   (useful options here include `name = "something"`), a character
+##'   vector of ids, or leave empty to validate everything.
+##'
+##' @param action The action to take on finding an invalid packet. See
+##'   Details.
+##'
+##' @inheritParams orderly_metadata
+##'
+##' @return Invisibly, a character vector of repaired (or invalid)
+##'   packets.
+##'
+##' @export
+orderly_validate_archive <- function(..., action = "inform",
+                                     root = NULL, locate = TRUE) {
+  root <- root_open(root, locate = TRUE, require_orderly = FALSE)
+  action <- match_value(action, c("inform", "orphan", "delete", "repair"))
+
+  if (is.null(root$config$core$path_archive)) {
+    cli::cli_abort("You have no archive to validate")
+  }
+
+  if (dots_is_literal_id(...)) {
+    ids <- ..1
+  } else {
+    options <- orderly_search_options(location = local)
+    ids <- orderly_search(..., options = options, root = root)
+  }
+
+  cache <- new.env(parent = emptyenv())
+  for (id in sort(ids)) {
+    cache[[id]] <- orderly_validate_archive_packet(id, action, cache, root)
+  }
+  res <- as.list(cache)
+  invalid <- sort(names(Filter(function(x) !x$valid, res)))
+  if (length(invalid) > 0) {
+    root$index$rebuild()
+  }
+  invisible(invalid)
+}
+
+
+orderly_validate_archive_packet <- function(id, action, cache, root) {
+  if (!is.null(cache[[id]])) {
+    return(cache[[id]])
+  }
+
+  res <- orderly_validate_archive_packet_check(id, action, cache, root)
+  cache[[id]] <- res
+
+  if (res$valid) {
+    cli::cli_alert_success("{res$id} ({res$name}) is valid")
+  } else {
+    reason <- c(if (!all(res$files$valid)) "files",
+                if (!all(res$depends$valid)) "upstream packets")
+    cli::cli_alert_danger(
+      "{res$id} ({res$name}) is invalid due to its {reason}")
+    if (action == "orphan") {
+      drop_local_packet(id, root)
+    } else if (action == "delete") {
+      drop_local_packet(id, root)
+      unlink(file.path(root$path, root$config$core$path_archive, res$name, id),
+             recursive = TRUE)
+    }
+  }
+
+  res
+}
+
+
+orderly_validate_archive_packet_check <- function(id, action, cache, root) {
+  meta <- outpack_metadata_core(id, root)
+  name <- meta$name
+  path <- file.path(root$path, root$config$core$path_archive, name, id)
+
+  depends <- meta$depends
+  depends$valid <- rep(TRUE, nrow(depends))
+  if (root$config$core$require_complete_tree) {
+    for (i in seq_len(nrow(depends))) {
+      depends$valid[[i]] <- orderly_validate_archive_packet(
+        depends$packet[[i]], action, cache, root)$valid
+    }
+  }
+
+  hash_compare <- function(path, hash) {
+    if (!file.exists(path)) NA_character_ else rehash(path, hash_file, hash)
+  }
+  files <- meta$files
+  files$hash_found <- list_to_character(
+    Map(hash_compare, file.path(path, files$path), files$hash))
+  files$valid <- !is.na(files$hash_found) & files$hash_found == files$hash
+
+  valid <- all(files$valid) && all(depends$valid)
+
+  list(valid = valid, id = id, name = name, files = files, depends = depends)
+}

_pkgdown.yml

@@ -80,3 +80,4 @@ reference:
     contents:
       - orderly_copy_files
       - orderly_example
+      - orderly_validate_archive