Merge pull request #168 from mrc-ide/mrc-5725-device-flow

Implement OAuth device flow for GitHub logins.

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: orderly2
 Title: Orderly Next Generation
-Version: 1.99.37
+Version: 1.99.38
 Authors@R: c(person("Rich", "FitzJohn", role = c("aut", "cre"),
                     email = "[email protected]"),
              person("Robert", "Ashton", role = "aut"),

R/location.R

@@ -41,8 +41,12 @@
 ##' * `url`: The location of the server
 ##'
 ##' * `token`: The value for your your login token (currently this is
-##'   a GitHub token with `read:org` scope).  Later we'll expand this
-##'   as other authentication modes are supported.
+##'   a GitHub token with `read:org` scope). If missing or NULL, orderly2 will
+##'   perform an interactive authentication against GitHub to obtain one.
+##'
+##' * `save_token`: If no token is provided and interactive authentication is
+##'    used, this controls whether the GitHub token should be saved to disk.
+##'    Defaults to TRUE if missing.
 ##'
 ##' **Custom locations**:
 ##'
@@ -110,7 +114,14 @@ orderly_location_add <- function(name, type, args, root = NULL, locate = TRUE) {
     assert_scalar_character(loc$args[[1]]$url, name = "args$url",
                             call = environment())
     assert_scalar_character(loc$args[[1]]$token, name = "args$token",
+                            allow_null = TRUE,
                             call = environment())
+    assert_scalar_logical(loc$args[[1]]$save_token, name = "args$save_token",
+                          allow_null = TRUE,
+                          call = environment())
+    if (!is.null(loc$args[[1]]$token) && !is.null(loc$args[[1]]$save_token)) {
+      cli::cli_abort("Cannot specify both 'token' and 'save_token'")
+    }
   }
 
   config <- root$config
@@ -448,21 +459,22 @@ location_driver <- function(location_name, root) {
   i <- match(location_name, root$config$location$name)
   type <- root$config$location$type[[i]]
   args <- root$config$location$args[[i]]
-  switch(type,
-         path = orderly_location_path$new(args$path),
-         http = orderly_location_http$new(args$url),
-         packit = orderly_location_packit(args$url, args$token),
-         custom = orderly_location_custom(args))
+  location <- switch(type,
+                     path = orderly_location_path$new,
+                     http = orderly_location_http$new,
+                     packit = orderly_location_packit,
+                     custom = orderly_location_custom)
+  do.call(location, args)
 }
 
 
-orderly_location_custom <- function(args) {
-  driver <- check_symbol_from_str(args$driver, "args$driver")
+orderly_location_custom <- function(driver, ...) {
+  driver <- check_symbol_from_str(driver, "args$driver")
   driver <- getExportedValue(driver$namespace, driver$symbol)
   if (inherits(driver, "R6ClassGenerator")) {
     driver <- driver$new
   }
-  do.call(driver, args[names(args) != "driver"])
+  driver(...)
 }
 
 
@@ -764,7 +776,7 @@ new_location_entry <- function(name, type, args, call = NULL) {
   } else if (type == "http") {
     required <- "url"
   } else if (type == "packit") {
-    required <- c("url", "token")
+    required <- "url"
   } else if (type == "custom") {
     required <- "driver"
   }

R/location_http.R

@@ -1,17 +1,15 @@
 orderly_location_http <- R6::R6Class(
   "orderly_location_http",
 
-  private = list(
-    client = NULL
-  ),
-
   public = list(
-    initialize = function(url, auth = NULL) {
-      private$client <- outpack_http_client$new(url, auth)
+    client = NULL,
+
+    initialize = function(url, authorise = NULL) {
+      self$client <- outpack_http_client$new(url, authorise)
     },
 
     list = function() {
-      dat <- private$client$request("/metadata/list")$data
+      dat <- self$client$request("/metadata/list")$data
       data_frame(
         packet = vcapply(dat, "[[", "packet"),
         time = num_to_time(vnapply(dat, "[[", "time")),
@@ -21,8 +19,8 @@ orderly_location_http <- R6::R6Class(
     metadata = function(packet_ids) {
       ret <- vcapply(packet_ids, function(id) {
         tryCatch(
-          trimws(private$client$request(sprintf("/metadata/%s/text", id),
-                                        parse_json = FALSE)),
+          trimws(self$client$request(sprintf("/metadata/%s/text", id),
+                                     parse_json = FALSE)),
           outpack_http_client_error = function(e) {
             if (e$code == 404) {
               e$message <- sprintf("Some packet ids not found: '%s'", id)
@@ -43,7 +41,7 @@ orderly_location_http <- R6::R6Class(
       ## progress in the client, but there's not much point until
       ## then.
       tryCatch(
-        private$client$request(sprintf("/file/%s", hash), download = dest),
+        self$client$request(sprintf("/file/%s", hash), download = dest),
         outpack_http_client_error = function(e) {
           if (e$code == 404) {
             unlink(dest)
@@ -56,21 +54,21 @@ orderly_location_http <- R6::R6Class(
 
     ## TODO: we could get the schemas here from outpack_server too
     list_unknown_packets = function(ids) {
-      res <- private$client$request(
+      res <- self$client$request(
         "/packets/missing",
         function(r) http_body_json(r, list(ids = ids, unpacked = scalar(TRUE))))
       list_to_character(res$data)
     },
 
     list_unknown_files = function(hashes) {
-      res <- private$client$request(
+      res <- self$client$request(
         "/files/missing",
         function(r) http_body_json(r, list(hashes = hashes)))
       list_to_character(res$data)
     },
 
     push_file = function(src, hash) {
-      res <- private$client$request(
+      res <- self$client$request(
         sprintf("/file/%s", hash),
         function(r) httr2::req_body_file(r, src, "application/octet-stream"))
 
@@ -79,33 +77,10 @@ orderly_location_http <- R6::R6Class(
 
     push_metadata = function(packet_id, hash, path) {
       meta <- read_string(path)
-      res <- private$client$request(
+      res <- self$client$request(
         sprintf("/packet/%s", hash),
         function(r) httr2::req_body_raw(r, meta, "text/plain"))
       invisible(NULL)
     }
   )
 )
-
-
-orderly_location_packit <- function(url, token) {
-  assert_scalar_character(url)
-  assert_scalar_character(token)
-  if (grepl("^\\$", token)) {
-    token_variable <- sub("^\\$", "", token)
-    token <- Sys.getenv(token_variable, NA_character_)
-    if (is.na(token)) {
-      cli::cli_abort(
-        "Environment variable '{token_variable}' was not set")
-    }
-  }
-
-  if (!grepl("/$", url)) {
-    url <- paste0(url, "/")
-  }
-  url_login <- paste0(url, "packit/api/auth/login/api")
-  url_outpack <- paste0(url, "packit/api/outpack")
-
-  auth <- list(url = url_login, data = list(token = scalar(token)))
-  orderly_location_http$new(url_outpack, auth)
-}

R/location_packit.R

@@ -0,0 +1,87 @@
+github_oauth_client <- function() {
+  # Surprisingly, we don't actually need the Client ID here to match the one
+  # used by Packit. It should be fine to hardcode a value regardless of which
+  # server we are talking to.
+  httr2::oauth_client(
+    id = "Ov23liUrbkR0qUtAO1zu",
+    token_url = "https://github.com/login/oauth/access_token",
+    name = "orderly2"
+  )
+}
+
+do_oauth_device_flow <- function(base_url, cache_disk) {
+  # httr2 has a pretty unintuitive output when running interactively.
+  # It waits for the user to press <Enter> and then opens up a browser, but the
+  # wording isn't super clear. It also does not work at all if a browser can't
+  # be opened, eg. in an SSH session.
+  #
+  # Thankfully, if we pretend to not be interactive the behaviour is a lot more
+  # obvious. It will just print the link to the console and with instructions
+  # for the user to open it up.
+  res <- rlang::with_interactive(value = FALSE, {
+    httr2::oauth_token_cached(
+      client = github_oauth_client(),
+      flow = httr2::oauth_flow_device,
+      flow_params = list(
+        auth_url = "https://github.com/login/device/code",
+        scope = "read:org"),
+      cache_disk = cache_disk)
+  })
+  res$access_token
+}
+
+# Logging in with packit is quite slow and we'll want to cache this; but we
+# won't be holding a persistent handle to the root.  So for now at least we'll
+# keep a pool of generated bearer token headers, stored against the hash of the
+# auth details. We only store this on successful login.
+#
+# This does mean there's no way to flush the cache and force a login, but that
+# should hopefully not be that big a problem.  We'll probably want to refresh
+# the tokens from the request anyway.
+#
+# It also means the user cannot easily use two different identities on the same
+# server from within the same session.
+auth_cache <- new.env(parent = emptyenv())
+packit_authorisation <- function(base_url, token, save_token) {
+  key <- rlang::hash(list(base_url = base_url, token = token))
+
+  if (is.null(auth_cache[[key]])) {
+    cli::cli_alert_info("Logging in to {base_url}")
+    if (is.null(token)) {
+      token <- do_oauth_device_flow(base_url, cache_disk = save_token)
+    }
+
+    login_url <- paste0(base_url, "packit/api/auth/login/api")
+    res <- http_client_request(
+      login_url,
+      function(r) http_body_json(r, list(token = scalar(token))))
+
+    cli::cli_alert_success("Logged in successfully")
+
+    auth_cache[[key]] <- list("Authorization" = paste("Bearer", res$token))
+  }
+  auth_cache[[key]]
+}
+
+orderly_location_packit <- function(url, token = NULL, save_token = TRUE) {
+  assert_scalar_character(url)
+  assert_scalar_character(token, allow_null = TRUE)
+  assert_scalar_logical(save_token)
+
+  if (!is.null(token) && grepl("^\\$", token)) {
+    token_variable <- sub("^\\$", "", token)
+    token <- Sys.getenv(token_variable, NA_character_)
+    if (is.na(token)) {
+      cli::cli_abort(
+        "Environment variable '{token_variable}' was not set")
+    }
+  }
+
+  if (!grepl("/$", url)) {
+    url <- paste0(url, "/")
+  }
+
+  orderly_location_http$new(
+    paste0(url, "packit/api/outpack"),
+    function() packit_authorisation(url, token, save_token))
+}

R/outpack_http_client.R

@@ -3,31 +3,24 @@ outpack_http_client <- R6::R6Class(
 
   public = list(
     url = NULL,
-    auth = NULL,
+    authorise = NULL,
 
-    initialize = function(url, auth) {
+    initialize = function(url, authorise = NULL) {
       self$url <- sub("/$", "", url)
-      if (is.null(auth)) {
-        self$auth <- list(enabled = FALSE)
+      if (is.null(authorise)) {
+        self$authorise <- function() NULL
       } else {
-        self$auth <- list(enabled = TRUE, url = auth$url, data = auth$data)
-      }
-    },
-
-    authorise = function() {
-      needs_auth <- self$auth$enabled && is.null(self$auth$header)
-      if (needs_auth) {
-        self$auth$header <- http_client_login(self$url, self$auth)
+        self$authorise <- authorise
       }
     },
 
     request = function(path, customize = identity, ...) {
-      self$authorise()
+      auth_headers <- self$authorise()
       http_client_request(
         self$url,
         function(r) {
           r <- httr2::req_url_path_append(r, path)
-          r <- httr2::req_headers(r, !!!self$auth$header)
+          r <- httr2::req_headers(r, !!!auth_headers)
           customize(r)
         }, ...)
     }
@@ -92,29 +85,3 @@ http_client_error <- function(msg, code, errors) {
   class(err) <- c("outpack_http_client_error", "error", "condition")
   err
 }
-
-
-## Logging in with packit is quite slow and we'll want to cache this;
-## but we won't be holding a persistant handle to the root.  So for
-## now at least we'll keep a pool of generated bearer token headers,
-## stored against the hash of the auth details (so the url and the
-## token used to log in with).  We only store this on successful
-## login.
-##
-## This does mean there's no way to flush the cache and force a login,
-## but that should hopefully not be that big a problem.  We'll
-## probably want to refresh the tokens from the request anyway.
-auth_cache <- new.env(parent = emptyenv())
-http_client_login <- function(name, auth) {
-  key <- rlang::hash(auth)
-  if (is.null(auth_cache[[key]])) {
-    cli::cli_alert_info("Logging in to {name}")
-
-    res <- http_client_request(auth$url,
-                               function(r) http_body_json(r, auth$data))
-
-    cli::cli_alert_success("Logged in successfully")
-    auth_cache[[key]] <- list("Authorization" = paste("Bearer", res$token))
-  }
-  auth_cache[[key]]
-}

tests/testthat/helper-outpack-http.R

@@ -44,8 +44,8 @@ clear_auth_cache <- function() {
   rm(list = ls(auth_cache), envir = auth_cache)
 }
 
-local_mock_response <- function(..., env = rlang::caller_env()) {
-  mock <- mockery::mock(mock_response(...))
+local_mock_response <- function(..., env = rlang::caller_env(), cycle = FALSE) {
+  mock <- mockery::mock(mock_response(...), cycle = cycle)
   httr2::local_mocked_responses(function(req) mock(req), env = env)
   mock
 }