remove shell scripts and add dry run script

DESCRIPTION

@@ -28,21 +28,20 @@ Depends:
 Imports: 
     curl,
     httr2 (>= 0.2.2),
+    jsonlite,
     rappdirs,
     stats,
     utils,
     withr
 Suggests: 
     httptest2,
-    jsonlite,
     kableExtra,
     knitr,
     purrr,
     readr,
     rmarkdown,
     spelling,
-    testthat (>= 3.0.0),
-    xml2
+    testthat (>= 3.0.0)
 VignetteBuilder: 
     knitr
 Config/testthat/edition: 3

R/irods-demo.R

@@ -90,25 +90,33 @@ use_irods_demo <- function(user = character(), pass = character(),
 
   # Sometimes it just does not want to start right. This will perform a dry run
   # and restart the process again. This usually does the trick.
-  dry_run_irods(user, pass, recreate)
+  dry_run_irods(
+    user,
+    pass,
+    "http://localhost:9001/irods-http-api/0.1.0",
+    paste0("/tempZone/home/", user),
+    verbose
+  )
 
-  if (isTRUE(verbose)) {
-    message(
-      "\n",
-      "Do the following to connect with the iRODS demo server: \n",
-      "create_irods(\"http://localhost:9001/irods-http-api/0.1.0\") \n",
-      "iauth(\"", user, "\", \"", pass, "\")"
-    )
-  }
+  message(
+    "\n",
+    "Do the following to connect with the iRODS demo server: \n",
+    "create_irods(\"http://localhost:9001/irods-http-api/0.1.0\") \n",
+    "iauth(\"", user, "\", \"", pass, "\")"
+  )
 
   invisible(NULL)
 }
 #' @rdname use_irods_demo
 #'
 #' @export
