Merge pull request #353 from dgkf/328-parse-gitlab-ref

Updating GitLab url parsing; fix authed list_refs
r-lib · Apr 4, 2024 · 316d7fb · 316d7fb
2 parents 4de9160 + 019393c
commit 316d7fb
Show file tree

Hide file tree

Showing 18 changed files with 636 additions and 204 deletions.
diff --git a/NEWS.md b/NEWS.md
@@ -1,5 +1,8 @@
 # pkgdepends (development version)
 
+* pkgdepends now supports `gitlab::` package sources better, by adding
+  explicit syntax to specify subdirectories (#353, @dgkf).
+
 # pkgdepends 0.7.2
 
 * pkgdepends now supports the `*` wildcard for parameter specifications,

diff --git a/R/git-protocol.R b/R/git-protocol.R
@@ -1,4 +1,3 @@
-
 #' git protocol notes, for developers
 #'
 #' Assumptions, they might be relaxed or checked for later:
@@ -39,6 +38,30 @@ NULL
 
 # -------------------------------------------------------------------------
 
+git_creds_for_url <- function(url) {
+  creds <- tryCatch(
+    gitcreds_get(url)[c("username", "password")],
+    error = function(e) NULL
+  )
+  if (is.null(creds)) {
+    do.call(
+      Sys.setenv,
+      structure(list("FAIL"), names = gitcreds_cache_envvar(url))
+    )
+  }
+  creds
+}
+
+git_http_get <- function(url, options = list(), ...) {
+  options <- c(options, git_creds_for_url(url))
+  http_get(url, options = options, ...)
+}
+
+git_http_post <- function(url, options = list(), ...) {
+  options <- c(options, git_creds_for_url(url))
+  http_post(url, options = options, ...)
+}
+
 #' List references in a remote git repository
 #'
 #' @details
@@ -802,7 +825,8 @@ async_git_send_message_v2 <- function(
     "git-protocol" = "version=2",
     "content-length" = as.character(length(msg))
   )
-  http_post(
+
+  git_http_post(
     url2,
     data = msg,
     headers = headers
@@ -821,7 +845,7 @@ async_git_send_message_v1 <- function(url, args, caps) {
     "accept" = "application/x-git-upload-pack-result",
     "content-length" = as.character(length(msg))
   )
-  http_post(
+  git_http_post(
     url2,
     data = msg,
     headers = headers
@@ -894,7 +918,7 @@ git_list_refs_v1 <- function(url) {
 async_git_list_refs_v1 <- function(url) {
   url
   url1 <- paste0(url, "/info/refs?service=git-upload-pack")
-  http_get(url1, headers = c("User-Agent" = git_ua()))$
+  git_http_get(url1, headers = c("User-Agent" = git_ua()))$
     then(http_stop_for_status)$
     then(function(response) git_list_refs_v1_process(response, url))
 }
@@ -1020,11 +1044,13 @@ async_git_list_refs_v2 <- function(url, prefixes = character()) {
   url; prefixes
 
   url1 <- paste0(url, "/info/refs?service=git-upload-pack")
+
   headers <- c(
     "User-Agent" = git_ua(),
     "git-protocol" = "version=2"
   )
-  http_get(url1, headers = headers)$
+
+  git_http_get(url1, headers = headers)$
     then(http_stop_for_status)$
     then(function(res) async_git_list_refs_v2_process_1(res, url, prefixes))
 }
@@ -1670,9 +1696,9 @@ async_git_dumb_list_refs <- function(url) {
     "User-Agent" = git_ua()
   )
   when_all(
-    http_get(url1, headers = headers)$
+    git_http_get(url1, headers = headers)$
       then(http_stop_for_status),
-    http_get(url2, headers = headers)$
+    git_http_get(url2, headers = headers)$
       then(http_stop_for_status)
   )$
     then(function(res) async_git_dumb_list_refs_process(res, url))
@@ -1752,7 +1778,7 @@ async_git_dumb_get_commit <- function(url, sha) {
     "User-Agent" = git_ua(),
     "accept-encoding" = "deflate, gzip"
   )
-  http_get(url = url1, headers = headers)$
+  git_http_get(url = url1, headers = headers)$
     then(http_stop_for_status)$
     then(function(res) {
       cmt <- zip::inflate(res$content)$output
@@ -1781,7 +1807,7 @@ async_git_dumb_get_tree <- function(url, sha) {
     "User-Agent" = git_ua(),
     "accept-encoding" = "deflate, gzip"
   )
-  http_get(url = url1, headers = headers)$
+  git_http_get(url = url1, headers = headers)$
     then(http_stop_for_status)$
     then(function(res) {
       cmt <- zip::inflate(res$content)$output
@@ -1810,7 +1836,7 @@ async_git_dumb_get_blob <- function(url, sha) {
     "User-Agent" = git_ua(),
     "accept-encoding" = "deflate, gzip"
   )
-  http_get(url = url1, headers = headers)$
+  git_http_get(url = url1, headers = headers)$
     then(http_stop_for_status)$
     then(function(res) {
       cmt <- zip::inflate(res$content)$output

diff --git a/R/git-submodules.R b/R/git-submodules.R
@@ -122,36 +122,14 @@ async_update_submodule <- function(url, path, branch) {
     if (is.null(branch) || is.na(branch)) branch <- "HEAD"
     # message("getting ", path)
     async_git_download_repo(
-      git_auth_url(url),
+      url,
       ref = branch,
       output = path,
       submodules = TRUE
     )
   }
 }
 
-git_auth_url <- function(url) {
-  parsed <- parse_url(url)
-  auth <- tryCatch(gitcreds_get(url), error = function(err) NULL)
-  if (is.null(auth)) {
-    url
-  } else {
-    paste0(
-      parsed$protocol,
-      "://",
-      auth$username,
-      ":",
-      auth$password,
-      "@",
-      sub(paste0("^", parsed$protocol, "://"), "", parsed$url),
-      # gitlab needs .git suffix
-      if (parsed$host == "gitlab.com" && !endsWith(parsed$url, ".git")) {
-        ".git"
-      }
-    )
-  }
-}
-
 update_git_submodules_r <- function(path, subdir) {
   synchronize(async_update_git_submodules_r(path, subdir))           # nocov
 }

diff --git a/R/install-plan.R b/R/install-plan.R
@@ -667,7 +667,7 @@ stop_task_package_build <- function(state, worker) {
       state$cache$add(state$plan$file[pkgidx], state$plan$target[pkgidx],
                       package = pkg, version = version, built = TRUE,
                       sha256 = state$plan$extra[[pkgidx]]$remotesha,
-                      vignettes = state$plan$vignette[pkgidx],
+                      vignettes = state$plan$vignettes[pkgidx],
                       platform = "source"),
       error = function(err) {
         alert("warning", "Failed to add {.pkg {pkg}} \\
@@ -744,7 +744,7 @@ stop_task_build <- function(state, worker) {
       state$cache$add(state$plan$file[pkgidx], target,
                       package = pkg, version = version, built = TRUE,
                       sha256 = state$plan$extra[[pkgidx]]$remotesha,
-                      vignettes = state$plan$vignette[pkgidx],
+                      vignettes = state$plan$vignettes[pkgidx],
                       platform = ptfm, rversion = rv),
       error = function(err) {
         alert("warning", "Failed to add {.pkg {pkg}} \\

diff --git a/R/type-git.R b/R/type-git.R
@@ -88,7 +88,7 @@ download_remote_git <- function(resolution, target, target_tree,
 
   ## 4. Need to download the repo
 
-  url <- type_git_auth_url(resolution$remote[[1]])
+  url <- resolution$remote[[1]]$url
   sha <- resolution$metadata[[1]][["RemoteSha"]]
   pkgdir <- file.path(target_tree, resolution$package)
   mkdirp(pkgdir)
@@ -168,36 +168,18 @@ git_rx <- function() {
   )
 }
 
-type_git_auth_url <- function(remote) {
-  url <- remote$url
-  auth <- tryCatch(gitcreds_get(url), error = function(err) NULL)
-  if (is.null(auth)) {
-    url
-  } else {
-    paste0(
-      remote$protocol,
-      "://",
-      auth$username,
-      ":",
-      auth$password,
-      "@",
-      sub(paste0("^", remote$protocol, "://"), "", remote$url)
-    )
-  }
-}
-
 type_git_get_data <- function(remote) {
   remote
+  url <- remote$url
   sha <- NULL
   dsc <- NULL
-  auth_url <- type_git_auth_url(remote)
   desc_path <- if (is.null(remote$subdir) || remote$subdir == "") {
     "DESCRIPTION"
   } else {
     paste0(remote$subdir, "/", "DESCRIPTION")
   }
 
-  async_git_list_files(auth_url, remote$commitish)$
+  async_git_list_files(url, remote$commitish)$
     catch(error = function(err) {
       throw(pkg_error(
         "Failed to download {.path {desc_path}} from git repo at {.url {remote$url}}."
@@ -219,7 +201,7 @@ type_git_get_data <- function(remote) {
       files$files$hash[desc_idx]
     })$
     then(function(desc_hash) {
-      async_git_download_file(auth_url, desc_hash, output = NULL)$
+      async_git_download_file(url, desc_hash, output = NULL)$
       catch(error = function(err) {
         throw(pkg_error(
           "Failed to download {.path {desc_path}} from git repo at {.url {remote$url}}."

diff --git a/R/type-gitlab.R b/R/type-gitlab.R
@@ -1,18 +1,17 @@
 
 parse_remote_gitlab <- function(specs, config, ...) {
-
   pds <- re_match(specs, gitlab_rx())
   pds$ref <- pds$.text
   pds$protocol[pds$protocol == ""] <- "https"
   pds$host[pds$host == ""] <- "gitlab.com"
-  pds$path <- paste0("/", pds$username, "/")
+  pds$path <- paste0("/", pds$projectpath, "/", pds$project)
   pds$dotgit <- ""
   pds$commitish[pds$commitish == ""] <- "HEAD"
-  pds$url <- paste0(pds$protocol, "://", pds$host, pds$path, pds$repo, ".git")
+  pds$url <- paste0(pds$protocol, "://", pds$host, pds$path, ".git")
   cn <- setdiff(colnames(pds), c(".match", ".text"))
   pds <- pds[, cn]
   pds$type <- "gitlab"
-  pds$package <- ifelse(nzchar(pds$package), pds$package, pds$repo)
+  pds$package <- ifelse(nzchar(pds$package), pds$package, pds$project)
   lapply(
     seq_len(nrow(pds)),
     function(i) as.list(pds[i,])
@@ -24,8 +23,8 @@ resolve_remote_gitlab <- function(remote, direct, config, cache,
   resolve_remote_git(remote, direct, config, cache, dependencies, ...)$
     then(function(res) {
       res$metadata["RemoteHost"] <- remote$host
-      res$metadata["RemoteRepo"] <- remote$repo
-      res$metadata["RemoteUsername"] <- remote$username
+      res$metadata["RemoteRepo"] <- remote$project
+      res$metadata["RemoteUsername"] <- remote$projectpath
       res$metadata["RemoteType"] <- "gitlab"
       if (!is.null(remote$subdir) && remote$subdir != "") {
         res$metadata["RemoteSubdir"] <- remote$subdir
@@ -55,16 +54,31 @@ installedok_remote_gitlab <- function(installed, solution, config, ...) {
   installedok_remote_git(installed, solution, config, ...)
 }
 
+# source: https://docs.gitlab.com/ee/user/reserved_names.html#limitations-on-usernames-project-and-group-names
+gitlab_slug_rx <- function() {
+  "[a-zA-Z0-9][-._a-zA-Z0-9]*[a-zA-Z0-9]"
+}
+
+gitlab_project_rx <- function() {
+  paste0("(?<project>", gitlab_slug_rx(), ")")
+}
+
+gitlab_project_path_rx <- function() {
+  paste0("(?<projectpath>", gitlab_slug_rx(), "(?:/", gitlab_slug_rx(), ")*)")
+}
+
 gitlab_rx <- function() {
   paste0(
     "^",
     ## Optional package name
     "(?:(?<package>", package_name_rx(), ")=)?",
     "gitlab::",
-    "(?:(?<protocol>[^/]*)://(?<host>[^/]+))?",
-    github_username_rx(), "/",
-    github_repo_rx(),
-    github_subdir_rx(), "?",
+    ## Optional protocol::host
+    "(?:(?<protocol>[^/]*)://(?<host>[^/]+)/)?",
+    gitlab_project_path_rx(), "/",
+    gitlab_project_rx(),
+    ## Optional subdirectory, prefixed with /-, ie project/-/sub/dir
+    "(?:/-", github_subdir_rx(), ")?",
     "(?:", github_commitish_rx(), ")?",
     "$"
   )

diff --git a/inst/docs/pkg-refs.rds b/inst/docs/pkg-refs.rds
diff --git a/man/pkg_refs.Rd b/man/pkg_refs.Rd
diff --git a/tests/testthat/_snaps/git-submodules.md b/tests/testthat/_snaps/git-submodules.md
@@ -143,27 +143,6 @@
        [9] "v1/README.md"                            
       [10] "v1/wipe.R"                               
 
-# git_auth_url
-
-    Code
-      git_auth_url("https://github.com/r-lib/pak")
-    Output
-      [1] "https://github.com/r-lib/pak"
-
----
-
-    Code
-      git_auth_url("https://github.com/r-lib/pak")
-    Output
-      [1] "https://user:[email protected]/r-lib/pak"
-
----
-
-    Code
-      git_auth_url("https://gitlab.com/gaborcsardi/vli")
-    Output
-      [1] "https://user:[email protected]/gaborcsardi/vli.git"
-
 # directories
 
     Code