support GitHub enterprise with gitcreds

NEWS.md

@@ -1,6 +1,9 @@
 
 # renv (development version)
 
+* `renv` now supports the use of GitHub Enterprise servers with the
+  `gitcreds` package for authentication credentials. (#1814)
+
 * `renv::dependencies()` now treats `#| eval: !expr <...>` chunk options
   as truthy by default, implying that such chunks are scanned for their
   R package dependencies. (#1816)

R/download.R

@@ -498,7 +498,7 @@ renv_download_auth <- function(url, type) {
   switch(
     type,
     bitbucket = renv_download_auth_bitbucket(),
-    github = renv_download_auth_github(),
+    github = renv_download_auth_github(url),
     gitlab = renv_download_auth_gitlab(),
     character()
   )
@@ -523,31 +523,44 @@ renv_download_auth_bitbucket <- function() {
 
 }
 
-renv_download_auth_github <- function() {
+renv_download_auth_github <- function(url) {
 
-  pat <- renv_download_auth_github_pat()
+  pat <- renv_download_auth_github_pat(url)
   if (is.null(pat))
     return(character())
 
   c("Authorization" = paste("token", pat))
 
 }
 
-renv_download_auth_github_pat <- function() {
+renv_download_auth_github_pat <- function(url) {
 
   # check for an existing PAT
   pat <- Sys.getenv("GITHUB_PAT", unset = NA)
   if (!is.na(pat))
     return(pat)
 
   # if gitcreds is available, try to use it
-  if (requireNamespace("gitcreds", quietly = TRUE)) {
-
-    token <- tryCatch(gitcreds::gitcreds_get(), error = function(cnd) {
-      warning(conditionMessage(cnd))
-      NULL
-    })
+  gitcreds <-
+    getOption("renv.gitcreds.enabled", default = TRUE) &&
+    requireNamespace("gitcreds", quietly = TRUE)
+
+  if (gitcreds) {
+
+    # ensure URL has protocol pre-pended
+    url <- renv_retrieve_origin(url)
+
+    # request token
+    dlog("download", "requesting git credentials for url '%s'", url)
+    token <- tryCatch(
+      gitcreds::gitcreds_get(url),
+      error = function(cnd) {
+        warning(conditionMessage(cnd))
+        NULL
+      }
+    )
 
+    # use if available
     if (!is.null(token))
       return(token$password)
 

R/remotes.R

@@ -541,7 +541,7 @@ renv_remotes_resolve_github_modules <- function(host, user, repo, subdir, sha) {
 
 }
 
-renv_remotes_resolve_github_description <- function(host, user, repo, subdir, sha) {
+renv_remotes_resolve_github_description <- function(url, host, user, repo, subdir, sha) {
 
   # form DESCRIPTION path
   subdir <- subdir %||% ""
@@ -558,7 +558,7 @@ renv_remotes_resolve_github_description <- function(host, user, repo, subdir, sh
   # add headers
   headers <- c(
     Accept = "application/vnd.github.raw",
-    renv_download_auth_github()
+    renv_download_auth_github(url)
   )
 
   # get the DESCRIPTION contents
@@ -646,14 +646,14 @@ renv_remotes_resolve_github <- function(remote) {
   # check whether the repository has a .gitmodules file; if so, then we'll have
   # to use a plain 'git' client to retrieve the package
   modules <- renv_remotes_resolve_github_modules(host, user, repo, subdir, sha)
-  url <- if (modules) {
-    origin <- fsub("api.github.com", "github.com", renv_retrieve_origin(host))
-    parts <- c(origin, user, repo)
-    paste(parts, collapse = "/")
-  }
+
+  # construct full url
+  origin <- fsub("api.github.com", "github.com", renv_retrieve_origin(host))
+  parts <- c(origin, user, repo)
+  url <- paste(parts, collapse = "/")
 
   # read DESCRIPTION
-  desc <- renv_remotes_resolve_github_description(host, user, repo, subdir, sha)
+  desc <- renv_remotes_resolve_github_description(url, host, user, repo, subdir, sha)
 
   list(
     Package        = desc$Package,

R/update.R

@@ -114,8 +114,14 @@ renv_update_find_github_impl <- function(record) {
   if (sha == record$RemoteSha)
     return(NULL)
 
+  url <- record$RemoteUrl %||% {
+    origin <- fsub("api.github.com", "github.com", renv_retrieve_origin(host))
+    parts <- c(origin, user, repo)
+    paste(parts, collapse = "/")
+  }
+
   # get updated record
-  desc <- renv_remotes_resolve_github_description(host, user, repo, subdir, sha)
+  desc <- renv_remotes_resolve_github_description(url, host, user, repo, subdir, sha)
   current <- list(
     Package        = desc$Package,
     Version        = desc$Version,

tests/testthat/helper-setup.R

@@ -13,7 +13,7 @@ renv_tests_setup <- function(scope = parent.frame()) {
     return()
 
   # force gitcreds to initialize early
-  renv_download_auth_github()
+  renv_download_auth_github(url = "https://github.com")
 
   # remove automatic tasks so we can capture explicitly in tests
   renv_task_unload()