-stop_irods_demo <- function() {
-  system(paste0("cd ", path_to_demo(), " ; docker compose down"))
-  invisible()
+stop_irods_demo <- function(verbose = TRUE) {
+  system(
+    paste0("cd ", path_to_demo(), " ; docker compose down"),
+    ignore.stdout = !verbose,
+    ignore.stderr = !verbose
+  )
+  invisible(NULL)
 }
 
 #' Predicate for iRODS Demonstration Service State
@@ -180,28 +188,51 @@ start_irods <- function(verbose, recreate = TRUE) {
 path_to_demo <- function() system.file("irods_demo", package = "rirods")
 
 # perform dry run to see if iRODS can be used
-dry_run_irods <- function(user, pass, recreate) {
-  tryCatch(
-    {local_create_irods(); iauth(user, pass); ils()},
-    error = function(err)  {
-      if (isFALSE(recreate)) {
-        message(
-          "\nThere seems to be a problem with the iRODS demo ",
-          "server. \nThe problem might be solved by rebooting the server. ",
-          "\nThis action will destroy all content on the server!\n"
-        )
-        recreate <- utils::askYesNo("Can I reboot the server?", default = FALSE)
-      }
+dry_run_irods <- function(user, pass, host, lpath, verbose, user_input = FALSE) {
+
+  irods_server_status <- is_irods_server_operational(user, pass, host, lpath)
 
-      if (isTRUE(recreate)) {
-        message("\nThis may take a while!\n")
-        start_irods(recreate)
-        use_irods_demo(user, pass, recreate, verbose = FALSE)
-      } else {
-        stop("The iRODS server could not be started!", call. = FALSE)
-      }
+  while (!irods_server_status) {
+    if (isFALSE(user_input)) {
+      message(
+        "\nThere seems to be a problem with the iRODS demo ",
+        "server. \nThe problem might be solved by rebooting the server. ",
+        "\nThis action will destroy all content on the server!\n"
+      )
+      user_input <- utils::askYesNo("Can I reboot the server?", default = FALSE)
     }
-  )
+    if (isTRUE(user_input)) {
+      if (verbose) message("\nRecreating iRODS demo. This may take a while!\n")
+      start_irods(verbose, recreate = TRUE)
+    } else{
+      stop("The iRODS server could not be started!", call. = FALSE)
+    }
+
+    irods_server_status <- is_irods_server_operational(user, pass, host, lpath)
+  }
+}
+
+is_irods_server_operational <- function(user, pass, host, lpath) {
+  Sys.sleep(3) # requires some time to stand up
+  is_irods_server_running_correct() &&
+    is_http_server_running_correct(user, pass, host, lpath)
+}
+
+is_http_server_running_correct <- function(user, pass, host, lpath) {
+  system2(
+    system.file(package = "rirods", "shell_scripts", "dry-run-irods-curl.sh"),
+    c(user, pass, host, lpath),
+    stdout = FALSE,
+    stderr = FALSE
+  ) == 0
+}
+
+is_irods_server_running_correct <- function() {
+  system2(
+    system.file(package = "rirods", "shell_scripts", "dry-run-irods-icommands.sh"),
+    stdout = FALSE,
+    stderr = FALSE
+  ) == 0
 }
 
 # look up table for irods_demo images

inst/httptest2/redact.R

@@ -1,21 +1,42 @@
 function (response) {
 
+  grep_json_body_element <- function(response, element) {
+    response_R_body <- jsonlite::fromJSON(rawToChar(response$body))
+    response_R_body[[element]] <- character(1)
+    response$body <- charToRaw(jsonlite::toJSON(response_R_body,  auto_unbox = TRUE))
+    response
+  }
+
   # mask host in headers
   response$url <- gsub(rirods:::find_irods_file("host"), "", response$url, fixed = TRUE)
 
-  # token
-  if (inherits(response, "httr2_response")) {
-    response$request$headers$Authorization  <- ""
-  }
-
   # mask dates in headers
   response$headers$Date <- ""
 
-  # change body upon PUT when type is raw (`iput()` and `isaverds()`)
-  if (inherits(response, "httr2_request") &&
-      inherits(response$body$data$bytes,  "form_data")) {
-    response$body$data <- NULL
+  if (inherits(response, "httr2_response")) {
+    if (grepl("op=stat", response$request$url)) {
+      response <- grep_json_body_element(response, "modified_at") # stat
+    }
+
+    if (response$method != "GET" && response$request$body$data$op == "parallel_write_init") {
+      response <- grep_json_body_element(response, "parallel_write_handle") # mask token for init and shutdown
+    }
+    if (response$method != "GET" && response$request$body$data$op == "parallel_write_shutdown") {
+      response$request$body$data$`parallel-write-handle` <- character(1)
+    }
+    response$request$headers$Authorization  <- "" # token
+  }
+
+  if (inherits(response, "httr2_request")) {
+    if (inherits(response$body$data$bytes,  "form_data")) {
+      # change body upon PUT when type is raw (`iput()` and `isaverds()`)
+      response$body$data <- NULL
+    } else if (response$method != "GET" && response$body$data$op == "parallel_write_shutdown") {
+      response$body$data$`parallel-write-handle` <- character(1)
+    }
   }
 
   response
 }
+
+

inst/shell_scripts/dry-run-irods-curl.sh

@@ -0,0 +1,10 @@
+#!/bin/sh
+
+# get token
+TOKEN=$(curl -X POST -u "$1:$2" "http://localhost:9001/irods-http-api/0.1.0/authenticate")
+
+curl -G "$3/collections"\
+    -H "Authorization: Bearer ${TOKEN}" \
+    --data-urlencode 'op=list' \
+    --data-urlencode "lpath=$4" \
+    --data-urlencode "recurse=0" | grep -o "\"status_code\":[0-9]*"

inst/shell_scripts/dry-run-irods-icommands.sh

@@ -0,0 +1,8 @@
+#!/bin/sh
+
+DIR="$(dirname "$(realpath "$0")")"
+
+cd $DIR
+cd ../irods_demo
+
+docker exec irods_demo-irods-client-icommands-1 ils