Adding git_remote fallback for gitlab_remote use without full API access (Resolves #604)

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: remotes
 Title: R Package Installation from Remote Repositories, Including 'GitHub'
-Version: 2.4.0.9001
+Version: 2.4.0.9002
 Authors@R: c(
     person("Jim", "Hester", , "jim.hester@rstudio.com", role = c("aut", "cre")),
     person("Gábor", "Csárdi", , "csardi.gabor@gmail.com", role = c("aut")),

NAMESPACE

@@ -98,6 +98,7 @@ export(system_requirements)
 export(update_packages)
 importFrom(stats,update)
 importFrom(tools,file_ext)
+importFrom(utils,URLencode)
 importFrom(utils,available.packages)
 importFrom(utils,compareVersion)
 importFrom(utils,contrib.url)

NEWS.md

@@ -1,9 +1,11 @@
 # remotes (development version)
 
+* Using `install_gitlab` will now revert to using `install_git` when API access to the GitLab server is unavailable using the provided credentials. This is especially useful within a GitLab CI job where the created `CI_JOB_TOKEN` environment variable does not provide necessary API access, but is sufficient for cloning the repository using `git` (#608, @dgkf)
 * pkgbuild is no longer accidentally loaded even in standalone mode (#548)
 * The internal GitHub token used to increase rate limits has been regenerated.
 * Using `remote_package_name.git2r_remote` now passes credentials when looking up the package `DESCRIPTION` (#633, @rnorberg)
 * Using `remote_package_name.git2r_remote` and `remote_package_name.xgit_remote`, http responses returning an invalid `DESCRIPTION` or that redirect to another page will now fallback to return `NA` instead of throwing an error when trying to parse the unexpected content (#628, @dgkf).
+
 * Fix regex that breaks git protocol in `git_remote` (@niheaven #630).
 * Clarify `github_pull()` documentation (@ms609 #640).
 

R/git.R

@@ -26,10 +26,12 @@ git_extract_sha1_tar <- function(bundle) {
   }
 }
 
-git <- function(args, quiet = TRUE, path = ".") {
+git <- function(args, quiet = TRUE, path = ".", display_args = args) {
   full <- paste0(shQuote(check_git_path()), " ", paste(args, collapse = ""))
+  display_full <- paste0(shQuote(check_git_path()), " ", paste(display_args, collapse = ""))
+
   if (!quiet) {
-    message(full)
+    message(display_full)
   }
 
   result <- in_dir(path, system(full, intern = TRUE, ignore.stderr = quiet))

R/install-git.R

@@ -79,12 +79,55 @@ git_remote <- function(url, subdir = NULL, ref = NULL, credentials = git_credent
     stop("`credentials` can only be used with `git = \"git2r\"`", call. = FALSE)
   }
 
-  meta <- re_match(url, "(?<url>(?:git@)?[^@]*)(?:@(?<ref>.*))?")
+  meta <- parse_git_url(url)
+  url <- paste0(meta$prot, meta$auth, meta$url)
   ref <- ref %||% (if (meta$ref == "") NULL else meta$ref)
 
-  list(git2r = git_remote_git2r, external = git_remote_xgit)[[git]](meta$url, subdir, ref, credentials)
+  list(git2r = git_remote_git2r, external = git_remote_xgit)[[git]](url, subdir, ref, credentials)
 }
 
+#' Extract URL parts from a git-style url
+#'
+#' Although not a full url parser, this expression captures and separates url
+#' protocol (`prot`), full authentication prefix (`auth`, containing `username`
+#' and `password`), the host and path (`url`) and git reference (`ref`).
+#'
+#' @param url A `character` vector of urls to parse
+#'
+parse_git_url <- function(url) {
+  re_match(url, paste0(
+    "(?<prot>.*://)?(?<auth>(?<username>[^:@/]*)(?::(?<password>[^@/]*)?)?@)?",
+    "(?<url>[^@]*)",
+    "(?:@(?<ref>.*))?"
+  ))
+}
+
+#' Anonymize a git-style url
+#'
+#' Strip a url of user-specific username and password if embedded as part of a
+#' url string.
+#'
+#' @inheritParams parse_git_url
+#'
+git_anon_url <- function(url) {
+  meta <- parse_git_url(url)
+  paste0(meta$prot, meta$url)
+}
+
+#' Censor user password in a git-style url
+#'
+#' If a password is provided as part of a url string, censor the url string,
+#' replacing the password with a series of asterisks.
+#'
+#' @inheritParams parse_git_url
+#'
+git_censored_url <- function(url) {
+  meta <- parse_git_url(url)
+  auth <- meta$username
+  auth <- ifelse(nzchar(meta$password), paste0(auth, ":", strrep("*", 8L)), auth)
+  auth <- ifelse(nzchar(auth), paste0(auth, "@"), auth)
+  paste0(meta$prot, auth, meta$url)
+}
 
 git_remote_git2r <- function(url, subdir = NULL, ref = NULL, credentials = git_credentials()) {
   remote("git2r",
@@ -107,7 +150,7 @@ git_remote_xgit <- function(url, subdir = NULL, ref = NULL, credentials = git_cr
 #' @export
 remote_download.git2r_remote <- function(x, quiet = FALSE) {
   if (!quiet) {
-    message("Downloading git repo ", x$url)
+    message("Downloading git repo ", git_anon_url(x$url))
   }
 
   bundle <- tempfile()
@@ -132,7 +175,7 @@ remote_metadata.git2r_remote <- function(x, bundle = NULL, source = NULL, sha =
 
   list(
     RemoteType = "git2r",
-    RemoteUrl = x$url,
+    RemoteUrl = git_anon_url(x$url),
     RemoteSubdir = x$subdir,
     RemoteRef = x$ref,
     RemoteSha = sha
@@ -255,14 +298,18 @@ format.git2r_remote <- function(x, ...) {
 #' @export
 remote_download.xgit_remote <- function(x, quiet = FALSE) {
   if (!quiet) {
-    message("Downloading git repo ", x$url)
+    message("Downloading git repo ", git_anon_url(x$url))
   }
 
   bundle <- tempfile()
 
-  args <- c("clone", "--depth", "1", "--no-hardlinks")
-  args <- c(args, x$args, x$url, bundle)
-  git(paste0(args, collapse = " "), quiet = quiet)
+  args <- c("clone", "--depth", "1", "--no-hardlinks", x$args)
+  display_args <- c(args, git_censored_url(x$url), bundle)
+  display_args <- paste0(display_args, collapse = " ")
+  args <- c(args, x$url, bundle)
+  args <- paste0(args, collapse = " ")
+
+  git(args, quiet = quiet, display_args = display_args)
 
   if (!is.null(x$ref)) {
     git(paste0(c("fetch", "origin", x$ref), collapse = " "), quiet = quiet, path = bundle)
@@ -280,7 +327,7 @@ remote_metadata.xgit_remote <- function(x, bundle = NULL, source = NULL, sha = N
 
   list(
     RemoteType = "xgit",
-    RemoteUrl = x$url,
+    RemoteUrl = git_anon_url(x$url),
     RemoteSubdir = x$subdir,
     RemoteRef = x$ref,
     RemoteSha = sha,

R/install-gitlab.R

@@ -18,7 +18,14 @@
 #'   supply to this argument. This is safer than using a password because you
 #'   can easily delete a PAT without affecting any others. Defaults to the
 #'   GITLAB_PAT environment variable.
-#' @inheritParams install_github
+#' @param git_fallback A `logical` value indicating whether to defer to using
+#'   a `git` remote if the GitLab api is inaccessible. This can be a helpful
+#'   mitigating measure when an access token does not have the necessary scopes
+#'   for accessing the GitLab api, but still provides access for git
+#'   authentication. Defaults to the value of option
+#'   `"remotes.gitlab_git_fallback"`, or `TRUE` if the option is not set.
+#' @inheritParams install_git
+#'
 #' @export
 #' @family package installation
 #' @examples
@@ -37,9 +44,19 @@ install_gitlab <- function(repo,
                            build_manual = FALSE, build_vignettes = FALSE,
                            repos = getOption("repos"),
                            type = getOption("pkgType"),
-                           ...) {
+                           ...,
+                           git_fallback = getOption("remotes.gitlab_git_fallback", TRUE),
+                           credentials = git_credentials()) {
 
-  remotes <- lapply(repo, gitlab_remote, subdir = subdir, auth_token = auth_token, host = host)
+  remotes <- lapply(
+    repo,
+    gitlab_remote,
+    subdir = subdir,
+    auth_token = auth_token,
+    host = host,
+    git_fallback = git_fallback, 
+    credentials = credentials
+  )
 
   install_remotes(remotes, auth_token = auth_token, host = host,
                   dependencies = dependencies,
@@ -56,20 +73,103 @@ install_gitlab <- function(repo,
 }
 
 gitlab_remote <- function(repo, subdir = NULL,
-                       auth_token = gitlab_pat(), sha = NULL,
-                       host = "gitlab.com", ...) {
+                          auth_token = gitlab_pat(quiet), sha = NULL,
+                          host = "gitlab.com", ..., 
+                          git_fallback = getOption("remotes.gitlab_git_fallback", TRUE),
+                          quiet = FALSE) {
 
   meta <- parse_git_repo(repo)
   meta$ref <- meta$ref %||% "HEAD"
 
-  remote("gitlab",
-    host = host,
-    repo = paste(c(meta$repo, meta$subdir), collapse = "/"),
+  # use project id api request as a canary for api access using auth_token.
+  repo <- paste0(c(meta$repo, meta$subdir), collapse = "/")
+  project_id <- try(silent = TRUE, {
+    gitlab_project_id(meta$username, repo, meta$ref, host, auth_token)
+  })
+
+  has_access_token <- !is.null(auth_token) && nchar(auth_token) > 0L
+  if (inherits(project_id, "try-error") && isTRUE(git_fallback)) {
+    if (has_access_token && !quiet) {
+      message(wrap(exdent = 2L, paste0("auth_token does not have scopes ", 
+        "'read-repository' and 'api' for host '", host, "' required to ",
+        "install using gitlab_remote.")))
+    } else if (!quiet) {
+      message(wrap(exdent = 2L, paste0("Unable to establish api access for ",
+        "host '", host, "' required to install using gitlab_remote.")))
+    }
+
+    gitlab_to_git_remote(
+      repo = paste0(c(meta$username, repo), collapse = "/"),
+      subdir = subdir,      
+      auth_token = auth_token,
+      ref = sha %||% meta$ref,
+      host = host,
+      quiet = quiet,
+      ...
+    )
+  } else {
+    remote("gitlab",
+      host = host,
+      repo = repo,
+      subdir = subdir,
+      username = meta$username,
+      ref = meta$ref,
+      sha = sha,
+      auth_token = auth_token
+    )
+  }
+}
+
+#' @importFrom utils URLencode
+gitlab_to_git_remote <- function(repo, subdir = NULL,
+                                 auth_token = gitlab_pat(quiet), ref = NULL, 
+                                 host = "gitlab.com", ..., 
+                                 git_fallback = getOption("remotes.gitlab_git_fallback", TRUE),
+                                 credentials = NULL,
+                                 quiet = FALSE) {
+
+  # for basic http auth, required names are largely undocumented:
+  #   - in GitLab CI using job account, username must be "gitlab-ci-token"
+  #   - for Project Access Tokens, username must be "<project-name>"
+  #   - for Personal Access Tokens, username is ignored
+  #
+  # choose to use "gitlab-ci-token" for most general default behavior
+  # https://docs.gitlab.com/ee/user/profile/personal_access_tokens.html
+
+  url <- paste0(build_url(host, repo), ".git")
+  url_has_embedded_token <- grepl("^(.*://)?[^@/]+@", url)
+  has_access_token <- !is.null(auth_token) && nchar(auth_token) > 0L
+  has_credentials <- !is.null(credentials)
+  use_git2r <- !is_standalone() && pkg_installed("git2r")
+
+  if (url_has_embedded_token || has_credentials) {
+    if (!quiet)
+      message(wrap(exdent = 2L, paste0("Attempting git_remote")))
+  } else if (has_access_token && !has_credentials && use_git2r) {
+    if (!quiet)
+      message(wrap(exdent = 2L, paste0("Attempting git_remote using ",
+        "credentials: username='gitlab-ci-token', password=<auth_token>")))
+
+    credentials <- getExportedValue("git2r", "cred_user_pass")(
+      username = "gitlab-ci-token",
+      password = auth_token
+    )    
+  } else if (has_access_token && !has_credentials && !use_git2r) {
+    url_protocol <- gsub("((.*)://)?.*", "\\1", url)
+    url_path     <- gsub("((.*)://)?", "", url)
+    url <- paste0(url_protocol, "gitlab-ci-token:", utils::URLencode(auth_token), "@", url_path)
+
+    if (!quiet)
+      message(wrap(exdent = 2L, paste0("Attempting git_remote using ",
+        sprintf("url=%sgitlab-ci-token:<auth_token>@%s", url_protocol, url_path))))
+  }
+
+  git_remote(
+    url = url,
     subdir = subdir,
-    username = meta$username,
-    ref = meta$ref,
-    sha = sha,
-    auth_token = auth_token
+    ref = ref,
+    credentials = credentials,
+    ...
   )
 }
 

R/utils.R

@@ -517,3 +517,8 @@ raw_to_char_utf8 <- function(x) {
   Encoding(res) <- "UTF-8"
   res
 }
+
+wrap <- function(x, ..., simplify = FALSE) {
+  lines <- unlist(strwrap(unlist(strsplit(x, "\n")), ..., simplify = simplify))
+  paste(lines, collapse = "\n")
+}