Nothing
gitcreds_get <- NULL
gitcreds_set <- NULL
gitcreds_delete <- NULL
gitcreds_list_helpers <- NULL
gitcreds_cache_envvar <- NULL
gitcreds_fill <- NULL
gitcreds_approve <- NULL
gitcreds_reject <- NULL
gitcreds_parse_output <- NULL
gitcreds <- local({
# ------------------------------------------------------------------------
# Public API
# ------------------------------------------------------------------------
gitcreds_get <<- function(url = "https://github.com", use_cache = TRUE,
set_cache = TRUE) {
stopifnot(
is_string(url), has_no_newline(url),
is_flag(use_cache),
is_flag(set_cache)
)
cache_ev <- gitcreds_cache_envvar(url)
if (use_cache && !is.null(ans <- gitcreds_get_cache(cache_ev))) {
return(ans)
}
check_for_git()
out <- gitcreds_fill(list(url = url), dummy = TRUE)
creds <- gitcreds_parse_output(out, url)
if (set_cache) {
gitcreds_set_cache(cache_ev, creds)
}
creds
}
gitcreds_set <<- function(url = "https://github.com") {
if (!is_interactive()) {
throw(new_error(
"gitcreds_not_interactive_error",
message = "`gitcreds_set()` only works in interactive sessions"
))
}
stopifnot(is_string(url), has_no_newline(url))
check_for_git()
current <- tryCatch(
gitcreds_get(url, use_cache = FALSE, set_cache = FALSE),
gitcreds_no_credentials = function(e) NULL
)
if (!is.null(current)) {
gitcreds_set_replace(url, current)
} else {
gitcreds_set_new(url)
}
msg("-> Removing credentials from cache...")
gitcreds_delete_cache(gitcreds_cache_envvar(url))
msg("-> Done.")
invisible()
}
#' Replace credentials with new ones
#'
#' It only works interactively, because of `menu()` in `ack()` and
#' `readline()`.
#'
#' We need to set a username, it is compulsory for git credential.
#' 1. If there was one in the url, then we use that.
#' 2. Otherwise if git has a username configured for this URL, we use that.
#' 3. Otherwise we use the username in the credentials we are replacing.
#'
#' @param url URL.
#' @param current Must not be `NULL`, and it must contain a
#' `gitcreds` object. (Well, a named list, really.)
#' @noRd
#' @return Nothing.
gitcreds_set_replace <- function(url, current) {
# Potentially take username from the credential we are replacing
current_username <- current$username
# Keep warning until there is a credential to replace.
# In case there are multiple credentials for the same URL.
while (!is.null(current)) {
if (!ack(url, current, "Replace")) {
throw(new_error("gitcreds_abort_replace_error"))
}
msg("\n-> Removing current credentials...")
gitcreds_reject(current)
current <- tryCatch(
gitcreds_get(url, use_cache = FALSE, set_cache = FALSE),
gitcreds_no_credentials = function(e) NULL
)
if (!is.null(current)) msg("\n!! Found more matching credentials!")
}
msg("")
pat <- readline("? Enter new password or token: ")
username <- get_url_username(url) %||%
gitcreds_username(url) %||%
current_username
msg("-> Adding new credentials...")
gitcreds_approve(list(url = url, username = username, password = pat))
invisible()
}
#' Set new credentials
#'
#' This should not replace or remove any old credentials, but of course
#' we cannot be sure, because credential helpers pretty much do what they
#' want.
#'
#' We need to set a username, it is compulsory for git credential.
#' 1. If there was one in the url, then we use that.
#' 2. Otherwise if git has a username configured for this URL, we use that.
#' 3. Otherwise we use a default username.
#'
#' @param url URL.
#' @noRd
#' @return Nothing.
gitcreds_set_new <- function(url) {
msg("\n")
pat <- readline("? Enter password or token: ")
username <- get_url_username(url) %||%
gitcreds_username(url) %||%
default_username()
msg("-> Adding new credentials...")
gitcreds_approve(list(url = url, username = username, password = pat))
invisible()
}
gitcreds_delete <<- function(url = "https://github.com") {
if (!is_interactive()) {
throw(new_error(
"gitcreds_not_interactive_error",
message = "`gitcreds_delete()` only works in interactive sessions"
))
}
stopifnot(is_string(url))
check_for_git()
current <- tryCatch(
gitcreds_get(url, use_cache = FALSE, set_cache = FALSE),
gitcreds_no_credentials = function(e) NULL
)
if (is.null(current)) {
return(invisible(FALSE))
}
if (!ack(url, current, "Delete")) {
throw(new_error("gitcreds_abort_delete_error"))
}
msg("-> Removing current credentials...")
gitcreds_reject(current)
msg("-> Removing credentials from cache...")
gitcreds_delete_cache(gitcreds_cache_envvar(url))
msg("-> Done.")
invisible(TRUE)
}
gitcreds_list_helpers <<- function() {
check_for_git()
out <- git_run(c("config", "--get-all", "credential.helper"))
clear <- rev(which(out == ""))
if (length(clear)) out <- out[-(1:clear[1])]
out
}
gitcreds_cache_envvar <<- function(url) {
pcs <- parse_url(url)
bad <- is.na(pcs$protocol) | is.na(pcs$host)
if (any(bad)) {
stop("Invalid URL(s): ", paste(url[bad], collapse = ", "))
}
proto <- sub("^https?_$", "", paste0(pcs$protocol, "_"))
user <- ifelse(pcs$username != "", paste0(pcs$username, "_AT_"), "")
host0 <- sub("^api[.]github[.]com$", "github.com", pcs$host)
host1 <- gsub("[.:]+", "_", host0)
host <- gsub("[^a-zA-Z0-9_-]", "x", host1)
slug1 <- paste0(proto, user, host)
# fix the user name ambiguity, not that it happens often...
slug2 <- ifelse(grepl("^AT_", slug1), paste0("AT_", slug1), slug1)
# env vars cannot start with a number
slug3 <- ifelse(grepl("^[0-9]", slug2), paste0("AT_", slug2), slug2)
paste0("GITHUB_PAT_", toupper(slug3))
}
gitcreds_get_cache <- function(ev) {
val <- Sys.getenv(ev, NA_character_)
if (is.na(val) && ev == "GITHUB_PAT_GITHUB_COM") {
val <- Sys.getenv("GITHUB_PAT", NA_character_)
}
if (is.na(val) && ev == "GITHUB_PAT_GITHUB_COM") {
val <- Sys.getenv("GITHUB_TOKEN", NA_character_)
}
if (is.na(val) || val == "") {
return(NULL)
}
if (val == "FAIL" || grepl("^FAIL:", val)) {
class <- strsplit(val, ":", fixed = TRUE)[[1]][2]
if (is.na(class)) class <- "gitcreds_no_credentials"
throw(new_error(class))
}
unesc <- function(x) {
gsub("\\\\(.)", "\\1", x)
}
# split on `:` that is not preceded by a `\`
spval <- strsplit(val, "(?<!\\\\):", perl = TRUE)[[1]]
spval0 <- unesc(spval)
# Single field, then the token
if (length(spval) == 1) {
return(new_gitcreds(
protocol = NA_character_,
host = NA_character_,
username = NA_character_,
password = unesc(val)
))
}
# Two fields? Then it is username:password
if (length(spval) == 2) {
return(new_gitcreds(
protocol = NA_character_,
host = NA_character_,
username = spval0[1],
password = spval0[2]
))
}
# Otherwise a full record
if (length(spval) %% 2 == 1) {
warning("Invalid gitcreds credentials in env var `", ev, "`. ",
"Maybe an unescaped ':' character?")
return(NULL)
}
creds <- structure(
spval0[seq(2, length(spval0), by = 2)],
names = spval[seq(1, length(spval0), by = 2)]
)
do.call("new_gitcreds", as.list(creds))
}
gitcreds_set_cache <- function(ev, creds) {
esc <- function(x) gsub(":", "\\:", x, fixed = TRUE)
keys <- esc(names(creds))
vals <- esc(unlist(creds, use.names = FALSE))
value <- paste0(keys, ":", vals, collapse = ":")
do.call("set_env", list(structure(value, names = ev)))
invisible(NULL)
}
gitcreds_delete_cache <- function(ev) {
Sys.unsetenv(ev)
}
# ------------------------------------------------------------------------
# Raw git credential API
# ------------------------------------------------------------------------
gitcreds_fill <<- function(input, args = character(), dummy = TRUE) {
if (dummy) {
helper <- paste0(
"credential.helper=\"! echo protocol=dummy;",
"echo host=dummy;",
"echo username=dummy;",
"echo password=dummy\""
)
args <- c(args, "-c", helper)
}
gitcreds_run("fill", input, args)
}
gitcreds_approve <<- function(creds, args = character()) {
gitcreds_run("approve", creds, args)
}
gitcreds_reject <<- function(creds, args = character()) {
gitcreds_run("reject", creds, args)
}
gitcreds_parse_output <<- function(txt, url) {
if (is.null(txt) || txt[1] == "protocol=dummy") {
throw(new_error("gitcreds_no_credentials", url = url))
}
nms <- sub("=.*$", "", txt)
vls <- sub("^[^=]+=", "", txt)
structure(as.list(vls), names = nms, class = "gitcreds")
}
#' Run a `git credential` command
#'
#' @details
#' We set the [gitcreds_env()] environment variables, to avoid dialog boxes
#' from some credential helpers and also validation that potentiall needs
#' an internet connection.
#'
#' @param command Command name, e.g. `"fill"`.
#' @param input Named list of input, see
#' https://git-scm.com/docs/git-credential#IOFMT
#' @param args Extra command line arguments, added after `git` and
#' _before_ `command`, to allow `git -c ... fill`.
#' @return Standard output, line by line.
#'
#' @noRd
#' @seealso [git_run()].
gitcreds_run <- function(command, input, args = character()) {
env <- gitcreds_env()
oenv <- set_env(env)
on.exit(set_env(oenv), add = TRUE)
stdin <- create_gitcreds_input(input)
git_run(c(args, "credential", command), input = stdin)
}
# ------------------------------------------------------------------------
# Helpers specific to git
# ------------------------------------------------------------------------
#' Run a git command
#'
#' @details
#' Currently we don't set the credential specific environment variables
#' here, and credential helpers invoked by `git` behave the same way as
#' they would from the command line.
#'
#' ## Errors
#'
#' On error `git_run()` returns an error with class `git_error` and
#' also `gitcreds_error`. The error object includes
#' * `args` the command line arguments,
#' * `status`: the exit status of the command,
#' * `stdout`: the standard output of the command, line by line.
#' * `stderr`: the standard error of the command, line by line.
#'
#' @param args Command line arguments.
#' @param input The standard input (the `input` argument of [system2()].
#' @noRd
#' @return Standard output, line by line.
git_run <- function(args, input = NULL) {
stderr_file <- tempfile("gitcreds-stderr-")
on.exit(unlink(stderr_file, recursive = TRUE), add = TRUE)
if (!is.null(input)) {
stdin_file <- tempfile("gitcreds-stdin-")
on.exit(unlink(stdin_file, recursive = TRUE), add = TRUE)
writeBin(charToRaw(input), stdin_file)
stdin <- stdin_file
} else {
stdin <- ""
}
out <- tryCatch(
suppressWarnings(system2(
"git", args, stdin = stdin, stdout = TRUE, stderr = stderr_file
)),
error = function(e) NULL
)
if (!is.null(attr(out, "status")) && attr(out, "status") != 0) {
throw(new_git_error(
"git_error",
args = args,
stdout = out,
status = attr(out, "status"),
stderr = read_file(stderr_file)
))
}
out
}
#' Request confirmation from the user, to replace or delete credentials
#'
#' This function only works in interactive sessions.
#'
#' @param url URL to delete or set new credentials for.
#' @param current The current credentials.
#' @return `FALSE` is the user changed their mind, to keep the current
#' credentials. `TRUE` for replacing/deleting them.
#'
#' @noRd
#' @seealso [gitcreds_set()].
ack <- function(url, current, what = "Replace") {
msg("\n-> Your current credentials for ", squote(url), ":\n")
msg(paste0(format(current, header = FALSE), collapse = "\n"), "\n")
choices <- c(
"Abort update with error, and keep the existing credentials",
paste(what, "these credentials"),
if (has_password(current)) "See the password / token"
)
repeat {
ch <- utils::menu(title = "-> What would you like to do?", choices)
if (ch == 1) return(FALSE)
if (ch == 2) return(TRUE)
msg("\nCurrent password: ", current$password, "\n\n")
}
}
#' Whether a `gitcreds` credential has a non-empty `password`
#'
#' This is usually `TRUE`.
#'
#' @param creds `gitcreds`
#' @noRd
#' @return `TRUE` is there is a `password`
has_password <- function(creds) {
is_string(creds$password) && creds$password != ""
}
#' Create a string that can be passed as standard input to `git credential`
#' commands
#'
#' @param args Usually a `gitcreds` object, but can be a named list in
#' general. This is a format: https://git-scm.com/docs/git-credential#IOFMT
#' @noRd
#' @return String.
create_gitcreds_input <- function(args) {
paste0(
paste0(names(args), "=", args, collapse = "\n"),
"\n\n"
)
}
#' Environment to set for all `git credential` commands.
#' @noRd
#' @return Named character vector.
gitcreds_env <- function() {
# Avoid interactivity and validation with some common credential helpers
c(
GCM_INTERACTIVE = "Never",
GCM_MODAL_PROMPT = "false",
GCM_VALIDATE = "false"
)
}
#' Check if `git` is installed and can run
#'
#' If not installed, a `gitcreds_nogit_error` is thrown.
#'
#' @noRd
#' @return Nothing
check_for_git <- function() {
# This is simpler than Sys.which(), and also less fragile
has_git <- tryCatch({
suppressWarnings(system2(
"git", "--version",
stdout = TRUE, stderr = null_file()
))
TRUE
}, error = function(e) FALSE)
if (!has_git) throw(new_error("gitcreds_nogit_error"))
}
#' Query the `username` to use for `git config credential`
#'
#' @details
#' The current working directory matters for this command, as you can
#' configure `username` in a local `.git/config` file (via
#' `git config --local`).
#'
#' @param url URL to query the username for, or `NULL`. If not `NULL`,
#' then we first try to query an URL-specific username. See
#' https://git-scm.com/docs/gitcredentials for more about URL-specific
#' credential config
#' @noRd
#' @return A string with the username, or `NULL` if no default was found.
gitcreds_username <- function(url = NULL) {
gitcreds_username_for_url(url) %||% gitcreds_username_generic()
}
gitcreds_username_for_url <- function(url) {
if (is.null(url)) return(NULL)
tryCatch(
git_run(c(
"config", "--get-urlmatch", "credential.username", shQuote(url)
)),
git_error = function(err) {
if (err$status == 1) NULL else throw(err)
}
)
}
gitcreds_username_generic <- function() {
tryCatch(
git_run(c("config", "credential.username")),
git_error = function(err) {
if (err$status == 1) NULL else throw(err)
}
)
}
#' User name to use when creating a credential, if there is nothing better
#'
#' These user names are typical for some git tools, e.g.
#' [Git Credential Manager for Windows](http://microsoft.github.io/Git-Credential-Manager-for-Windows/)
#' (`manager`) and
#' [Git Credential Manager Core](https://github.com/Microsoft/Git-Credential-Manager-Core)
#' (`manager-core`).
#'
#' @noRd
#' @return Character string
default_username <- function() {
"PersonalAccessToken"
}
new_gitcreds <- function(...) {
structure(list(...), class = "gitcreds")
}
# ------------------------------------------------------------------------
# Errors
# ------------------------------------------------------------------------
gitcred_errors <- function() {
c(
git_error = "System git failed",
gitcreds_nogit_error = "Could not find system git",
gitcreds_not_interactive_error = "gitcreds needs an interactive session",
gitcreds_abort_replace_error = "User aborted updating credentials",
gitcreds_abort_delete_error = "User aborted deleting credentials",
gitcreds_no_credentials = "Could not find any credentials",
gitcreds_no_helper = "No credential helper is set",
gitcreds_multiple_helpers =
"Multiple credential helpers, only using the first",
gitcreds_unknown_helper = "Unknown credential helper, cannot list credentials"
)
}
new_error <- function(class, ..., message = "", call. = TRUE, domain = NULL) {
if (message == "") message <- gitcred_errors()[[class]]
message <- .makeMessage(message, domain = domain)
cond <- list(message = message, ...)
if (call.) cond$call <- sys.call(-1)
class(cond) <- c(class, "gitcreds_error", "error", "condition")
cond
}
new_git_error <- function(class, ..., stderr) {
cond <- new_error(class, ..., stderr = stderr)
cond$message <- paste0(cond$message, ": ", stderr)
cond
}
new_warning <- function(class, ..., message = "", call. = TRUE, domain = NULL) {
if (message == "") message <- gitcred_errors()[[class]]
message <- .makeMessage(message, domain = domain)
cond <- list(message = message, ...)
if (call.) cond$call <- sys.call(-1)
class(cond) <- c(class, "gitcreds_warning", "warning", "condition")
cond
}
throw <- function(cond) {
cond
if ("error" %in% class(cond)) {
stop(cond)
} else if ("warning" %in% class(cond)) {
warning(cond)
} else if ("message" %in% class(cond)) {
message(cond)
} else {
signalCondition(cond)
}
}
# ------------------------------------------------------------------------
# Genetic helpers
# ------------------------------------------------------------------------
#' Set/remove env var and return the old values
#'
#' @param envs Named character vector or list of env vars to set. `NA`
#' values will un-set an env var.
#' @noRd
#' @return Character vector, the old values of the supplied environment
#' variables, `NA` for the ones that were not set.
set_env <- function(envs) {
current <- Sys.getenv(names(envs), NA_character_, names = TRUE)
na <- is.na(envs)
if (any(na)) {
Sys.unsetenv(names(envs)[na])
}
if (any(!na)) {
do.call("Sys.setenv", as.list(envs[!na]))
}
invisible(current)
}
#' Get the user name from a `protocol://username@host/path` URL.
#'
#' @param url URL
#' @noRd
#' @return String or `NULL` if `url` does not have a username.
get_url_username <- function(url) {
nm <- parse_url(url)$username
if (nm == "") NULL else nm
}
#' Parse URL
#'
#' It does not parse query parameters, as we don't deal with them here.
#' The port number is included in the host name, if present.
#'
#' @param url Character vector of one or more URLs.
#' @noRd
#' @return Data frame with string columns: `protocol`, `username`,
#' `password`, `host`, `path`.
parse_url <- function(url) {
re_url <- paste0(
"^(?<protocol>[a-zA-Z0-9]+)://",
"(?:(?<username>[^@/:]+)(?::(?<password>[^@/]+))?@)?",
"(?<host>[^/]+)",
"(?<path>.*)$" # don't worry about query params here...
)
mch <- re_match(url, re_url)
mch[, setdiff(colnames(mch), c(".match", ".text")), drop = FALSE]
}
is_string <- function(x) {
is.character(x) && length(x) == 1 && !is.na(x)
}
is_flag <- function(x) {
is.logical(x) && length(x) == 1 && !is.na(x)
}
has_no_newline <- function(url) {
! grepl("\n", url, fixed = TRUE)
}
# From the rematch2 package
re_match <- function(text, pattern, perl = TRUE, ...) {
stopifnot(is.character(pattern), length(pattern) == 1, !is.na(pattern))
text <- as.character(text)
match <- regexpr(pattern, text, perl = perl, ...)
start <- as.vector(match)
length <- attr(match, "match.length")
end <- start + length - 1L
matchstr <- substring(text, start, end)
matchstr[ start == -1 ] <- NA_character_
res <- data.frame(
stringsAsFactors = FALSE,
.text = text,
.match = matchstr
)
if (!is.null(attr(match, "capture.start"))) {
gstart <- attr(match, "capture.start")
glength <- attr(match, "capture.length")
gend <- gstart + glength - 1L
groupstr <- substring(text, gstart, gend)
groupstr[ gstart == -1 ] <- NA_character_
dim(groupstr) <- dim(gstart)
res <- cbind(groupstr, res, stringsAsFactors = FALSE)
}
names(res) <- c(attr(match, "capture.names"), ".text", ".match")
res
}
null_file <- function() {
if (get_os() == "windows") "nul:" else "/dev/null"
}
get_os <- function() {
if (.Platform$OS.type == "windows") {
"windows"
} else if (Sys.info()[["sysname"]] == "Darwin") {
"macos"
} else if (Sys.info()[["sysname"]] == "Linux") {
"linux"
} else {
"unknown"
}
}
`%||%` <- function(l, r) if (is.null(l)) r else l
#' Like [message()], but print to standard output in interactive
#' sessions
#'
#' To avoid red output in RStudio, RGui, and R.app.
#'
#' @inheritParams message
#' @noRd
#' @return Nothing
msg <- function(..., domain = NULL, appendLF = TRUE) {
cnd <- .makeMessage(..., domain = domain, appendLF = appendLF)
withRestarts(muffleMessage = function() NULL, {
signalCondition(simpleMessage(cnd))
output <- default_output()
cat(cnd, file = output, sep = "")
})
invisible()
}
#' Where to print messages to
#'
#' If the session is not interactive, then it potentially matters
#' whether we print to stdout or stderr, so we print to stderr.
#'
#' The same applies when there is a sink for stdout or stderr.
#'
#' @noRd
#' @return The connection to print to.
default_output <- function() {
if (is_interactive() && no_active_sink()) stdout() else stderr()
}
no_active_sink <- function() {
# See ?sink.number for the explanation
sink.number("output") == 0 && sink.number("message") == 2
}
#' Smarter `interactive()`
#'
#' @noRd
#' @return Logical scalar.
is_interactive <- function() {
opt <- getOption("rlib_interactive")
opt2 <- getOption("rlang_interactive")
if (isTRUE(opt)) {
TRUE
} else if (identical(opt, FALSE)) {
FALSE
} else if (isTRUE(opt2)) {
TRUE
} else if (identical(opt2, FALSE)) {
FALSE
} else if (tolower(getOption("knitr.in.progress", "false")) == "true") {
FALSE
} else if (identical(Sys.getenv("TESTTHAT"), "true")) {
FALSE
} else {
base::interactive()
}
}
#' Squote wrapper to avoid smart quotes
#'
#' @inheritParams sQuote
#' @inherit sQuote return
#' @noRd
#' @return Character vector.
squote <- function(x) {
old <- options(useFancyQuotes = FALSE)
on.exit(options(old), add = TRUE)
sQuote(x)
}
#' Read all of a file
#'
#' @param path File to read.
#' @param ... Passed to [readChar()].
#' @noRd
#' @return String.
read_file <- function(path, ...) {
readChar(path, nchars = file.info(path)$size, ...)
}
environment()
})
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.