Add an API to fetch repositories and list their branches.

DESCRIPTION

@@ -8,7 +8,7 @@ Authors@R: c(person("Rich", "FitzJohn", role = c("aut", "cre"),
 Description: Small HTTP server for running orderly reports.
 License: MIT + file LICENSE
 Encoding: UTF-8
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2
 Roxygen: list(markdown = TRUE, roclets = c("rd", "namespace", "porcelain::porcelain_roclet"))
 URL: https://github.com/mrc-ide/orderly.runner
 BugReports: https://github.com/mrc-ide/orderly.runner/issues
@@ -21,6 +21,7 @@ Imports:
     ids,
     jsonlite,
     orderly2 (>= 1.99.13),
+    openssl,
     porcelain,
     R6,
     redux,

R/api.R

@@ -4,6 +4,9 @@
 ##'
 ##' @param root Orderly root
 ##'
+##' @param repositories_base_path Path in which Git repositories are
+##'   cloned.
+##'
 ##' @param validate Logical, indicating if validation should be done
 ##'   on responses.  This should be `FALSE` in production
 ##'   environments.  See [porcelain::porcelain] for details
@@ -19,7 +22,8 @@
 ##'
 ##' @export
 api <- function(
-    root, validate = NULL, log_level = "info",
+    root, repositories_base_path,
+    validate = NULL, log_level = "info",
     skip_queue_creation = FALSE) {
   logger <- porcelain::porcelain_logger(log_level)
 
@@ -31,7 +35,10 @@ api <- function(
   }
 
   api <- porcelain::porcelain$new(validate = validate, logger = logger)
-  api$include_package_endpoints(state = list(root = root, queue = queue))
+  api$include_package_endpoints(state = list(
+    root = root,
+    repositories_base_path = repositories_base_path,
+    queue = queue))
   api
 }
 
@@ -46,6 +53,41 @@ root <- function() {
 }
 
 
+##' @porcelain POST /repository/fetch => json(repository_fetch_response)
+##'   state repositories_base_path :: repositories_base_path
+##'   body data :: json(repository_fetch_request)
+repository_fetch <- function(repositories_base_path, data) {
+  data <- jsonlite::parse_json(data)
+  r <- git_sync(repositories_base_path, data$url)
+
+  empty_object()
+}
+
+
+##' @porcelain GET /repository/branches => json(repository_branches)
+##'   state repositories_base_path :: repositories_base_path
+##'   query url :: string
+repository_branches <- function(repositories_base_path, url) {
+  repo <- repository_path(repositories_base_path, url)
+  branches <- git_remote_list_branches(repo)
+  message <- vcapply(branches$commit, function(commit) {
+    gert::git_commit_info(repo = repo, ref = commit)$message
+  })
+
+  branches$message <- message
+  list(
+    default_branch = scalar(git_remote_default_branch_name(repo)),
+    branches = data.frame(
+      name = branches$name,
+      commit_hash = branches$commit,
+      time = as.numeric(branches$updated),
+      message = message,
+      row.names = NULL
+    )
+  )
+}
+
+
 ##' @porcelain
 ##'   GET /report/list => json(report_list)
 ##'   query ref :: string

R/git.R

@@ -1,3 +1,48 @@
+#' Get the storage path for a repository.
+#'
+#' Repositories are all stored as subdirectories of a common base path,
+#' using a hash of their URL as the directory name.
+#'
+#' @param base the base directory in which all repositories are stored.
+#' @param url the URL of the remote repository.
+#' @param check if TRUE and the repository does not exist locally yet, an error
+#'   is raised.
+#' @return the path to the repository.
+repository_path <- function(base, url, check = TRUE) {
+  hash <- openssl::sha1(url)
+  path <- file.path(base, hash)
+  if (check && !fs::dir_exists(path)) {
+    porcelain::porcelain_stop(
+      message = "Repository does not exist",
+      code = "NOT_FOUND",
+      status_code = 404)
+  }
+  path
+}
+
+
+#' Clone or fetch a remote repository.
+#'
+#' @param base the base directory in which all repositories are stored.
+#' @param url the URL of the remote repository.
+#' @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)
+  }
+  repo
+}
+
+git_remote_list_branches <- function(repo) {
+  branches <- gert::git_branch_list(repo, local = FALSE)
+  branches$name <- gsub("^refs/remotes/origin/", "", branches$ref)
+  branches <- branches[branches$name != "HEAD", ]
+  branches
+}
+
 git_run <- function(args, repo = NULL, check = FALSE) {
   git <- sys_which("git")
   if (!is.null(repo)) {
@@ -12,7 +57,7 @@ git_run <- function(args, repo = NULL, check = FALSE) {
 }
 
 
-git_get_default_branch <- function(repo = NULL) {
+git_remote_default_branch_ref <- function(repo) {
   # This is assuming remote origin exists. We'll get an error if it
   # doesn't. But this should be safe for us as we'll always have cloned
   # this from GitHub.
@@ -21,10 +66,20 @@ git_get_default_branch <- function(repo = NULL) {
 }
 
 
+git_remote_default_branch_name <- function(repo) {
+  ref <- git_remote_default_branch_ref(repo)
+  if (!is.null(ref)) {
+    gsub("^refs/remotes/origin/", "", ref)
+  } else {
+    NULL
+  }
+}
+
+
 git_get_modified <- function(ref, base = NULL, 
                              relative_dir = NULL, repo = NULL) {
   if (is.null(base)) {
-    base <- git_get_default_branch(repo)
+    base <- git_remote_default_branch_ref(repo)
   }
   if (is.null(relative_dir)) {
     relative <- ""

R/main.R

@@ -1,6 +1,6 @@
 parse_main <- function(args = commandArgs(TRUE)) {
   usage <- "Usage:
-orderly.runner.server [options] <path>
+orderly.runner.server [options] <path> <repositories>
 
 Options:
   --log-level=LEVEL  Log-level (off, info, all) [default: info]
@@ -12,12 +12,13 @@ Options:
        validate = dat$validate,
        port = as.integer(dat$port),
        path = dat$path,
+       repositories = dat$repositories,
        host = dat$host)
 }
 
 main <- function(args = commandArgs(TRUE)) {
   dat <- parse_main(args)
-  api_obj <- api(dat$path, dat$validate, dat$log_level)
+  api_obj <- api(dat$path, dat$repositories, dat$validate, dat$log_level)
   api_obj$run(host = dat$host, port = dat$port)
 }
 

R/util.R

@@ -7,6 +7,15 @@ scalar <- function(x) {
   jsonlite::unbox(x)
 }
 
+empty_object <- function(x) {
+  # This is needed to get an empty JSON object.
+  # list() is `[]` and NULL may be `null` depending on the options passed to
+  # toJSON.
+  x <- list()
+  names(x) <- character(0)
+  x
+}
+
 
 package_version_string <- function(name) {
   as.character(utils::packageVersion(name))

docker/test/run-test

@@ -37,7 +37,8 @@ docker run --rm -d --pull=always \
        -v $ORDERLY_VOLUME:$CONTAINER_ORDERLY_ROOT_PATH \
        -v $ORDERLY_LOGS_VOLUME:$LOGS_DIR \
        $ORDERLY_RUNNER_IMAGE \
-       $CONTAINER_ORDERLY_ROOT_PATH
+       $CONTAINER_ORDERLY_ROOT_PATH \
+       /repositories
 
 docker run --rm -d --pull=always \
        --net=$NETWORK \

inst/schema/repository_branches.json

@@ -0,0 +1,39 @@
+{
+    "$schema": "http://json-schema.org/draft-07/schema#",
+    "type": "object",
+    "properties": {
+        "branches": {
+            "type": "array",
+            "items": {
+                "type": "object",
+                "properties": {
+                    "name": {
+                        "type": "string"
+                    },
+                    "commit_hash": {
+                        "type": "string"
+                    },
+                    "message": {
+                        "type": "string"
+                    },
+                    "time": {
+                        "type": "number"
+                    }
+                },
+                "required": [
+                    "name",
+                    "commit_hash",
+                    "message",
+                    "time"
+                ]
+            }
+        },
+        "default_branch": {
+            "type": "string"
+        }
+    },
+    "required": [
+        "branches",
+        "default_branch"
+    ]
+}

inst/schema/repository_fetch_request.json

@@ -0,0 +1,8 @@
+{
+    "$schema": "http://json-schema.org/draft-07/schema#",
+    "type": "object",
+    "properties": {
+        "url": { "type": "string" }
+    },
+    "required": [ "url" ]
+}

inst/schema/repository_fetch_response.json

@@ -0,0 +1,4 @@
+{
+    "$schema": "http://json-schema.org/draft-07/schema#",
+    "type": "object"
+}