Merge pull request #528 from hivtools/nm-45

[NM-45] Add some validation to project rehydration endpoint

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: hintr
 Title: R API for calling naomi district level HIV model
-Version: 1.2.2
+Version: 1.2.3
 Authors@R: 
     person(given = "Robert",
            family = "Ashton",

NEWS.md

@@ -1,3 +1,9 @@
+# hintr 1.2.3
+
+* Add checks that a rehydrated project is valid. It checks that:
+   * All input files exist on disk
+   * The model fit and calibrate IDs are known in redis
+
 # hintr 1.2.2
 
 * Fix issue where if shape file was uploaded with no `display` property it was raising an error when fetching input metadata. Now if no `display` property is set, it will include it in the returned metadata.
@@ -8,9 +14,6 @@
    * Not starting workers automatically when you create a queue
    * Only removing the workers a queue creates by default
    * Only deleting data if you explicitly opt in
-
-# hintr 1.2.1
-
 * Add new endpoint `/download/result/path/<id>` to return path to the download file on disk
 
 # hintr 1.2.0

R/queue.R

@@ -166,6 +166,10 @@ Queue <- R6::R6Class(
       rrq::rrq_task_cancel(id, controller = self$controller)
     },
 
+    exists = function(id) {
+      rrq::rrq_task_exists(id, controller = self$controller)
+    },
+
     ## Not part of the api exposed functions, used in tests
     remove = function(id) {
       rrq::rrq_task_delete(id, controller = self$controller)

R/rehydrate.R

@@ -34,9 +34,39 @@ rehydrate_submit <- function(queue) {
 rehydrate_result <- function(queue) {
   function(id) {
     res <- queue$result(id)
-    if (is_error(res)) {
-      hintr_error(api_error_msg(res), "PROJECT_REHYDRATE_FAILED")
-    }
+    validate_rehydrate_result(queue, res)
     res
   }
 }
+
+validate_rehydrate_result <- function(queue, res) {
+  if (is_error(res)) {
+    hintr_error(api_error_msg(res), "PROJECT_REHYDRATE_FAILED")
+  }
+  state <- jsonlite::fromJSON(res$state, simplifyVector = FALSE)
+
+  ## Input files must exist on disk
+  lapply(names(state$datasets), function(dataset_name) {
+    data_path <- state$datasets[[dataset_name]]$path
+    if (!is.null(queue$inputs_dir)) {
+      data_path <- file.path(queue$inputs_dir, basename(data_path))
+    }
+
+    if (!file.exists(data_path)) {
+      hintr_error(t_("REHYDRATE_MISSING_INPUT_FILE"),
+                  "PROJECT_REHYDRATE_FAILED")
+    }
+  })
+
+  ## IDs must exist in redis
+  if (!queue$exists(state$model_fit$id)) {
+    hintr_error(t_("REHYDRATE_MODEL_FIT_ID_UNKNOWN"),
+                "PROJECT_REHYDRATE_FAILED")
+  }
+  if (!queue$exists(state$calibrate$id)) {
+    hintr_error(t_("REHYDRATE_CALIBRATE_ID_UNKNOWN"),
+                "PROJECT_REHYDRATE_FAILED")
+  }
+  invisible(TRUE)
+}
+

inst/traduire/en-translation.json

@@ -76,6 +76,9 @@
     "OUTPUT_TABLE_PRESETS": "Presets",
     "OUTPUT_BUBBLE_SIZE_INDICATOR": "Size Indicator",
     "OUTPUT_BUBBLE_COLOUR_INDICATOR": "Colour Indicator",
+    "REHYDRATE_MISSING_INPUT_FILE": "Unable to load output zip, input files not found. Please contact a system admin.",
+    "REHYDRATE_MODEL_FIT_ID_UNKNOWN": "Unable to load output zip, model fit not generated on the web app. Please contact a system admin.",
+    "REHYDRATE_CALIBRATE_ID_UNKNOWN": "Unable to load output zip, model calibrate not generated on the web app. Please contact a system admin.",
     "REVIEW_INPUT_DATA_SOURCE": "Data Source",
     "REVIEW_INPUT_ANC": "ANC testing",
     "REVIEW_INPUT_PROGRAMME": "ART",

inst/traduire/fr-translation.json

@@ -76,6 +76,9 @@
     "OUTPUT_TABLE_PRESETS": "Préconfigurations",
     "OUTPUT_BUBBLE_SIZE_INDICATOR": "Indicateur de Taille",
     "OUTPUT_BUBBLE_COLOUR_INDICATOR": "Indicateur de Couleur",
+    "REHYDRATE_MISSING_INPUT_FILE": "Impossible de charger le fichier zip de sortie, les fichiers d'entrée n'ont pas été trouvés. Veuillez contacter un administrateur système.",
+    "REHYDRATE_MODEL_FIT_ID_UNKNOWN": "Impossible de charger le zip de sortie, l'ajustement du modèle n'a pas été généré sur l'application web. Veuillez contacter un administrateur système.",
+    "REHYDRATE_CALIBRATE_ID_UNKNOWN": "Impossible de charger le fichier zip de sortie, le calibrage du modèle n'a pas été généré sur l'application web. Veuillez contacter un administrateur système.",
     "REVIEW_INPUT_DATA_SOURCE": "La Source de Données",
     "REVIEW_INPUT_ANC": "Test de clinique prénatale",
     "REVIEW_INPUT_PROGRAMME": "TARV",

inst/traduire/pt-translation.json

@@ -36,6 +36,9 @@
     "OUTPUT_TABLE_PRESETS": "Predefinições",
     "OUTPUT_BUBBLE_SIZE_INDICATOR": "Indicador de Tamanho",
     "OUTPUT_BUBBLE_COLOUR_INDICATOR": "Indicador de Cor",
+    "REHYDRATE_MISSING_INPUT_FILE": "Não é possível carregar o zip de saída, os ficheiros de entrada não foram encontrados. Contacte um administrador do sistema.",
+    "REHYDRATE_MODEL_FIT_ID_UNKNOWN": "Não é possível carregar o zip de saída, o ajuste do modelo não foi gerado na aplicação Web. Contacte um administrador do sistema.",
+    "REHYDRATE_CALIBRATE_ID_UNKNOWN": "Não é possível carregar o zip de saída, a calibração do modelo não foi gerada na aplicação Web. Contacte um administrador do sistema.",
     "REVIEW_INPUT_DATA_SOURCE": "Fonte de Dados",
     "REVIEW_INPUT_ANC": "Teste da CPN",
     "REVIEW_INPUT_PROGRAMME": "TARV",

scripts/download_payload.json

@@ -11,27 +11,27 @@
   "state": {
     "datasets": {
       "pjnz":{
-        "path":"72A9B1F58AAA743ADA64C6AE985CF228.pjnz",
+        "path":"Malawi2019.PJNZ",
         "filename":"demo_mwi2019.pjnz"
       },
       "population":{
-        "path":"651105353D7153381ED29363DF0D772F.csv",
+        "path":"population.csv",
         "filename":"demo_population_agesex.csv"
       },
       "shape":{
-        "path":"EBE533976BFAF0CABCA2C2E1B611B9C7.geojson",
+        "path":"malawi.geojson",
         "filename":"demo_areas.geojson"
       },
       "survey":{
-        "path":"F669CA9AA38A3993B5A9E9D3EB717C7D.csv",
+        "path":"survey.csv",
         "filename":"demo_survey_hiv_indicators.csv"
       },
       "programme":{
-        "path":"8301300AB39BE177FA593571B9DD94C4.csv",
+        "path":"programme.csv",
         "filename":"demo_art_number.csv"
       },
       "anc":{
-        "path":"E6323AAEB045D31E4A267398F669CF20.csv",
+        "path":"anc.csv",
         "filename":"demo_anc_testing.csv"
       }
     },

tests/testthat/helper-queue.R

@@ -52,8 +52,16 @@ create_blocking_worker <- function(controller, worker_name = NULL) {
 
 test_queue_result <- function(model = mock_model,
                               calibrate = mock_calibrate,
-                              clone_output = TRUE) {
-  queue <- Queue$new(workers = 1, timeout = 300, delete_data_on_exit = TRUE)
+                              clone_output = TRUE,
+                              inputs_dir = NULL) {
+  queue <- Queue$new(workers = 1, timeout = 300,
+                     delete_data_on_exit = TRUE,
+                     inputs_dir = inputs_dir)
+  ## Replace exists function so when testing rehydrate we avoid
+  ## validation issues
+  unlockBinding("exists", queue)
+  queue$exists <- function(id) TRUE
+  lockBinding("exists", queue)
   withr::defer_parent({
     message("cleaning up workers")
     queue$cleanup()

tests/testthat/integration-server.R

@@ -856,16 +856,14 @@ test_that("rehydrate", {
     expect_equal(response$data$status, "COMPLETE")
   })
 
-  ## Result
+  ## Result is going to fail validation as we are rehydrating from data
+  ## created via another queue. So input files and IDs are not known
+  ## enough to check that we get a response here I think
   r <- server$request("GET", paste0("/rehydrate/result/", id))
-  expect_equal(httr::status_code(r), 200)
+  expect_equal(httr::status_code(r), 400)
   response <- response_from_json(r)
-  expect_equal(response$status, "success")
-  expect_equal(response$errors, NULL)
-  expect_setequal(names(response$data$state),
-                  c("datasets", "model_fit", "calibrate", "version"))
-  expect_setequal(
-    names(response$data$state$datasets),
-    c("pjnz", "population", "shape", "survey", "programme", "anc"))
-  expect_match(response$data$notes, "These are my project notes")
+  expect_equal(response$status, "failure")
+  expect_equal(response$errors[[1]]$error, "PROJECT_REHYDRATE_FAILED")
+  expect_match(response$errors[[1]]$detail,
+               "Unable to load output zip, input files not found\\.")
 })

tests/testthat/test-endpoints-rehydrate.R

@@ -15,7 +15,7 @@ test_that("rehydrate returns json", {
 
 test_that("rehydrate endpoint returns json", {
   test_mock_model_available()
-  q <- test_queue_result()
+  q <- test_queue_result(inputs_dir = normalizePath(test_path("testdata")))
 
   ## Submit rehydrate request
   payload <- setup_payload_rehydrate()
@@ -54,7 +54,7 @@ test_that("rehydrate endpoint returns json", {
 test_that("api can call spectrum download", {
   test_redis_available()
   test_mock_model_available()
-  q <- test_queue_result()
+  q <- test_queue_result(inputs_dir = normalizePath(test_path("testdata")))
   api <- api_build(q$queue)
 
   ## Submit rehydrate request
@@ -95,10 +95,10 @@ test_that("api can call spectrum download", {
 
 test_that("rehydrate returns useful error if cannot rehydrate from zip", {
   test_mock_model_available()
-  q <- test_queue_result()
+  q <- test_queue_result(inputs_dir = normalizePath(test_path("testdata")))
 
   ## Submit rehydrate request which will error
-  payload <- setup_payload_rehydrate("testdata/Malawi2019.PJNZ")
+  payload <- setup_payload_rehydrate(test_path("testdata/Botswana2018.PJNZ"))
   submit <- endpoint_rehydrate_submit(q$queue)
   submit_response <- submit$run(payload)
   expect_equal(submit_response$status_code, 200)
@@ -118,7 +118,7 @@ test_that("rehydrate returns useful error if cannot rehydrate from zip", {
 
 test_that("rehydrate returns useful error when submission fails", {
   test_mock_model_available()
-  q <- test_queue_result()
+  q <- test_queue_result(inputs_dir = normalizePath(test_path("testdata")))
 
   payload <- setup_payload_rehydrate("missing/file.zip")
   submit <- endpoint_rehydrate_submit(q$queue)
@@ -155,3 +155,77 @@ test_that("trying to rehydrate with no notes does not error", {
 
   expect_null(out$notes)
 })
+
+test_that("rehydrate throws error if input files are unknown", {
+  payload <- setup_payload_rehydrate()
+  input <- jsonlite::fromJSON(payload)
+  out <- rehydrate(input$file)
+
+  mock_queue <- list(
+    inputs_dir = tempdir(),
+    result = function(id) out
+  )
+
+  get_rehydrate_result <- rehydrate_result(mock_queue)
+
+  error <- expect_error(get_rehydrate_result("123"))
+  expect_equal(error$data[[1]]$error, scalar("PROJECT_REHYDRATE_FAILED"))
+  expect_match(error$data[[1]]$detail,
+               scalar("Unable to load output zip, input files not found\\."))
+  expect_equal(error$status_code, 400)
+})
+
+test_that("rehydrate throws error if model fit or calibrate IDs are unknown", {
+  payload <- setup_payload_rehydrate()
+  input <- jsonlite::fromJSON(payload)
+  out <- rehydrate(input$file)
+  state <- jsonlite::fromJSON(out$state, simplifyVector = FALSE)
+  state$datasets[["pjnz"]]$path <- "Malawi2019.PJNZ"
+  state$datasets[["population"]]$path <- "population.csv"
+  state$datasets[["shape"]]$path <- "malawi.geojson"
+  state$datasets[["survey"]]$path <- "survey.csv"
+  state$datasets[["programme"]]$path <- "programme.csv"
+  state$datasets[["anc"]]$path <- "anc.csv"
+  out$state <- jsonlite::toJSON(state, auto_unbox = TRUE)
+
+  mock_exists <- function(id) {
+    FALSE
+  }
+  mock_queue <- list(
+    inputs_dir = normalizePath(test_path("testdata")),
+    result = function(id) out,
+    exists = mock_exists
+  )
+
+  get_rehydrate_result <- rehydrate_result(mock_queue)
+
+  error <- expect_error(get_rehydrate_result("123"))
+  expect_equal(error$data[[1]]$error, scalar("PROJECT_REHYDRATE_FAILED"))
+  expect_match(error$data[[1]]$detail,
+               scalar(paste("Unable to load output zip, model",
+                            "fit not generated on the web app\\.")))
+  expect_equal(error$status_code, 400)
+
+  ## Missing calibrate ID
+  mock_exists <- function(id) {
+    if (id == state$model_fit$id) {
+      TRUE
+    } else {
+      FALSE
+    }
+  }
+  mock_queue <- list(
+    inputs_dir = normalizePath(test_path("testdata")),
+    result = function(id) out,
+    exists = mock_exists
+  )
+
+  get_rehydrate_result <- rehydrate_result(mock_queue)
+
+  error <- expect_error(get_rehydrate_result("123"))
+  expect_equal(error$data[[1]]$error, scalar("PROJECT_REHYDRATE_FAILED"))
+  expect_match(error$data[[1]]$detail,
+               scalar(paste("Unable to load output zip, model calibrate",
+                            "not generated on the web app\\.")))
+  expect_equal(error$status_code, 400)
+})