From 8b187582acf4b91b0f197844eb6781a5fcaab277 Mon Sep 17 00:00:00 2001 From: dgkf <18220321+dgkf@users.noreply.github.com> Date: Fri, 30 Apr 2021 15:18:36 -0700 Subject: [PATCH 01/26] adding check for api access and git fallback --- R/install-gitlab.R | 68 +++++++++++++++++++++++++++++++++++++++------- 1 file changed, 58 insertions(+), 10 deletions(-) diff --git a/R/install-gitlab.R b/R/install-gitlab.R index 4ed97820..0b97e2aa 100644 --- a/R/install-gitlab.R +++ b/R/install-gitlab.R @@ -57,20 +57,55 @@ install_gitlab <- function(repo, gitlab_remote <- function(repo, subdir = NULL, auth_token = gitlab_pat(), sha = NULL, - host = "gitlab.com", ...) { + host = "gitlab.com", ..., + git_fallback = getOption("remotes.gitlab_git_fallback", TRUE)) { meta <- parse_git_repo(repo) meta$ref <- meta$ref %||% "HEAD" - remote("gitlab", - host = host, - repo = paste(c(meta$repo, meta$subdir), collapse = "/"), - subdir = subdir, - username = meta$username, - ref = meta$ref, - sha = sha, - auth_token = auth_token - ) + if (auth_token_has_gitlab_api_access(host = host, pat = auth_token)) { + remote("gitlab", + host = host, + repo = paste(c(meta$repo, meta$subdir), collapse = "/"), + subdir = subdir, + username = meta$username, + ref = meta$ref, + sha = sha, + auth_token = auth_token + ) + } else if (isTRUE(git_fallback)) { + credentials <- git_credentials() + url <- paste0(build_url(host, repo), ".git") + + git2r_inst <- pkg_installed("git2r") + has_token <- !is.null(auth_token) + url_has_token <- grepl("^(.*://)?[^@/]+@", url) + + if (git2r_inst && has_token) { + credentials <- getExportedValue("git2r", "cred_user_pass")( + username = "gitlab-ci-token", + password = auth_token + ) + } else if (!url_has_token && !git2r_inst && has_token) { + url_protocol <- gsub("((.*)://)?.*", "\\1", url) + url_path <- gsub("((.*)://)?", "", url) + url <- paste0( + url_protocol, + "gitlab-ci-token:", + auth_token, + "@", + url_path + ) + } + + git_remote( + url = url, + subdir = subdir, + credentials = credentials, + ref = sha %||% meta$ref, + ... + ) + } } #' @export @@ -160,6 +195,19 @@ gitlab_commit <- function(username, repo, ref = "HEAD", json$parse_file(tmp)$id } +auth_token_has_gitlab_api_access <- function(host = "gitlab.com", pat) { + # use the /version endpoint - general access endpoint with small payload, but + # inaccessible to CI tokens + url <- build_url(host, "api", "v4", "version") + has_access <- tryCatch({ + download(tempfile(), url, headers = c("Private-Token" = pat)) + TRUE + }, error = function(e) { + FALSE + }) + has_access +} + #' Retrieve GitLab personal access token. #' #' A GitLab personal access token From 5985ecd41e6990d81fcfcf248d544833518f1295 Mon Sep 17 00:00:00 2001 From: dgkf <18220321+dgkf@users.noreply.github.com> Date: Fri, 30 Apr 2021 16:57:42 -0700 Subject: [PATCH 02/26] always try gitlab_remote when !git_fallback --- R/install-gitlab.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/install-gitlab.R b/R/install-gitlab.R index 0b97e2aa..f6f89d54 100644 --- a/R/install-gitlab.R +++ b/R/install-gitlab.R @@ -63,7 +63,7 @@ gitlab_remote <- function(repo, subdir = NULL, meta <- parse_git_repo(repo) meta$ref <- meta$ref %||% "HEAD" - if (auth_token_has_gitlab_api_access(host = host, pat = auth_token)) { + if (auth_token_has_gitlab_api_access(host = host, pat = auth_token) || !isTRUE(git_fallback)) { remote("gitlab", host = host, repo = paste(c(meta$repo, meta$subdir), collapse = "/"), @@ -73,7 +73,7 @@ gitlab_remote <- function(repo, subdir = NULL, sha = sha, auth_token = auth_token ) - } else if (isTRUE(git_fallback)) { + } else { credentials <- git_credentials() url <- paste0(build_url(host, repo), ".git") From 8bed1e4f43c3b4bfa458e683c77ff33a67e67e0a Mon Sep 17 00:00:00 2001 From: dgkf <18220321+dgkf@users.noreply.github.com> Date: Tue, 15 Jun 2021 16:51:43 -0700 Subject: [PATCH 03/26] adding error handling for http requests during remote_package_name.git2r_remote --- R/install-git.R | 9 +++++++-- tests/testthat/test-install-git.R | 16 ++++++++++++++++ 2 files changed, 23 insertions(+), 2 deletions(-) diff --git a/R/install-git.R b/R/install-git.R index 0486cb2c..af681314 100644 --- a/R/install-git.R +++ b/R/install-git.R @@ -146,9 +146,14 @@ remote_package_name.git2r_remote <- function(remote, ...) { description_path <- paste0(collapse = "/", c(remote$subdir, "DESCRIPTION")) if (grepl("^https?://", remote$url)) { + # assumes GitHub-style "/raw//" url url <- build_url(sub("\\.git$", "", remote$url), "raw", remote_sha(remote, ...), description_path) - download(tmp, url) - read_dcf(tmp)$Package + tryCatch({ + download(tmp, url) + read_dcf(tmp)$Package + }, error = function(e) { + NA_character_ + }) } else { # Try using git archive --remote to retrieve the DESCRIPTION, if the protocol # or server doesn't support that return NA diff --git a/tests/testthat/test-install-git.R b/tests/testthat/test-install-git.R index a9b5b73d..8b8b171b 100644 --- a/tests/testthat/test-install-git.R +++ b/tests/testthat/test-install-git.R @@ -165,6 +165,22 @@ test_that("remote_package_name.git2r_remote returns the package name if it exist url <- "https://github.com/igraph/rigraph.git@master" remote <- git_remote(url, git = "git2r") expect_equal(remote_package_name(remote), "igraph") + + # works for gitlab urls + url <- "https://gitlab.com/r-lib-grp/test-pkg.git" + remote <- git_remote(url, git = "git2r") + expect_equal(remote_package_name(remote), "test123") + + # safely returns NA when DESCRIPTION url is not accessible + # (condition emitted due to inaccessible git remote for remote_sha during testing) + url <- "https://gitlab.com/r-lib-grp/fake-private-repo.git" + remote <- git_remote(url, git = "git2r") + err <- tryCatch(remote_sha(remote), error = function(e) e) + expect_error( # expect same error as calling remote_sha directly + expect_equal(remote_package_name(remote), NA_character_), + class = class(err), + label = conditionMessage(err) + ) }) test_that("remote_package_name.xgit_remote returns the package name if it exists", { From 8be0803e01ecab6fb711043a912898cd2a99c58c Mon Sep 17 00:00:00 2001 From: dgkf <18220321+dgkf@users.noreply.github.com> Date: Wed, 16 Jun 2021 08:39:56 -0700 Subject: [PATCH 04/26] update NEWS; bump dev version --- DESCRIPTION | 2 +- NEWS.md | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index ddad8ef5..71264216 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: remotes Title: R Package Installation from Remote Repositories, Including 'GitHub' -Version: 2.4.0.9000 +Version: 2.4.0.9001 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")), diff --git a/NEWS.md b/NEWS.md index 4c6a6da0..99849d9b 100644 --- a/NEWS.md +++ b/NEWS.md @@ -8,7 +8,7 @@ * `system_requirements()` now works as intended if only the `os` argument is used (@mdneuzerling, #609) -* `remote_package_name.git2r_remote` and `remote_package_name.xgit_remote` now get correct package name from HTTP(S) git repo's `DESCRIPTION` file, and thus package's `DESCRIPTION` file's `Remotes` field could have `git::http(s):////[.git][@ref]` items that install remote packages using git via HTTP(S) protocal (@niheaven, #603). +* `remote_package_name.git2r_remote` and `remote_package_name.xgit_remote` now get correct package name from HTTP(S) git repo's `DESCRIPTION` file (or will remain undiscovered if unauthenticated access to the HTTP(s) endpoint is unavailable), and thus package's `DESCRIPTION` file's `Remotes` field could have `git::http(s):////[.git][@ref]` items that install remote packages using git via HTTP(S) protocal (@niheaven, #603; @dgkf #628). # remotes 2.3.0 From 0160e2c7ecace75c278ffd70bd55dc8e2e83f3cf Mon Sep 17 00:00:00 2001 From: dgkf <18220321+dgkf@users.noreply.github.com> Date: Wed, 16 Jun 2021 08:42:14 -0700 Subject: [PATCH 05/26] update NEWS --- NEWS.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/NEWS.md b/NEWS.md index 99849d9b..e98f3d8d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -8,7 +8,7 @@ * `system_requirements()` now works as intended if only the `os` argument is used (@mdneuzerling, #609) -* `remote_package_name.git2r_remote` and `remote_package_name.xgit_remote` now get correct package name from HTTP(S) git repo's `DESCRIPTION` file (or will remain undiscovered if unauthenticated access to the HTTP(s) endpoint is unavailable), and thus package's `DESCRIPTION` file's `Remotes` field could have `git::http(s):////[.git][@ref]` items that install remote packages using git via HTTP(S) protocal (@niheaven, #603; @dgkf #628). +* `remote_package_name.git2r_remote` and `remote_package_name.xgit_remote` now get correct package name from HTTP(S) git repo's `DESCRIPTION` file (or will remain undiscovered if unauthenticated access to the HTTP(s) endpoint is unavailable), and thus package's `DESCRIPTION` file's `Remotes` field could have `git::http(s):////[.git][@ref]` items that install remote packages using git via HTTP(S) protocal (@niheaven, #603; @dgkf, #628). # remotes 2.3.0 From a914a7405c857be43aa66fb0cb3d28c0160e3929 Mon Sep 17 00:00:00 2001 From: dgkf <18220321+dgkf@users.noreply.github.com> Date: Tue, 22 Jun 2021 10:45:57 -0700 Subject: [PATCH 06/26] breaking out dev note --- NEWS.md | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/NEWS.md b/NEWS.md index e98f3d8d..c395a7b3 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,7 @@ # remotes (development version) +* 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). + # remotes 2.4.0 * Re-license as MIT. (#551) @@ -8,7 +10,7 @@ * `system_requirements()` now works as intended if only the `os` argument is used (@mdneuzerling, #609) -* `remote_package_name.git2r_remote` and `remote_package_name.xgit_remote` now get correct package name from HTTP(S) git repo's `DESCRIPTION` file (or will remain undiscovered if unauthenticated access to the HTTP(s) endpoint is unavailable), and thus package's `DESCRIPTION` file's `Remotes` field could have `git::http(s):////[.git][@ref]` items that install remote packages using git via HTTP(S) protocal (@niheaven, #603; @dgkf, #628). +* `remote_package_name.git2r_remote` and `remote_package_name.xgit_remote` now get correct package name from HTTP(S) git repo's `DESCRIPTION` file, and thus package's `DESCRIPTION` file's `Remotes` field could have `git::http(s):////[.git][@ref]` items that install remote packages using git via HTTP(S) protocal (@niheaven, #603). # remotes 2.3.0 From e79a8b55c1f2510e8c4b184951705de08cd24108 Mon Sep 17 00:00:00 2001 From: dgkf <18220321+dgkf@users.noreply.github.com> Date: Thu, 24 Jun 2021 10:25:42 -0700 Subject: [PATCH 07/26] updating inst/ content; minor whitespace fix --- R/install-git.R | 2 +- inst/install-github.R | 9 +++++++-- install-github.R | 9 +++++++-- 3 files changed, 15 insertions(+), 5 deletions(-) diff --git a/R/install-git.R b/R/install-git.R index 3cc1dfaa..fb0df86e 100644 --- a/R/install-git.R +++ b/R/install-git.R @@ -152,7 +152,7 @@ remote_package_name.git2r_remote <- function(remote, ...) { download(tmp, url) read_dcf(tmp)$Package }, error = function(e) { - NA_character_ + NA_character_ }) } else { # Try using git archive --remote to retrieve the DESCRIPTION, if the protocol diff --git a/inst/install-github.R b/inst/install-github.R index 157b82ca..9c49d8ab 100644 --- a/inst/install-github.R +++ b/inst/install-github.R @@ -2734,9 +2734,14 @@ function(...) { description_path <- paste0(collapse = "/", c(remote$subdir, "DESCRIPTION")) if (grepl("^https?://", remote$url)) { + # assumes GitHub-style "/raw//" url url <- build_url(sub("\\.git$", "", remote$url), "raw", remote_sha(remote, ...), description_path) - download(tmp, url) - read_dcf(tmp)$Package + tryCatch({ + download(tmp, url) + read_dcf(tmp)$Package + }, error = function(e) { + NA_character_ + }) } else { # Try using git archive --remote to retrieve the DESCRIPTION, if the protocol # or server doesn't support that return NA diff --git a/install-github.R b/install-github.R index 157b82ca..9c49d8ab 100644 --- a/install-github.R +++ b/install-github.R @@ -2734,9 +2734,14 @@ function(...) { description_path <- paste0(collapse = "/", c(remote$subdir, "DESCRIPTION")) if (grepl("^https?://", remote$url)) { + # assumes GitHub-style "/raw//" url url <- build_url(sub("\\.git$", "", remote$url), "raw", remote_sha(remote, ...), description_path) - download(tmp, url) - read_dcf(tmp)$Package + tryCatch({ + download(tmp, url) + read_dcf(tmp)$Package + }, error = function(e) { + NA_character_ + }) } else { # Try using git archive --remote to retrieve the DESCRIPTION, if the protocol # or server doesn't support that return NA From b0d69b8c8275db25f83b39bba5c136c84c285a75 Mon Sep 17 00:00:00 2001 From: dgkf <18220321+dgkf@users.noreply.github.com> Date: Thu, 24 Jun 2021 11:59:11 -0700 Subject: [PATCH 08/26] simplifying git fallback --- R/install-gitlab.R | 31 +++---------------------------- 1 file changed, 3 insertions(+), 28 deletions(-) diff --git a/R/install-gitlab.R b/R/install-gitlab.R index f6f89d54..31a72fd8 100644 --- a/R/install-gitlab.R +++ b/R/install-gitlab.R @@ -39,7 +39,7 @@ install_gitlab <- function(repo, type = getOption("pkgType"), ...) { - 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, ...) install_remotes(remotes, auth_token = auth_token, host = host, dependencies = dependencies, @@ -63,7 +63,7 @@ gitlab_remote <- function(repo, subdir = NULL, meta <- parse_git_repo(repo) meta$ref <- meta$ref %||% "HEAD" - if (auth_token_has_gitlab_api_access(host = host, pat = auth_token) || !isTRUE(git_fallback)) { + if (!isTRUE(git_fallback) || auth_token_has_gitlab_api_access(host = host, pat = auth_token)) { remote("gitlab", host = host, repo = paste(c(meta$repo, meta$subdir), collapse = "/"), @@ -74,34 +74,9 @@ gitlab_remote <- function(repo, subdir = NULL, auth_token = auth_token ) } else { - credentials <- git_credentials() - url <- paste0(build_url(host, repo), ".git") - - git2r_inst <- pkg_installed("git2r") - has_token <- !is.null(auth_token) - url_has_token <- grepl("^(.*://)?[^@/]+@", url) - - if (git2r_inst && has_token) { - credentials <- getExportedValue("git2r", "cred_user_pass")( - username = "gitlab-ci-token", - password = auth_token - ) - } else if (!url_has_token && !git2r_inst && has_token) { - url_protocol <- gsub("((.*)://)?.*", "\\1", url) - url_path <- gsub("((.*)://)?", "", url) - url <- paste0( - url_protocol, - "gitlab-ci-token:", - auth_token, - "@", - url_path - ) - } - git_remote( - url = url, + url = paste0(build_url(host, repo), ".git"), subdir = subdir, - credentials = credentials, ref = sha %||% meta$ref, ... ) From 1b8e961785e43215e49ae2d58f6a89d1308dc73a Mon Sep 17 00:00:00 2001 From: dgkf <18220321+dgkf@users.noreply.github.com> Date: Thu, 24 Jun 2021 14:55:55 -0700 Subject: [PATCH 09/26] adding more helpful fallback messages --- R/install-gitlab.R | 57 ++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 48 insertions(+), 9 deletions(-) diff --git a/R/install-gitlab.R b/R/install-gitlab.R index 31a72fd8..c0c73e7d 100644 --- a/R/install-gitlab.R +++ b/R/install-gitlab.R @@ -58,12 +58,58 @@ install_gitlab <- function(repo, gitlab_remote <- function(repo, subdir = NULL, auth_token = gitlab_pat(), sha = NULL, host = "gitlab.com", ..., - git_fallback = getOption("remotes.gitlab_git_fallback", TRUE)) { + git_fallback = getOption("remotes.gitlab_git_fallback", TRUE), + quiet = FALSE) { meta <- parse_git_repo(repo) meta$ref <- meta$ref %||% "HEAD" - if (!isTRUE(git_fallback) || auth_token_has_gitlab_api_access(host = host, pat = auth_token)) { + # use project id api request as a canary for api access using auth_token. + project_id <- try(silent = TRUE, { + gitlab_project_id(meta$username, repo, meta$ref, host, auth_token) + }) + + if (inherits(project_id, "try-error") && isTRUE(git_fallback)) { + url <- paste0(build_url(host, repo), ".git") + url_has_token <- grepl("^(.*://)?[^@/]+@", url) + has_access_token <- !is.null(auth_token) && nchar(auth_token) > 0L + has_credentials <- !is.null(list(...)$credentials) + + if (has_access_token && !url_has_token && !has_credentials) { + # for basic http auth, + # - in GitLab CI using job account, username must be "gitlab-ci-token" + # - for Project Access Tokens, username must be "" + # - for Personal Acccess 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_protocol <- gsub("((.*)://)?.*", "\\1", url) + url_path <- gsub("((.*)://)?", "", url) + + if (!quiet) { + message("auth_token does not have scopes 'read-repository' and 'api' ", + "for host '", host, "' required to install using gitlab_remote.\n", + "Attempting git_remote using ", + sprintf("url=%sgitlab-ci-token:@%s", url_protocol, url_path)) + } + + url <- paste0(url_protocol, "gitlab-ci-token:", auth_token, "@", url_path) + } else if (has_credentials && !quiet) { + message("auth_token does not have scopes 'read-repository' and 'api' ", + "for host '", host, "' required to install using gitlab_remote.\n", + "Attempting git_remote using provided credentials for authentication.") + } else if (!quiet) { + message("auth_token does not have scopes 'read-repository' and 'api' ", + "for host '", host, "' required to install using gitlab_remote.\n", + "Attempting using git_remote.") + } + + git_remote( + url = url, + subdir = subdir, + ref = sha %||% meta$ref, + ... + ) + } else { remote("gitlab", host = host, repo = paste(c(meta$repo, meta$subdir), collapse = "/"), @@ -73,13 +119,6 @@ gitlab_remote <- function(repo, subdir = NULL, sha = sha, auth_token = auth_token ) - } else { - git_remote( - url = paste0(build_url(host, repo), ".git"), - subdir = subdir, - ref = sha %||% meta$ref, - ... - ) } } From 795b46ab4210dc2be4523f9bc81acf29ac9538d9 Mon Sep 17 00:00:00 2001 From: dgkf <18220321+dgkf@users.noreply.github.com> Date: Thu, 24 Jun 2021 15:40:10 -0700 Subject: [PATCH 10/26] adding more helpful fallback messages --- R/install-gitlab.R | 87 +++++++++++++++++++++++++++------------------- 1 file changed, 52 insertions(+), 35 deletions(-) diff --git a/R/install-gitlab.R b/R/install-gitlab.R index c0c73e7d..5dbcccfd 100644 --- a/R/install-gitlab.R +++ b/R/install-gitlab.R @@ -59,6 +59,7 @@ gitlab_remote <- function(repo, subdir = NULL, auth_token = gitlab_pat(), sha = NULL, host = "gitlab.com", ..., git_fallback = getOption("remotes.gitlab_git_fallback", TRUE), + credentials = NULL, quiet = FALSE) { meta <- parse_git_repo(repo) @@ -73,53 +74,69 @@ gitlab_remote <- function(repo, subdir = NULL, url <- paste0(build_url(host, repo), ".git") url_has_token <- grepl("^(.*://)?[^@/]+@", url) has_access_token <- !is.null(auth_token) && nchar(auth_token) > 0L - has_credentials <- !is.null(list(...)$credentials) + has_credentials <- !is.null(credentials) + use_git2r <- !is_standalone() && pkg_installed("git2r") + if (!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."))) + } + + # for basic http auth, + # - in GitLab CI using job account, username must be "gitlab-ci-token" + # - for Project Access Tokens, username must be "" + # - for Personal Acccess 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 if (has_access_token && !url_has_token && !has_credentials) { - # for basic http auth, - # - in GitLab CI using job account, username must be "gitlab-ci-token" - # - for Project Access Tokens, username must be "" - # - for Personal Acccess 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_protocol <- gsub("((.*)://)?.*", "\\1", url) - url_path <- gsub("((.*)://)?", "", url) - - if (!quiet) { - message("auth_token does not have scopes 'read-repository' and 'api' ", - "for host '", host, "' required to install using gitlab_remote.\n", - "Attempting git_remote using ", - sprintf("url=%sgitlab-ci-token:@%s", url_protocol, url_path)) + if (use_git2r) { + credentials <- getExportedValue("git2r", "cred_user_pass")( + username = "gitlab-ci-token", + password = auth_token + ) + + if (!quiet) { + message(wrap(exdent = 2L, paste0("Attempting git_remote using ", + "credentials: username='gitlab-ci-token', password="))) + } + + } else { + url_protocol <- gsub("((.*)://)?.*", "\\1", url) + url_path <- gsub("((.*)://)?", "", url) + + if (!quiet) { + message(wrap(exdent = 2L, paste0("Attempting git_remote using ", + sprintf("url=%sgitlab-ci-token:@%s", url_protocol, url_path)))) + } + + url <- paste0(url_protocol, "gitlab-ci-token:", auth_token, "@", url_path) } - - url <- paste0(url_protocol, "gitlab-ci-token:", auth_token, "@", url_path) } else if (has_credentials && !quiet) { - message("auth_token does not have scopes 'read-repository' and 'api' ", - "for host '", host, "' required to install using gitlab_remote.\n", - "Attempting git_remote using provided credentials for authentication.") + message(wrap(exdent = 2L, paste0("Attempting git_remote using provided ", + "credentials for authentication."))) } else if (!quiet) { - message("auth_token does not have scopes 'read-repository' and 'api' ", - "for host '", host, "' required to install using gitlab_remote.\n", - "Attempting using git_remote.") + message(wrap(exdent = 2L, "Attempting using git_remote.")) } - git_remote( + return(git_remote( url = url, subdir = subdir, ref = sha %||% meta$ref, + credentials = credentials, ... - ) - } else { - remote("gitlab", - host = host, - repo = paste(c(meta$repo, meta$subdir), collapse = "/"), - subdir = subdir, - username = meta$username, - ref = meta$ref, - sha = sha, - auth_token = auth_token - ) + )) } + + remote("gitlab", + host = host, + repo = paste(c(meta$repo, meta$subdir), collapse = "/"), + subdir = subdir, + username = meta$username, + ref = meta$ref, + sha = sha, + auth_token = auth_token + ) } #' @export From 00fc529b872034ee6ee2a36450300ced11321437 Mon Sep 17 00:00:00 2001 From: dgkf <18220321+dgkf@users.noreply.github.com> Date: Thu, 24 Jun 2021 15:41:24 -0700 Subject: [PATCH 11/26] adding wrap helper function --- R/utils.R | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/R/utils.R b/R/utils.R index a4efa1d3..e866fd44 100644 --- a/R/utils.R +++ b/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") +} From ab2009646b283f4dc8e54c7014c7cb1bc49809d7 Mon Sep 17 00:00:00 2001 From: dgkf <18220321+dgkf@users.noreply.github.com> Date: Thu, 24 Jun 2021 17:19:15 -0700 Subject: [PATCH 12/26] breaking out git fallback into separate remote constructor --- R/install-gitlab.R | 134 +++++++++++++++++++++++++-------------------- 1 file changed, 74 insertions(+), 60 deletions(-) diff --git a/R/install-gitlab.R b/R/install-gitlab.R index 5dbcccfd..5fde3fa3 100644 --- a/R/install-gitlab.R +++ b/R/install-gitlab.R @@ -56,11 +56,10 @@ install_gitlab <- function(repo, } gitlab_remote <- function(repo, subdir = NULL, - auth_token = gitlab_pat(), sha = NULL, - host = "gitlab.com", ..., - git_fallback = getOption("remotes.gitlab_git_fallback", TRUE), - credentials = NULL, - quiet = FALSE) { + auth_token = gitlab_pat(), 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" @@ -70,72 +69,87 @@ gitlab_remote <- function(repo, subdir = NULL, 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)) { - url <- paste0(build_url(host, repo), ".git") - url_has_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 (!quiet) { + 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."))) - } - - # for basic http auth, - # - in GitLab CI using job account, username must be "gitlab-ci-token" - # - for Project Access Tokens, username must be "" - # - for Personal Acccess 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 - if (has_access_token && !url_has_token && !has_credentials) { - if (use_git2r) { - credentials <- getExportedValue("git2r", "cred_user_pass")( - username = "gitlab-ci-token", - password = auth_token - ) - - if (!quiet) { - message(wrap(exdent = 2L, paste0("Attempting git_remote using ", - "credentials: username='gitlab-ci-token', password="))) - } - - } else { - url_protocol <- gsub("((.*)://)?.*", "\\1", url) - url_path <- gsub("((.*)://)?", "", url) - - if (!quiet) { - message(wrap(exdent = 2L, paste0("Attempting git_remote using ", - sprintf("url=%sgitlab-ci-token:@%s", url_protocol, url_path)))) - } - - url <- paste0(url_protocol, "gitlab-ci-token:", auth_token, "@", url_path) - } - } else if (has_credentials && !quiet) { - message(wrap(exdent = 2L, paste0("Attempting git_remote using provided ", - "credentials for authentication."))) } else if (!quiet) { - message(wrap(exdent = 2L, "Attempting using git_remote.")) + message(wrap(exdent = 2L, paste0("Unable to establish api access for ", + "host '", host, "' required to install using gitlab_remote."))) } - return(git_remote( - url = url, - subdir = subdir, - ref = sha %||% meta$ref, - credentials = credentials, + gitlab_to_git_remote( + repo = repo, + subdir = subdir, + auth_token = auth_token, + sha = sha, + host = host, + quiet = quiet, ... - )) + ) + } else { + remote("gitlab", + host = host, + repo = paste(c(meta$repo, meta$subdir), collapse = "/"), + subdir = subdir, + username = meta$username, + ref = meta$ref, + sha = sha, + auth_token = auth_token + ) + } +} + +gitlab_to_git_remote <- function(repo, subdir = NULL, + auth_token = gitlab_pat(), sha = 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 "" + # - 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_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="))) + + 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:", auth_token, "@", url_path) + + if (!quiet) + message(wrap(exdent = 2L, paste0("Attempting git_remote using ", + sprintf("url=%sgitlab-ci-token:@%s", url_protocol, url_path)))) } - remote("gitlab", - host = host, - repo = paste(c(meta$repo, meta$subdir), collapse = "/"), + git_remote( + url = url, subdir = subdir, - username = meta$username, - ref = meta$ref, - sha = sha, - auth_token = auth_token + ref = sha %||% meta$ref, + credentials = credentials, + ... ) } From 915c08cff340c2181bf51044d571a9d90b841f9a Mon Sep 17 00:00:00 2001 From: dgkf <18220321+dgkf@users.noreply.github.com> Date: Thu, 24 Jun 2021 17:21:00 -0700 Subject: [PATCH 13/26] fixing undef var --- R/install-gitlab.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/install-gitlab.R b/R/install-gitlab.R index 5fde3fa3..a18ede73 100644 --- a/R/install-gitlab.R +++ b/R/install-gitlab.R @@ -119,6 +119,7 @@ gitlab_to_git_remote <- function(repo, subdir = NULL, 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") From d9ca73a235b8551412c076bf047afa5a983de8a3 Mon Sep 17 00:00:00 2001 From: dgkf <18220321+dgkf@users.noreply.github.com> Date: Thu, 24 Jun 2021 17:30:08 -0700 Subject: [PATCH 14/26] handling sha/ref reconcilliation --- R/install-gitlab.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/install-gitlab.R b/R/install-gitlab.R index a18ede73..766ed5a1 100644 --- a/R/install-gitlab.R +++ b/R/install-gitlab.R @@ -84,7 +84,7 @@ gitlab_remote <- function(repo, subdir = NULL, repo = repo, subdir = subdir, auth_token = auth_token, - sha = sha, + ref = sha %||% meta$ref, host = host, quiet = quiet, ... @@ -103,7 +103,7 @@ gitlab_remote <- function(repo, subdir = NULL, } gitlab_to_git_remote <- function(repo, subdir = NULL, - auth_token = gitlab_pat(), sha = NULL, + auth_token = gitlab_pat(), ref = NULL, host = "gitlab.com", ..., git_fallback = getOption("remotes.gitlab_git_fallback", TRUE), credentials = NULL, @@ -148,7 +148,7 @@ gitlab_to_git_remote <- function(repo, subdir = NULL, git_remote( url = url, subdir = subdir, - ref = sha %||% meta$ref, + ref = ref, credentials = credentials, ... ) From 8b9911f582ef4e0768b02bca383866db988ea917 Mon Sep 17 00:00:00 2001 From: dgkf <18220321+dgkf@users.noreply.github.com> Date: Thu, 24 Jun 2021 20:05:36 -0700 Subject: [PATCH 15/26] adding parsing for username:password in git url --- R/install-git.R | 28 ++++++++++++++++++++++------ 1 file changed, 22 insertions(+), 6 deletions(-) diff --git a/R/install-git.R b/R/install-git.R index fb0df86e..d73c6ad4 100644 --- a/R/install-git.R +++ b/R/install-git.R @@ -79,10 +79,26 @@ 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, "(?(?:git@)?[^@]*)(?:@(?.*))?") + 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) +} + + +parse_git_url <- function(url) { + re_match(url, paste0( + "(?.*://)?(?(?[^:@]*)(?::(?[^@]*)?)?@)?", + "(?(?:git@)?[^@]*)", + "(?:@(?.*))?" + )) +} + + +scrubbed_git_url <- function(url) { + meta <- parse_git_url(url) + paste0(meta$prot, meta$url) } @@ -107,7 +123,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 ", scrubbed_git_url(x$url)) } bundle <- tempfile() @@ -132,7 +148,7 @@ remote_metadata.git2r_remote <- function(x, bundle = NULL, source = NULL, sha = list( RemoteType = "git2r", - RemoteUrl = x$url, + RemoteUrl = scrubbed_git_url(x$url), RemoteSubdir = x$subdir, RemoteRef = x$ref, RemoteSha = sha @@ -220,7 +236,7 @@ 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 ", scrubbed_git_url(x$url)) } bundle <- tempfile() @@ -245,7 +261,7 @@ remote_metadata.xgit_remote <- function(x, bundle = NULL, source = NULL, sha = N list( RemoteType = "xgit", - RemoteUrl = x$url, + RemoteUrl = scrubbed_git_url(x$url), RemoteSubdir = x$subdir, RemoteRef = x$ref, RemoteSha = sha, From 409ea8418bd196c9fed9bc652a8c1352abaf0a42 Mon Sep 17 00:00:00 2001 From: dgkf <18220321+dgkf@users.noreply.github.com> Date: Thu, 24 Jun 2021 20:20:15 -0700 Subject: [PATCH 16/26] censoring password in git command message --- R/git.R | 6 ++++-- R/install-git.R | 24 ++++++++++++++++-------- 2 files changed, 20 insertions(+), 10 deletions(-) diff --git a/R/git.R b/R/git.R index 153ad5d1..7b3f7d9e 100644 --- a/R/git.R +++ b/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)) diff --git a/R/install-git.R b/R/install-git.R index d73c6ad4..8ed4e3c2 100644 --- a/R/install-git.R +++ b/R/install-git.R @@ -96,12 +96,19 @@ parse_git_url <- function(url) { } -scrubbed_git_url <- function(url) { +git_anon_url <- function(url) { meta <- parse_git_url(url) paste0(meta$prot, meta$url) } +git_censored_url <- function(url) { + meta <- parse_git_url(url) + auth <- sub(meta$password, strrep("*", nchar(meta$password)), meta$auth, fixed = TRUE) + paste0(meta$prot, meta$auth, meta$url) +} + + git_remote_git2r <- function(url, subdir = NULL, ref = NULL, credentials = git_credentials()) { remote("git2r", url = url, @@ -123,7 +130,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 ", scrubbed_git_url(x$url)) + message("Downloading git repo ", git_anon_url(x$url)) } bundle <- tempfile() @@ -148,7 +155,7 @@ remote_metadata.git2r_remote <- function(x, bundle = NULL, source = NULL, sha = list( RemoteType = "git2r", - RemoteUrl = scrubbed_git_url(x$url), + RemoteUrl = git_anon_url(x$url), RemoteSubdir = x$subdir, RemoteRef = x$ref, RemoteSha = sha @@ -236,14 +243,15 @@ format.git2r_remote <- function(x, ...) { #' @export remote_download.xgit_remote <- function(x, quiet = FALSE) { if (!quiet) { - message("Downloading git repo ", scrubbed_git_url(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) + args <- c(args, x$url, bundle) + git(paste0(args, collapse = " "), quiet = TRUE, display_args = display_args) if (!is.null(x$ref)) { git(paste0(c("fetch", "origin", x$ref), collapse = " "), quiet = quiet, path = bundle) @@ -261,7 +269,7 @@ remote_metadata.xgit_remote <- function(x, bundle = NULL, source = NULL, sha = N list( RemoteType = "xgit", - RemoteUrl = scrubbed_git_url(x$url), + RemoteUrl = git_anon_url(x$url), RemoteSubdir = x$subdir, RemoteRef = x$ref, RemoteSha = sha, From f6af23240e346b02e5d1fd98dcb717cf9255c32f Mon Sep 17 00:00:00 2001 From: dgkf <18220321+dgkf@users.noreply.github.com> Date: Thu, 24 Jun 2021 20:26:06 -0700 Subject: [PATCH 17/26] actually censoring messages in git output --- R/install-git.R | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/R/install-git.R b/R/install-git.R index 8ed4e3c2..457d5884 100644 --- a/R/install-git.R +++ b/R/install-git.R @@ -104,8 +104,10 @@ git_anon_url <- function(url) { git_censored_url <- function(url) { meta <- parse_git_url(url) - auth <- sub(meta$password, strrep("*", nchar(meta$password)), meta$auth, fixed = TRUE) - paste0(meta$prot, meta$auth, meta$url) + auth <- meta$username + if (nchar(meta$password)) auth <- paste0(auth, ":", strrep("*", nchar(meta$password))) + if (nchar(auth)) auth <- paste0(auth, "@") + paste0(meta$prot, auth, meta$url) } From 4f49ce08c22e777c4438ce4491211416b25cb37c Mon Sep 17 00:00:00 2001 From: dgkf <18220321+dgkf@users.noreply.github.com> Date: Thu, 24 Jun 2021 20:44:36 -0700 Subject: [PATCH 18/26] enabling censored clone output --- R/install-git.R | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/R/install-git.R b/R/install-git.R index 457d5884..08280172 100644 --- a/R/install-git.R +++ b/R/install-git.R @@ -105,7 +105,7 @@ git_anon_url <- function(url) { git_censored_url <- function(url) { meta <- parse_git_url(url) auth <- meta$username - if (nchar(meta$password)) auth <- paste0(auth, ":", strrep("*", nchar(meta$password))) + if (nchar(meta$password)) auth <- paste0(auth, ":", strrep("*", 8L)) if (nchar(auth)) auth <- paste0(auth, "@") paste0(meta$prot, auth, meta$url) } @@ -252,8 +252,11 @@ remote_download.xgit_remote <- function(x, quiet = FALSE) { 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) - git(paste0(args, collapse = " "), quiet = TRUE, display_args = display_args) + 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) From e90a52c93339ae1c87754fc874f8a265cd76287a Mon Sep 17 00:00:00 2001 From: dgkf <18220321+dgkf@users.noreply.github.com> Date: Fri, 25 Jun 2021 11:57:22 -0700 Subject: [PATCH 19/26] adding tests --- R/install-git.R | 4 +- R/install-gitlab.R | 18 +--- tests/testthat/test-git.R | 154 +++++++++++++++++++++++++++ tests/testthat/test-install-gitlab.R | 57 ++++++++++ 4 files changed, 216 insertions(+), 17 deletions(-) diff --git a/R/install-git.R b/R/install-git.R index 08280172..5d2a62e4 100644 --- a/R/install-git.R +++ b/R/install-git.R @@ -89,8 +89,8 @@ git_remote <- function(url, subdir = NULL, ref = NULL, credentials = git_credent parse_git_url <- function(url) { re_match(url, paste0( - "(?.*://)?(?(?[^:@]*)(?::(?[^@]*)?)?@)?", - "(?(?:git@)?[^@]*)", + "(?.*://)?(?(?[^:@/]*)(?::(?[^@/]*)?)?@)?", + "(?[^@]*)", "(?:@(?.*))?" )) } diff --git a/R/install-gitlab.R b/R/install-gitlab.R index 766ed5a1..9e9525ed 100644 --- a/R/install-gitlab.R +++ b/R/install-gitlab.R @@ -66,7 +66,7 @@ gitlab_remote <- function(repo, subdir = NULL, # use project id api request as a canary for api access using auth_token. project_id <- try(silent = TRUE, { - gitlab_project_id(meta$username, repo, meta$ref, host, auth_token) + gitlab_project_id(meta$username, meta$repo, meta$ref, host, auth_token) }) has_access_token <- !is.null(auth_token) && nchar(auth_token) > 0L @@ -102,6 +102,7 @@ gitlab_remote <- function(repo, subdir = NULL, } } +#' @importFrom utils URLencode gitlab_to_git_remote <- function(repo, subdir = NULL, auth_token = gitlab_pat(), ref = NULL, host = "gitlab.com", ..., @@ -138,7 +139,7 @@ gitlab_to_git_remote <- function(repo, subdir = NULL, } 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:", auth_token, "@", url_path) + url <- paste0(url_protocol, "gitlab-ci-token:", utils::URLencode(auth_token), "@", url_path) if (!quiet) message(wrap(exdent = 2L, paste0("Attempting git_remote using ", @@ -241,19 +242,6 @@ gitlab_commit <- function(username, repo, ref = "HEAD", json$parse_file(tmp)$id } -auth_token_has_gitlab_api_access <- function(host = "gitlab.com", pat) { - # use the /version endpoint - general access endpoint with small payload, but - # inaccessible to CI tokens - url <- build_url(host, "api", "v4", "version") - has_access <- tryCatch({ - download(tempfile(), url, headers = c("Private-Token" = pat)) - TRUE - }, error = function(e) { - FALSE - }) - has_access -} - #' Retrieve GitLab personal access token. #' #' A GitLab personal access token diff --git a/tests/testthat/test-git.R b/tests/testthat/test-git.R index e7c35ce7..0929e405 100644 --- a/tests/testthat/test-git.R +++ b/tests/testthat/test-git.R @@ -69,3 +69,157 @@ test_that("check_git_path", { "Git does not seem to be installed on your system" ) }) + + +test_that("parse_git_url handles http-style repo urls", { + prot <- "http://" + username <- "janedoe" + password <- "12345" + url <- "www.gitzone.com/namespace/repo.git" + ref <- "HEAD" + + meta <- parse_git_url(paste0(url)) + expect_equal(meta$prot, "") + expect_equal(meta$auth, "") + expect_equal(meta$username, "") + expect_equal(meta$password, "") + expect_equal(meta$url, url) + expect_equal(meta$ref, "") + + meta <- parse_git_url(paste0(prot, url)) + expect_equal(meta$prot, prot) + expect_equal(meta$auth, "") + expect_equal(meta$username, "") + expect_equal(meta$password, "") + expect_equal(meta$url, url) + expect_equal(meta$ref, "") + + meta <- parse_git_url(paste0(prot, url, "@", ref)) + expect_equal(meta$prot, prot) + expect_equal(meta$auth, "") + expect_equal(meta$username, "") + expect_equal(meta$password, "") + expect_equal(meta$url, url) + expect_equal(meta$ref, ref) + + meta <- parse_git_url(paste0(url, "@", ref)) + expect_equal(meta$prot, "") + expect_equal(meta$auth, "") + expect_equal(meta$username, "") + expect_equal(meta$password, "") + expect_equal(meta$url, url) + expect_equal(meta$ref, ref) + + meta <- parse_git_url(paste0(username, "@", url, "@", ref)) + expect_equal(meta$prot, "") + expect_equal(meta$auth, paste0(username, "@")) + expect_equal(meta$username, username) + expect_equal(meta$password, "") + expect_equal(meta$url, url) + expect_equal(meta$ref, ref) + + meta <- parse_git_url(paste0(prot, username, "@", url, "@", ref)) + expect_equal(meta$prot, prot) + expect_equal(meta$auth, paste0(username, "@")) + expect_equal(meta$username, username) + expect_equal(meta$password, "") + expect_equal(meta$url, url) + expect_equal(meta$ref, ref) + + meta <- parse_git_url(paste0(username, ":", password, "@", url)) + expect_equal(meta$prot, "") + expect_equal(meta$auth, paste0(username, ":", password, "@")) + expect_equal(meta$username, username) + expect_equal(meta$password, password) + expect_equal(meta$url, url) + expect_equal(meta$ref, "") + + meta <- parse_git_url(paste0(username, ":", password, "@", url, "@", ref)) + expect_equal(meta$prot, "") + expect_equal(meta$auth, paste0(username, ":", password, "@")) + expect_equal(meta$username, username) + expect_equal(meta$password, password) + expect_equal(meta$url, url) + expect_equal(meta$ref, ref) + + meta <- parse_git_url(paste0(prot, username, ":", password, "@", url, "@", ref)) + expect_equal(meta$prot, prot) + expect_equal(meta$auth, paste0(username, ":", password, "@")) + expect_equal(meta$username, username) + expect_equal(meta$password, password) + expect_equal(meta$url, url) + expect_equal(meta$ref, ref) +}) + + +test_that("parse_git_url handles ssh-style repo urls", { + username <- "git" + url <- "gitzone.com:namespace/repo.git" + git_url <- paste0(username, "@", url) + ref <- "HEAD" + + meta <- parse_git_url(git_url) + expect_equal(meta$prot, "") + expect_equal(meta$auth, "git@") + expect_equal(meta$username, "git") + expect_equal(meta$password, "") + expect_equal(meta$url, url) + expect_equal(meta$ref, "") + + meta <- parse_git_url(paste0(git_url, "@", ref)) + expect_equal(meta$prot, "") + expect_equal(meta$auth, paste0(username, "@")) + expect_equal(meta$username, username) + expect_equal(meta$password, "") + expect_equal(meta$url, url) + expect_equal(meta$ref, ref) +}) + + +test_that("git_anon_url removes username and password", { + prot <- "http://" + username <- "janedoe" + password <- "12345" + url <- "www.gitzone.com/namespace/repo.git" + ref <- "HEAD" + + expect_equal(git_anon_url(url), url) + expect_equal(git_anon_url(i <- paste0(prot, url)), i) + expect_equal(git_anon_url(paste0(prot, url, "@", ref)), paste0(prot, url)) + expect_equal(git_anon_url(paste0(url, "@", ref)), url) + expect_equal(git_anon_url(paste0(username, "@", url, "@", ref)), url) + expect_equal(git_anon_url(paste0(prot, username, "@", url, "@", ref)), paste0(prot, url)) + expect_equal(git_anon_url(paste0(username, ":", password, "@", url)), url) + expect_equal(git_anon_url(paste0(username, ":", password, "@", url, "@", ref)), url) + expect_equal(git_anon_url(paste0(prot, username, ":", password, "@", url, "@", ref)), paste0(prot, url)) +}) + + +test_that("git_censored_url replaces password with asterisks", { + prot <- "http://" + username <- "janedoe" + password <- "12345" + asterisks <- strrep("*", 8L) + url <- "www.gitzone.com/namespace/repo.git" + ref <- "HEAD" + + expect_equal(git_censored_url(url), url) + expect_equal(git_censored_url(i <- paste0(prot, url)), i) + expect_equal(git_censored_url(paste0(prot, url, "@", ref)), paste0(prot, url)) + expect_equal(git_censored_url(paste0(url, "@", ref)), url) + expect_equal( + git_censored_url(paste0(username, "@", url, "@", ref)), + paste0(username, "@", url)) + expect_equal( + git_censored_url(paste0(prot, username, "@", url, "@", ref)), + paste0(prot, username, "@", url)) + expect_equal( + git_censored_url(paste0(username, ":", password, "@", url)), + paste0(username, ":", asterisks, "@", url)) + expect_equal( + git_censored_url(paste0(username, ":", password, "@", url, "@", ref)), + paste0(username, ":", asterisks, "@", url)) + expect_equal( + git_censored_url(paste0(prot, username, ":", password, "@", url, "@", ref)), + paste0(prot, username, ":", asterisks, "@", url)) +}) diff --git a/tests/testthat/test-install-gitlab.R b/tests/testthat/test-install-gitlab.R index 661cd821..78a6fcca 100644 --- a/tests/testthat/test-install-gitlab.R +++ b/tests/testthat/test-install-gitlab.R @@ -148,3 +148,60 @@ test_that("gitlab_project_id", { }) +test_that("gitlab_remote reverts to git2r_remote when git_fallback", { + skip_if_not_installed("git2r") + withr::local_envvar(c(GITLAB_PAT="badcafe")) + + msgs <- capture.output(type = "message", { + r <- gitlab_remote("fakenamespace/namespace/repo", git_fallback = TRUE) + }) + expect_true(any(grepl("auth_token does not", msgs))) + expect_true(any(grepl("Attempting git_remote using credentials", msgs))) + expect_s3_class(r, "git2r_remote") + expect_equal(r$credentials$username, "gitlab-ci-token") + expect_equal(r$credentials$password, "badcafe") + + withr::local_envvar(c(GITLAB_PAT="")) + msgs <- capture.output(type = "message", { + r <- gitlab_remote("fakenamespace/namespace/repo", git_fallback = TRUE) + }) + expect_true(any(grepl("Unable to establish api access", msgs))) + expect_s3_class(r, "git2r_remote") + expect_equal(r$credentials, NULL) + + r <- gitlab_remote("fakenamespace/namespace/repo", git_fallback = FALSE) + expect_s3_class(r, "gitlab_remote") + +}) + +test_that("gitlab_remote reverts to xgit_remote when git_fallback", { + withr::local_envvar(c(GITLAB_PAT="")) + mockery::stub(gitlab_remote, "pkg_installed", FALSE, 3L) + + msgs <- capture.output(type = "message", { + r <- gitlab_remote("fakenamespace/namespace/repo", git_fallback = TRUE) + }) + + expect_true(any(grepl("Unable to establish api access", msgs))) + expect_s3_class(r, "xgit_remote") + expect_equal(r$url, "https://gitlab.com/fakenamespace/namespace/repo.git") + + withr::local_envvar(c(GITLAB_PAT="badcafe")) + + msgs <- capture.output(type = "message", { + r <- gitlab_remote("fakenamespace/namespace/repo", git_fallback = TRUE) + }) + + expect_true(any(grepl("Attempting git_remote", msgs))) + expect_true(any(grepl("url.*", msgs))) + expect_s3_class(r, "xgit_remote") + expect_equal(r$url, "https://gitlab-ci-token:badcafe@gitlab.com/fakenamespace/namespace/repo.git") + + msgs <- capture.output(type = "message", { + r <- gitlab_remote("fakenamespace/namespace/repo", auth_token = "goodcafe", host = "github.com", git_fallback = TRUE) + }) + + expect_s3_class(r, "xgit_remote") + expect_equal(r$url, "https://gitlab-ci-token:goodcafe@github.com/fakenamespace/namespace/repo.git") +}) + From b477334683a09767290999bf6f8759f0bdf57a03 Mon Sep 17 00:00:00 2001 From: dgkf <18220321+dgkf@users.noreply.github.com> Date: Fri, 25 Jun 2021 12:34:21 -0700 Subject: [PATCH 20/26] improving documentation of new behavios --- R/install-git.R | 26 ++++++++++++++++++++++---- R/install-gitlab.R | 22 ++++++++++++++++++---- 2 files changed, 40 insertions(+), 8 deletions(-) diff --git a/R/install-git.R b/R/install-git.R index 5d2a62e4..cbd0ea9f 100644 --- a/R/install-git.R +++ b/R/install-git.R @@ -86,7 +86,14 @@ git_remote <- function(url, subdir = NULL, ref = NULL, credentials = git_credent 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( "(?.*://)?(?(?[^:@/]*)(?::(?[^@/]*)?)?@)?", @@ -95,13 +102,25 @@ parse_git_url <- function(url) { )) } - +#' 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 @@ -110,7 +129,6 @@ git_censored_url <- function(url) { paste0(meta$prot, auth, meta$url) } - git_remote_git2r <- function(url, subdir = NULL, ref = NULL, credentials = git_credentials()) { remote("git2r", url = url, diff --git a/R/install-gitlab.R b/R/install-gitlab.R index 9e9525ed..342e9ff5 100644 --- a/R/install-gitlab.R +++ b/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,16 @@ install_gitlab <- function(repo, build_manual = FALSE, build_vignettes = FALSE, repos = getOption("repos"), type = getOption("pkgType"), - ...) { - - remotes <- lapply(repo, gitlab_remote, subdir = subdir, auth_token = auth_token, host = host, ...) + ..., + git_fallback = getOption("remotes.gitlab_git_fallback", TRUE), + credentials = git_credentials()) { + + remotes <- lapply(repo, + gitlab_remote, + subdir = subdir, + auth_token = auth_token, + host = host, + credentials = credentials) install_remotes(remotes, auth_token = auth_token, host = host, dependencies = dependencies, From 4021939a47a58b172e031cd8d9676216c7d18244 Mon Sep 17 00:00:00 2001 From: dgkf <18220321+dgkf@users.noreply.github.com> Date: Fri, 25 Jun 2021 17:34:20 -0700 Subject: [PATCH 21/26] adding tests; docs --- NAMESPACE | 1 + R/install-git.R | 4 +- R/install-gitlab.R | 26 ++-- man/git_anon_url.Rd | 15 +++ man/git_censored_url.Rd | 15 +++ man/install_gitlab.Rd | 14 ++- man/parse_git_url.Rd | 16 +++ tests/testthat/test-git.R | 173 ++++++++++----------------- tests/testthat/test-install-gitlab.R | 77 ++++++------ 9 files changed, 180 insertions(+), 161 deletions(-) create mode 100644 man/git_anon_url.Rd create mode 100644 man/git_censored_url.Rd create mode 100644 man/parse_git_url.Rd diff --git a/NAMESPACE b/NAMESPACE index 7e0930a0..d3ed1bc5 100644 --- a/NAMESPACE +++ b/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) diff --git a/R/install-git.R b/R/install-git.R index cbd0ea9f..fbd20ab0 100644 --- a/R/install-git.R +++ b/R/install-git.R @@ -124,8 +124,8 @@ git_anon_url <- function(url) { git_censored_url <- function(url) { meta <- parse_git_url(url) auth <- meta$username - if (nchar(meta$password)) auth <- paste0(auth, ":", strrep("*", 8L)) - if (nchar(auth)) auth <- paste0(auth, "@") + auth <- ifelse(nzchar(meta$password), paste0(auth, ":", strrep("*", 8L)), auth) + auth <- ifelse(nzchar(auth), paste0(auth, "@"), auth) paste0(meta$prot, auth, meta$url) } diff --git a/R/install-gitlab.R b/R/install-gitlab.R index 342e9ff5..a7617571 100644 --- a/R/install-gitlab.R +++ b/R/install-gitlab.R @@ -48,12 +48,15 @@ install_gitlab <- function(repo, git_fallback = getOption("remotes.gitlab_git_fallback", TRUE), credentials = git_credentials()) { - remotes <- lapply(repo, - gitlab_remote, - subdir = subdir, - auth_token = auth_token, - host = host, - credentials = credentials) + 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, @@ -70,7 +73,7 @@ install_gitlab <- function(repo, } gitlab_remote <- function(repo, subdir = NULL, - auth_token = gitlab_pat(), sha = NULL, + auth_token = gitlab_pat(quiet), sha = NULL, host = "gitlab.com", ..., git_fallback = getOption("remotes.gitlab_git_fallback", TRUE), quiet = FALSE) { @@ -79,8 +82,9 @@ gitlab_remote <- function(repo, subdir = NULL, meta$ref <- meta$ref %||% "HEAD" # 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, meta$repo, meta$ref, host, auth_token) + gitlab_project_id(meta$username, repo, meta$ref, host, auth_token) }) has_access_token <- !is.null(auth_token) && nchar(auth_token) > 0L @@ -95,7 +99,7 @@ gitlab_remote <- function(repo, subdir = NULL, } gitlab_to_git_remote( - repo = repo, + repo = paste0(c(meta$username, repo), collapse = "/"), subdir = subdir, auth_token = auth_token, ref = sha %||% meta$ref, @@ -106,7 +110,7 @@ gitlab_remote <- function(repo, subdir = NULL, } else { remote("gitlab", host = host, - repo = paste(c(meta$repo, meta$subdir), collapse = "/"), + repo = repo, subdir = subdir, username = meta$username, ref = meta$ref, @@ -118,7 +122,7 @@ gitlab_remote <- function(repo, subdir = NULL, #' @importFrom utils URLencode gitlab_to_git_remote <- function(repo, subdir = NULL, - auth_token = gitlab_pat(), ref = NULL, + auth_token = gitlab_pat(quiet), ref = NULL, host = "gitlab.com", ..., git_fallback = getOption("remotes.gitlab_git_fallback", TRUE), credentials = NULL, diff --git a/man/git_anon_url.Rd b/man/git_anon_url.Rd new file mode 100644 index 00000000..c71d8d40 --- /dev/null +++ b/man/git_anon_url.Rd @@ -0,0 +1,15 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/install-git.R +\name{git_anon_url} +\alias{git_anon_url} +\title{Anonymize a git-style url} +\usage{ +git_anon_url(url) +} +\arguments{ +\item{url}{A \code{character} vector of urls to parse} +} +\description{ +Strip a url of user-specific username and password if embedded as part of a +url string. +} diff --git a/man/git_censored_url.Rd b/man/git_censored_url.Rd new file mode 100644 index 00000000..50a42b78 --- /dev/null +++ b/man/git_censored_url.Rd @@ -0,0 +1,15 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/install-git.R +\name{git_censored_url} +\alias{git_censored_url} +\title{Censor user password in a git-style url} +\usage{ +git_censored_url(url) +} +\arguments{ +\item{url}{A \code{character} vector of urls to parse} +} +\description{ +If a password is provided as part of a url string, censor the url string, +replacing the password with a series of asterisks. +} diff --git a/man/install_gitlab.Rd b/man/install_gitlab.Rd index 2f463f9e..4d762824 100644 --- a/man/install_gitlab.Rd +++ b/man/install_gitlab.Rd @@ -19,7 +19,9 @@ install_gitlab( build_vignettes = FALSE, repos = getOption("repos"), type = getOption("pkgType"), - ... + ..., + git_fallback = getOption("remotes.gitlab_git_fallback", TRUE), + credentials = git_credentials() ) } \arguments{ @@ -83,6 +85,16 @@ since the previous install.} \item{type}{Type of package to \code{update}.} \item{...}{Other arguments passed on to \code{\link[utils:install.packages]{utils::install.packages()}}.} + +\item{git_fallback}{A \code{logical} value indicating whether to defer to using +a \code{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 +\code{"remotes.gitlab_git_fallback"}, or \code{TRUE} if the option is not set.} + +\item{credentials}{A git2r credentials object passed through to clone. +Supplying this argument implies using \code{git2r} with \code{git}.} } \description{ This function is vectorised on \code{repo} so you can install multiple diff --git a/man/parse_git_url.Rd b/man/parse_git_url.Rd new file mode 100644 index 00000000..1b388cb5 --- /dev/null +++ b/man/parse_git_url.Rd @@ -0,0 +1,16 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/install-git.R +\name{parse_git_url} +\alias{parse_git_url} +\title{Extract URL parts from a git-style url} +\usage{ +parse_git_url(url) +} +\arguments{ +\item{url}{A \code{character} vector of urls to parse} +} +\description{ +Although not a full url parser, this expression captures and separates url +protocol (\code{prot}), full authentication prefix (\code{auth}, containing \code{username} +and \code{password}), the host and path (\code{url}) and git reference (\code{ref}). +} diff --git a/tests/testthat/test-git.R b/tests/testthat/test-git.R index 0929e405..92925177 100644 --- a/tests/testthat/test-git.R +++ b/tests/testthat/test-git.R @@ -71,117 +71,47 @@ test_that("check_git_path", { }) -test_that("parse_git_url handles http-style repo urls", { +test_that("git urls are properly parsed, anonymized and censored", { prot <- "http://" username <- "janedoe" password <- "12345" + asterisks <- strrep("*", 8L) url <- "www.gitzone.com/namespace/repo.git" ref <- "HEAD" - meta <- parse_git_url(paste0(url)) - expect_equal(meta$prot, "") - expect_equal(meta$auth, "") - expect_equal(meta$username, "") - expect_equal(meta$password, "") - expect_equal(meta$url, url) - expect_equal(meta$ref, "") - - meta <- parse_git_url(paste0(prot, url)) - expect_equal(meta$prot, prot) - expect_equal(meta$auth, "") - expect_equal(meta$username, "") - expect_equal(meta$password, "") - expect_equal(meta$url, url) - expect_equal(meta$ref, "") - - meta <- parse_git_url(paste0(prot, url, "@", ref)) - expect_equal(meta$prot, prot) - expect_equal(meta$auth, "") - expect_equal(meta$username, "") - expect_equal(meta$password, "") - expect_equal(meta$url, url) - expect_equal(meta$ref, ref) - - meta <- parse_git_url(paste0(url, "@", ref)) - expect_equal(meta$prot, "") - expect_equal(meta$auth, "") - expect_equal(meta$username, "") - expect_equal(meta$password, "") - expect_equal(meta$url, url) - expect_equal(meta$ref, ref) - - meta <- parse_git_url(paste0(username, "@", url, "@", ref)) - expect_equal(meta$prot, "") - expect_equal(meta$auth, paste0(username, "@")) - expect_equal(meta$username, username) - expect_equal(meta$password, "") - expect_equal(meta$url, url) - expect_equal(meta$ref, ref) - - meta <- parse_git_url(paste0(prot, username, "@", url, "@", ref)) - expect_equal(meta$prot, prot) - expect_equal(meta$auth, paste0(username, "@")) - expect_equal(meta$username, username) - expect_equal(meta$password, "") - expect_equal(meta$url, url) - expect_equal(meta$ref, ref) - - meta <- parse_git_url(paste0(username, ":", password, "@", url)) - expect_equal(meta$prot, "") - expect_equal(meta$auth, paste0(username, ":", password, "@")) - expect_equal(meta$username, username) - expect_equal(meta$password, password) - expect_equal(meta$url, url) - expect_equal(meta$ref, "") - - meta <- parse_git_url(paste0(username, ":", password, "@", url, "@", ref)) - expect_equal(meta$prot, "") - expect_equal(meta$auth, paste0(username, ":", password, "@")) - expect_equal(meta$username, username) - expect_equal(meta$password, password) - expect_equal(meta$url, url) - expect_equal(meta$ref, ref) - - meta <- parse_git_url(paste0(prot, username, ":", password, "@", url, "@", ref)) - expect_equal(meta$prot, prot) - expect_equal(meta$auth, paste0(username, ":", password, "@")) - expect_equal(meta$username, username) - expect_equal(meta$password, password) - expect_equal(meta$url, url) - expect_equal(meta$ref, ref) -}) - - -test_that("parse_git_url handles ssh-style repo urls", { - username <- "git" - url <- "gitzone.com:namespace/repo.git" - git_url <- paste0(username, "@", url) - ref <- "HEAD" - - meta <- parse_git_url(git_url) - expect_equal(meta$prot, "") - expect_equal(meta$auth, "git@") - expect_equal(meta$username, "git") - expect_equal(meta$password, "") - expect_equal(meta$url, url) - expect_equal(meta$ref, "") - - meta <- parse_git_url(paste0(git_url, "@", ref)) - expect_equal(meta$prot, "") - expect_equal(meta$auth, paste0(username, "@")) - expect_equal(meta$username, username) - expect_equal(meta$password, "") - expect_equal(meta$url, url) - expect_equal(meta$ref, ref) -}) + df <- expand.grid( + prot = c("", prot), + username = c("", username), + password = c("", password), + url = url, + ref = c("", ref), + stringsAsFactors = FALSE + ) - -test_that("git_anon_url removes username and password", { - prot <- "http://" - username <- "janedoe" - password <- "12345" - url <- "www.gitzone.com/namespace/repo.git" - ref <- "HEAD" + # filter invalid urls with password but no username + df <- df[!(!nchar(df$username) & nchar(df$password)),] + + # format url components and build permuted urls + df$auth <- with(df, paste0( + username, + ifelse(nzchar(password), paste0(":", password), ""), + ifelse(nzchar(username), "@", "") + )) + df$ref_str <- with(df, ifelse(nzchar(ref), paste0("@", ref), "")) + df$full_url <- with(df, paste0(prot, auth, url, ref_str)) + + for (i in seq_len(nrow(df))) { + meta <- parse_git_url(df[i,"full_url"]) + expect_equal(meta$prot, df$prot[i]) + expect_equal(meta$auth, df$auth[i]) + expect_equal(meta$username, df$username[i]) + expect_equal(meta$password, df$password[i]) + expect_equal(meta$url, df$url[i]) + expect_equal(meta$ref, df$ref[i]) + } + + expect_true(!any(grepl(password, git_anon_url(df$full_url)))) + expect_true(!any(grepl(paste0(username, "|", password), git_anon_url(df$full_url)))) expect_equal(git_anon_url(url), url) expect_equal(git_anon_url(i <- paste0(prot, url)), i) @@ -192,16 +122,9 @@ test_that("git_anon_url removes username and password", { expect_equal(git_anon_url(paste0(username, ":", password, "@", url)), url) expect_equal(git_anon_url(paste0(username, ":", password, "@", url, "@", ref)), url) expect_equal(git_anon_url(paste0(prot, username, ":", password, "@", url, "@", ref)), paste0(prot, url)) -}) - -test_that("git_censored_url replaces password with asterisks", { - prot <- "http://" - username <- "janedoe" - password <- "12345" - asterisks <- strrep("*", 8L) - url <- "www.gitzone.com/namespace/repo.git" - ref <- "HEAD" + expect_true(!any(grepl(password, git_censored_url(df$full_url)))) + expect_equal(git_censored_url(df$full_url), gsub(password, asterisks, paste0(df$prot, df$auth, df$url))) expect_equal(git_censored_url(url), url) expect_equal(git_censored_url(i <- paste0(prot, url)), i) @@ -223,3 +146,27 @@ test_that("git_censored_url replaces password with asterisks", { git_censored_url(paste0(prot, username, ":", password, "@", url, "@", ref)), paste0(prot, username, ":", asterisks, "@", url)) }) + + +test_that("parse_git_url handles ssh-style repo urls", { + username <- "git" + url <- "gitzone.com:namespace/repo.git" + git_url <- paste0(username, "@", url) + ref <- "HEAD" + + meta <- parse_git_url(git_url) + expect_equal(meta$prot, "") + expect_equal(meta$auth, "git@") + expect_equal(meta$username, "git") + expect_equal(meta$password, "") + expect_equal(meta$url, url) + expect_equal(meta$ref, "") + + meta <- parse_git_url(paste0(git_url, "@", ref)) + expect_equal(meta$prot, "") + expect_equal(meta$auth, paste0(username, "@")) + expect_equal(meta$username, username) + expect_equal(meta$password, "") + expect_equal(meta$url, url) + expect_equal(meta$ref, ref) +}) diff --git a/tests/testthat/test-install-gitlab.R b/tests/testthat/test-install-gitlab.R index 78a6fcca..054344b4 100644 --- a/tests/testthat/test-install-gitlab.R +++ b/tests/testthat/test-install-gitlab.R @@ -1,9 +1,9 @@ context("Install from GitLab") test_that("install_gitlab", { - skip_on_cran() skip_if_offline() + withr::local_envvar(c(GITLAB_PAT="")) Sys.unsetenv("R_TESTS") @@ -31,9 +31,9 @@ test_that("install_gitlab", { }) test_that("install_gitlab with subgroups and special characters", { - skip_on_cran() skip_if_offline() + withr::local_envvar(c(GITLAB_PAT="")) Sys.unsetenv("R_TESTS") @@ -67,9 +67,9 @@ test_that("install_gitlab with subgroups and special characters", { }) test_that("error if not username, warning if given as argument", { - skip_on_cran() skip_if_offline() + withr::local_envvar(c(GITLAB_PAT="")) Sys.unsetenv("R_TESTS") @@ -85,6 +85,7 @@ test_that("error if not username, warning if given as argument", { test_that("remote_download.gitlab_remote messages", { skip_on_cran() skip_if_offline() + withr::local_envvar(c(GITLAB_PAT="")) mockery::stub(remote_download.gitlab_remote, "download", TRUE) expect_message( @@ -101,9 +102,9 @@ test_that("remote_download.gitlab_remote messages", { }) test_that("remote_sha.gitlab_remote", { - skip_on_cran() skip_if_offline() + withr::local_envvar(c(GITLAB_PAT="")) expect_equal( remote_sha( @@ -132,9 +133,9 @@ test_that("remote_sha.gitlab_remote", { }) test_that("gitlab_project_id", { - skip_on_cran() skip_if_offline() + withr::local_envvar(c(GITLAB_PAT="")) expect_equal( gitlab_project_id( @@ -148,59 +149,67 @@ test_that("gitlab_project_id", { }) -test_that("gitlab_remote reverts to git2r_remote when git_fallback", { +test_that("gitlab_remote reverts to git2r_remote when git_fallback with git2r", { skip_if_not_installed("git2r") withr::local_envvar(c(GITLAB_PAT="badcafe")) - - msgs <- capture.output(type = "message", { - r <- gitlab_remote("fakenamespace/namespace/repo", git_fallback = TRUE) - }) - expect_true(any(grepl("auth_token does not", msgs))) - expect_true(any(grepl("Attempting git_remote using credentials", msgs))) + mockery::stub(gitlab_remote, "pkg_installed", function(...) TRUE, 2L) # assume git2r available + + expect_message({ + r <- gitlab_remote( + "fakenamespace/namespace/repo", + git_fallback = TRUE + ) + }, "auth_token does not") expect_s3_class(r, "git2r_remote") expect_equal(r$credentials$username, "gitlab-ci-token") expect_equal(r$credentials$password, "badcafe") withr::local_envvar(c(GITLAB_PAT="")) - msgs <- capture.output(type = "message", { - r <- gitlab_remote("fakenamespace/namespace/repo", git_fallback = TRUE) - }) - expect_true(any(grepl("Unable to establish api access", msgs))) + expect_message({ + r <- gitlab_remote( + "fakenamespace/namespace/repo", + git_fallback = TRUE + ) + }, "Unable to establish api access") expect_s3_class(r, "git2r_remote") expect_equal(r$credentials, NULL) r <- gitlab_remote("fakenamespace/namespace/repo", git_fallback = FALSE) expect_s3_class(r, "gitlab_remote") - }) -test_that("gitlab_remote reverts to xgit_remote when git_fallback", { +test_that("gitlab_remote reverts to xgit_remote when git_fallback and no git2r", { withr::local_envvar(c(GITLAB_PAT="")) - mockery::stub(gitlab_remote, "pkg_installed", FALSE, 3L) - - msgs <- capture.output(type = "message", { - r <- gitlab_remote("fakenamespace/namespace/repo", git_fallback = TRUE) - }) + mockery::stub(gitlab_to_git_remote, "pkg_installed", function(...) FALSE, 2L) # assume git2r unavailable - expect_true(any(grepl("Unable to establish api access", msgs))) + expect_message({ + r <- gitlab_remote( + "fakenamespace/namespace/repo", + git_fallback = TRUE + ) + }, "Unable to establish api access") expect_s3_class(r, "xgit_remote") expect_equal(r$url, "https://gitlab.com/fakenamespace/namespace/repo.git") withr::local_envvar(c(GITLAB_PAT="badcafe")) - msgs <- capture.output(type = "message", { - r <- gitlab_remote("fakenamespace/namespace/repo", git_fallback = TRUE) - }) - - expect_true(any(grepl("Attempting git_remote", msgs))) - expect_true(any(grepl("url.*", msgs))) + expect_message({ + r <- gitlab_remote( + "fakenamespace/namespace/repo", + git_fallback = TRUE + ) + }, "auth_token does not") expect_s3_class(r, "xgit_remote") expect_equal(r$url, "https://gitlab-ci-token:badcafe@gitlab.com/fakenamespace/namespace/repo.git") - msgs <- capture.output(type = "message", { - r <- gitlab_remote("fakenamespace/namespace/repo", auth_token = "goodcafe", host = "github.com", git_fallback = TRUE) - }) - + expect_message({ + r <- gitlab_remote( + "fakenamespace/namespace/repo", + auth_token = "goodcafe", + host = "github.com", + git_fallback = TRUE + ) + }, "Attempting git_remote.*@") expect_s3_class(r, "xgit_remote") expect_equal(r$url, "https://gitlab-ci-token:goodcafe@github.com/fakenamespace/namespace/repo.git") }) From d7d8709cd76e0f68abf7458339666f1988b9e446 Mon Sep 17 00:00:00 2001 From: dgkf <18220321+dgkf@users.noreply.github.com> Date: Fri, 9 Jul 2021 16:58:42 -0700 Subject: [PATCH 22/26] updating NEWS --- NEWS.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/NEWS.md b/NEWS.md index f3b47362..527f664e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,6 +1,9 @@ # 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) + * 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). # remotes 2.4.0 From 37e177b049fe045ec6aa3f5c538b2e159e8629dc Mon Sep 17 00:00:00 2001 From: dgkf <18220321+dgkf@users.noreply.github.com> Date: Fri, 9 Jul 2021 18:31:40 -0700 Subject: [PATCH 23/26] updating DESCRIPTION; tests --- DESCRIPTION | 2 +- tests/testthat/test-install-gitlab.R | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 71264216..b2968141 100644 --- a/DESCRIPTION +++ b/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")), diff --git a/tests/testthat/test-install-gitlab.R b/tests/testthat/test-install-gitlab.R index 054344b4..558b4117 100644 --- a/tests/testthat/test-install-gitlab.R +++ b/tests/testthat/test-install-gitlab.R @@ -180,7 +180,7 @@ test_that("gitlab_remote reverts to git2r_remote when git_fallback with git2r", test_that("gitlab_remote reverts to xgit_remote when git_fallback and no git2r", { withr::local_envvar(c(GITLAB_PAT="")) - mockery::stub(gitlab_to_git_remote, "pkg_installed", function(...) FALSE, 2L) # assume git2r unavailable + mockery::stub(gitlab_remote, "pkg_installed", function(...) FALSE, 2L) # assume git2r unavailable expect_message({ r <- gitlab_remote( From a6d1ae00139cc74d25ec7e169dcb23f3a0c53e60 Mon Sep 17 00:00:00 2001 From: dgkf <18220321+dgkf@users.noreply.github.com> Date: Fri, 9 Jul 2021 18:33:15 -0700 Subject: [PATCH 24/26] rerunning make --- inst/install-github.R | 200 +++++++++++++++++++++++++++++++++++++----- install-github.R | 200 +++++++++++++++++++++++++++++++++++++----- 2 files changed, 354 insertions(+), 46 deletions(-) diff --git a/inst/install-github.R b/inst/install-github.R index 9c49d8ab..5c659126 100644 --- a/inst/install-github.R +++ b/inst/install-github.R @@ -1627,10 +1627,12 @@ function(...) { } } - 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)) @@ -2667,12 +2669,55 @@ function(...) { stop("`credentials` can only be used with `git = \"git2r\"`", call. = FALSE) } - meta <- re_match(url, "(?(?:git@)?[^@]*)(?:@(?.*))?") + 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( + "(?.*://)?(?(?[^:@/]*)(?::(?[^@/]*)?)?@)?", + "(?[^@]*)", + "(?:@(?.*))?" + )) + } + + #' 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", @@ -2695,7 +2740,7 @@ function(...) { #' @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() @@ -2720,7 +2765,7 @@ function(...) { list( RemoteType = "git2r", - RemoteUrl = x$url, + RemoteUrl = git_anon_url(x$url), RemoteSubdir = x$subdir, RemoteRef = x$ref, RemoteSha = sha @@ -2808,14 +2853,18 @@ function(...) { #' @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) @@ -2833,7 +2882,7 @@ function(...) { list( RemoteType = "xgit", - RemoteUrl = x$url, + RemoteUrl = git_anon_url(x$url), RemoteSubdir = x$subdir, RemoteRef = x$ref, RemoteSha = sha, @@ -3169,7 +3218,14 @@ function(...) { #' 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 @@ -3188,9 +3244,19 @@ function(...) { 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, @@ -3207,20 +3273,103 @@ function(...) { } 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 "" + # - 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="))) + + 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:@%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, + ... ) } @@ -5640,6 +5789,11 @@ function(...) { Encoding(res) <- "UTF-8" res } + + wrap <- function(x, ..., simplify = FALSE) { + lines <- unlist(strwrap(unlist(strsplit(x, "\n")), ..., simplify = simplify)) + paste(lines, collapse = "\n") + } ## Standalone mode, make sure that we restore the env var on exit diff --git a/install-github.R b/install-github.R index 9c49d8ab..5c659126 100644 --- a/install-github.R +++ b/install-github.R @@ -1627,10 +1627,12 @@ function(...) { } } - 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)) @@ -2667,12 +2669,55 @@ function(...) { stop("`credentials` can only be used with `git = \"git2r\"`", call. = FALSE) } - meta <- re_match(url, "(?(?:git@)?[^@]*)(?:@(?.*))?") + 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( + "(?.*://)?(?(?[^:@/]*)(?::(?[^@/]*)?)?@)?", + "(?[^@]*)", + "(?:@(?.*))?" + )) + } + + #' 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", @@ -2695,7 +2740,7 @@ function(...) { #' @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() @@ -2720,7 +2765,7 @@ function(...) { list( RemoteType = "git2r", - RemoteUrl = x$url, + RemoteUrl = git_anon_url(x$url), RemoteSubdir = x$subdir, RemoteRef = x$ref, RemoteSha = sha @@ -2808,14 +2853,18 @@ function(...) { #' @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) @@ -2833,7 +2882,7 @@ function(...) { list( RemoteType = "xgit", - RemoteUrl = x$url, + RemoteUrl = git_anon_url(x$url), RemoteSubdir = x$subdir, RemoteRef = x$ref, RemoteSha = sha, @@ -3169,7 +3218,14 @@ function(...) { #' 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 @@ -3188,9 +3244,19 @@ function(...) { 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, @@ -3207,20 +3273,103 @@ function(...) { } 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 "" + # - 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="))) + + 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:@%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, + ... ) } @@ -5640,6 +5789,11 @@ function(...) { Encoding(res) <- "UTF-8" res } + + wrap <- function(x, ..., simplify = FALSE) { + lines <- unlist(strwrap(unlist(strsplit(x, "\n")), ..., simplify = simplify)) + paste(lines, collapse = "\n") + } ## Standalone mode, make sure that we restore the env var on exit From 68980b2170e52024bd846630a49bf4e77e318a65 Mon Sep 17 00:00:00 2001 From: dgkf <18220321+dgkf@users.noreply.github.com> Date: Fri, 9 Jul 2021 18:48:30 -0700 Subject: [PATCH 25/26] using atomic return instead of function for mocks --- tests/testthat/test-install-gitlab.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-install-gitlab.R b/tests/testthat/test-install-gitlab.R index 558b4117..f7eb547e 100644 --- a/tests/testthat/test-install-gitlab.R +++ b/tests/testthat/test-install-gitlab.R @@ -152,7 +152,7 @@ test_that("gitlab_project_id", { test_that("gitlab_remote reverts to git2r_remote when git_fallback with git2r", { skip_if_not_installed("git2r") withr::local_envvar(c(GITLAB_PAT="badcafe")) - mockery::stub(gitlab_remote, "pkg_installed", function(...) TRUE, 2L) # assume git2r available + mockery::stub(gitlab_remote, "pkg_installed", TRUE, 2L) # assume git2r available expect_message({ r <- gitlab_remote( @@ -180,7 +180,7 @@ test_that("gitlab_remote reverts to git2r_remote when git_fallback with git2r", test_that("gitlab_remote reverts to xgit_remote when git_fallback and no git2r", { withr::local_envvar(c(GITLAB_PAT="")) - mockery::stub(gitlab_remote, "pkg_installed", function(...) FALSE, 2L) # assume git2r unavailable + mockery::stub(gitlab_remote, "pkg_installed", FALSE, 2L) # assume git2r unavailable expect_message({ r <- gitlab_remote( From 1917f02ac9430318419e0d29176559eeb12373c7 Mon Sep 17 00:00:00 2001 From: dgkf <18220321+dgkf@users.noreply.github.com> Date: Fri, 9 Jul 2021 19:53:11 -0700 Subject: [PATCH 26/26] fixing stubbing at depth into fn; yo dawg i heard you like mocks --- tests/testthat/test-install-gitlab.R | 33 +++++++++++++++++++++++++--- 1 file changed, 30 insertions(+), 3 deletions(-) diff --git a/tests/testthat/test-install-gitlab.R b/tests/testthat/test-install-gitlab.R index f7eb547e..3d85d40f 100644 --- a/tests/testthat/test-install-gitlab.R +++ b/tests/testthat/test-install-gitlab.R @@ -150,9 +150,24 @@ test_that("gitlab_project_id", { }) test_that("gitlab_remote reverts to git2r_remote when git_fallback with git2r", { - skip_if_not_installed("git2r") + skip_if_not_installed("git2r") # needed for credential creation withr::local_envvar(c(GITLAB_PAT="badcafe")) - mockery::stub(gitlab_remote, "pkg_installed", TRUE, 2L) # assume git2r available + + # assume git2r available + stubbed_gitlab_to_git_remote <- gitlab_to_git_remote + stubbed_git_remote <- git_remote + mockery::stub(stubbed_gitlab_to_git_remote, "pkg_installed", TRUE) + mockery::stub(stubbed_git_remote, "pkg_installed", TRUE) + mockery::stub(stubbed_gitlab_to_git_remote, "git_remote", stubbed_git_remote) + mockery::stub(gitlab_remote, "gitlab_to_git_remote", stubbed_gitlab_to_git_remote) + + expect_s3_class( + expect_message( + gitlab_remote("fakenamespace/namespace/repo", git_fallback = FALSE), + "GITLAB_PAT" + ), + "gitlab_remote" + ) expect_message({ r <- gitlab_remote( @@ -180,7 +195,19 @@ test_that("gitlab_remote reverts to git2r_remote when git_fallback with git2r", test_that("gitlab_remote reverts to xgit_remote when git_fallback and no git2r", { withr::local_envvar(c(GITLAB_PAT="")) - mockery::stub(gitlab_remote, "pkg_installed", FALSE, 2L) # assume git2r unavailable + + # assume git2r unavailable + stubbed_gitlab_to_git_remote <- gitlab_to_git_remote + stubbed_git_remote <- git_remote + mockery::stub(stubbed_gitlab_to_git_remote, "pkg_installed", FALSE) + mockery::stub(stubbed_git_remote, "pkg_installed", FALSE) + mockery::stub(stubbed_gitlab_to_git_remote, "git_remote", stubbed_git_remote) + mockery::stub(gitlab_remote, "gitlab_to_git_remote", stubbed_gitlab_to_git_remote) + + expect_s3_class( + expect_silent(gitlab_remote("fakenamespace/namespace/repo", git_fallback = FALSE)), + "gitlab_remote" + ) expect_message({ r <- gitlab_remote(