wip, need to complete tests

.github/workflows/test-coverage.yaml

@@ -38,6 +38,8 @@ jobs:
             install_path = file.path(Sys.getenv("RUNNER_TEMP"), "package")
           )
         shell: Rscript {0}
+        env:
+          TEST_PRIVATE_REPO_SSH_KEY: ${{ secrets.TEST_PRIVATE_REPO_SSH_KEY }}
 
       - name: Show testthat output
         if: always()

.gitignore

@@ -15,3 +15,4 @@ docs
 .valgrind_ignore
 inst/doc
 pkgdown
+logs

R/api.R

@@ -51,19 +51,20 @@ root <- function() {
 
 
 ##' @porcelain POST /repository/fetch => json(repository_fetch_response)
-##'   state repositories_base_path :: repositories_base_path
+##'   query url :: string
 ##'   body data :: json(repository_fetch_request)
-repository_fetch <- function(repositories_base_path, data) {
+##'   state repositories_base_path :: repositories_base_path
+repository_fetch <- function(repositories_base_path, url, data) {
   data <- jsonlite::parse_json(data)
-  r <- git_sync(repositories_base_path, data$url)
+  r <- git_sync(repositories_base_path, url, data$ssh_key)
 
   empty_object()
 }
 
 
 ##' @porcelain GET /repository/branches => json(repository_branches)
-##'   state repositories_base_path :: repositories_base_path
 ##'   query url :: string
+##'   state repositories_base_path :: repositories_base_path
 repository_branches <- function(repositories_base_path, url) {
   repo <- repository_path(repositories_base_path, url)
   branches <- git_remote_list_branches(repo)
@@ -123,17 +124,19 @@ report_parameters <- function(repositories_base_path, url, ref, name) {
 
 ##' @porcelain
 ##'   POST /report/run => json(report_run_response)
-##'   state queue :: queue
+##'   query url :: string
 ##'   body data :: json(report_run_request)
-submit_report_run <- function(queue, data) {
+##'   state queue :: queue
+submit_report_run <- function(queue, url, data) {
   data <- jsonlite::parse_json(data)
   task_id <- queue$submit(
-    data$name,
-    url = data$url,
+    reportname = data$name,
+    url = url,
     branch = data$branch,
     ref = data$hash,
     parameters = data$parameters,
-    location = data$location
+    location = data$location,
+    ssh_key = data$ssh_key
   )
   list(taskId = scalar(task_id))
 }

R/git.R

@@ -25,14 +25,22 @@ repository_path <- function(base, url, check = TRUE) {
 #'
 #' @param base the base directory in which all repositories are stored.
 #' @param url the URL of the remote repository.
+#' @param ssh_key private SSH key as a character vector (separated by newline characters)
+#'   for connecting to private repositories (Optional, default is NULL).
 #' @return the path to the local clone of the repository.
-git_sync <- function(base, url) {
-  repo <- repository_path(base, url, check = FALSE)
-  if (!fs::dir_exists(repo)) {
-    gert::git_clone(url = url, path = repo, bare = TRUE, verbose = FALSE)
-  } else {
-    gert::git_fetch(repo = repo, prune = TRUE, verbose = FALSE)
+git_sync <- function(base, url, ssh_key = NULL) {
+  if (!is.null(ssh_key)) {
+    ssh_key <- withr::local_tempfile(lines = ssh_key)
   }
+  repo <- repository_path(base, url, check = FALSE)
+  withr::with_envvar(new = c("SSH_AUTH_SOCK" = NA), {
+    if (!fs::dir_exists(repo)) {
+      gert::git_clone(url = url, path = repo, bare = TRUE, verbose = FALSE, ssh_key = ssh_key)
+    } else {
+      gert::git_fetch(repo = repo, prune = TRUE, verbose = FALSE, ssh_key = ssh_key)
+    }
+  })
+
   repo
 }
 

R/queue.R

@@ -36,14 +36,17 @@ Queue <- R6::R6Class("Queue", # nolint
     #' @param parameters Parameters to run the report with.
     #' @param location Location of the outpack repository from which to pull
     #'   dependencies and push the produced packet.
-    submit = function(url, branch, ref, reportname, parameters, location) {
+    #' @param ssh_key private SSH key as a character vector (separated by newline characters)
+    #'   for connecting to private repositories (Optional, default is NULL).
+    submit = function(url, branch, ref, reportname, parameters, location, ssh_key = NULL) {
       run_args <- list(
         url,
         branch,
         ref,
         reportname,
         parameters,
-        location
+        location,
+        ssh_key
       )
       rrq::rrq_task_create_call(runner_run, run_args,
         separate_process = TRUE,

R/runner.R

@@ -1,11 +1,11 @@
-runner_run <- function(url, branch, ref, reportname, parameters, location, ...) {
+runner_run <- function(url, branch, ref, reportname, parameters, location, ssh_key = NULL, ...) {
   storage <- Sys.getenv("ORDERLY_WORKER_STORAGE")
   stopifnot(nzchar(storage) && fs::dir_exists(storage))
 
   repositories <- fs::dir_create(storage, "git")
   worktree_base <- fs::dir_create(storage, "worktrees")
 
-  repo <- git_sync(repositories, url)
+  repo <- git_sync(repositories, url, ssh_key)
 
   # We could create the worktree with a detached HEAD and not bother with
   # creating the branch, but then Orderly's metadata wouldn't be as complete.

inst/schema/report_run_request.json

@@ -2,7 +2,7 @@
     "$schema": "http://json-schema.org/draft-07/schema#",
     "type": "object",
     "properties": {
-        "url": {
+        "ssh_key": {
             "type": "string"
         },
         "branch": {
@@ -38,6 +38,6 @@
             }
         }
     },
-    "required": ["url", "branch", "hash", "name", "parameters", "location"],
+    "required": ["branch", "hash", "name", "parameters", "location"],
     "additionalProperties": false
 }

inst/schema/repository_fetch_request.json

@@ -2,7 +2,6 @@
     "$schema": "http://json-schema.org/draft-07/schema#",
     "type": "object",
     "properties": {
-        "url": { "type": "string" }
-    },
-    "required": [ "url" ]
+        "ssh_key": { "type": "string" }
+    }
 }

tests/testthat/helper-orderly-runner.R

@@ -25,6 +25,25 @@ skip_if_no_redis <- function() {
 }
 
 
+skip_if_no_test_private_repo_ssh_key <- function() {
+  ssh_key <- Sys.getenv("TEST_PRIVATE_REPO_SSH_KEY", unset = NA)
+  if (is.na(ssh_key)) {
+    testthat::skip("Skipping test as TEST_PRIVATE_REPO_SSH_KEY is not set")
+  }
+  ssh_key <- strsplit(ssh_key, "\n")
+
+  list(
+    ssh_key = ssh_key,
+    url = "git@github.com:mrc-ide/orderly.runner-private-test-repo.git"
+  )
+}
+
+
+empty_json_object <- function() {
+  jsonlite::toJSON(empty_object())
+}
+
+
 create_temporary_root <- function(..., env = parent.frame()) {
   path <- withr::local_tempdir(.local_envir = env)
   suppressMessages(orderly2::orderly_init(path, ...))