Add an API to fetch repositories and list their branches.

This API is a replacement for the one currently provided by
outpack_server.

A single instance of orderly.runner API is able to operate over an
arbitrary number of Git repositories. The first time a URL is fetched, a
`git clone` is performed. Subsequent fetches are incremental using `git
fetch`.

Repositories are each stored in their own directory, named using the
hash of the URL. Using the hash makes it easy to support arbitrary
upstreams, without having to worry about encoding the URL characters as
file names.

The existing endpoints still operate on the "root" repository, which is
assumed to exist before the API is launched. Eventually all those APIs
will be migrated to have a `url` argument.

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,8 @@
 ##'
 ##' @param root Orderly root
 ##'
+##' @param repositories 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 +21,8 @@
 ##'
 ##' @export
 api <- function(
-    root, validate = NULL, log_level = "info",
+    root, repositories,
+    validate = NULL, log_level = "info",
     skip_queue_creation = FALSE) {
   logger <- porcelain::porcelain_logger(log_level)
 
@@ -31,7 +34,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 = repositories,
+    queue = queue))
   api
 }
 
@@ -46,6 +52,41 @@ root <- function() {
 }
 
 
+##' @porcelain POST /repository/fetch => json(repository_fetch_response)
+##'   state repositories :: repositories
+##'   body data :: json(repository_fetch_request)
+repository_fetch <- function(repositories, data) {
+  data <- jsonlite::parse_json(data)
+  r <- git_sync(repositories, data$url)
+
+  empty_object()
+}
+
+
+##' @porcelain GET /repository/branches => json(repository_branches)
+##'   state repositories :: repositories
+##'   query url :: string
+repository_branches <- function(repositories, url) {
+  repo <- repository_path(repositories, 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"
+}