### -----------------------------------------------------------------------
### API
parse_remote_github <- function(specs, config, ...) {
pds <- re_match(specs, github_rx())
if (any(unk <- is.na(pds$.match))) {
pds[unk] <- re_match(specs[unk], github_url_rx())
pds[unk, "subdir"] <- ""
}
pds$ref <- pds$.text
cn <- setdiff(colnames(pds), c(".match", ".text"))
pds <- pds[, cn]
pds$type <- "github"
pds$package <- ifelse(nzchar(pds$package), pds$package, pds$repo)
lapply(
seq_len(nrow(pds)),
function(i) as.list(pds[i,])
)
}
resolve_remote_github <- function(remote, direct, config, cache,
dependencies, ...) {
force(direct); force(dependencies)
## Get the DESCRIPTION data, and the SHA we need
type_github_get_data(remote)$
then(function(resp) {
data <- list(
desc = resp$description,
sha = resp$sha,
remote = remote,
direct = direct,
dependencies = dependencies[[2 - direct]])
type_github_make_resolution(data)
})
}
download_remote_github <- function(resolution, target, target_tree,
config, cache, which, on_progress) {
## A GitHub package needs to be built, from the downloaded repo
## If we are downloading a solution, then we skip building the vignettes,
## because these will be built later by pkginstall.
##
## We cache both the downloaded repo snapshot and the built package in
## the package cache. So this is how we go:
##
## 1. If there is a locally built bianry in the cache (including
## vignettes if they are requested), then we use that.
## 2. If there is a built package in the cache (including vignettes
## if they are needed), then we use that.
## 3. If there is a repo snapshot in the cache, we build an R package
## from it. (Add also add it to the cache.)
## 4. Otherwise we download the repo, add it to the cache, build the
## R package, and add that to the cache as well.
package <- resolution$package
sha <- resolution$extra[[1]][["remotesha"]] %||% NA_character_
need_vignettes <- which == "resolution"
nocache <- is_true_param(resolution$params[[1]], "nocache")
source <- is_true_param(resolution$params[[1]], "source")
# in case there is a leftover package/tree here
unlink(c(target, target_tree), recursive = TRUE)
## 1. Check for a binary package
if (!nocache && !source) {
ptfm <- current_r_platform()
hit <- cache$package$copy_to(
target, package = package, sha256 = sha, built = TRUE,
platform = ptfm, rversion = current_r_version(),
.list = c(if (need_vignettes) c(vignettes = TRUE)))
if (nrow(hit)) {
return(paste("Had", ptfm)) # TODO: untested currently
}
}
## 2. Check if we have a built package in the cache. We do not check the
## ref or the type, so the package could have been built from a local
## ref or from another repo. As long as the sha is the same, we are
## fine. If we don't require vignetted, then a package with or without
## vignettes is fine.
if (!nocache) {
hit <- cache$package$copy_to(
target, package = package, sha256 = sha, built = TRUE,
.list = c(if (need_vignettes) c(vignettes = TRUE)))
if (nrow(hit)) {
"!DEBUG found GH `resolution$ref`@`sha` in the cache"
return("Had")
}
}
## 3. Check if we have a repo snapshot in the cache.
rel_target <- resolution$target
if (!nocache) {
subdir <- resolution$remote[[1]]$subdir
hit <- cache$package$copy_to(
target_tree, package = package, sha256 = sha, built = FALSE)
if (nrow(hit)) {
"!DEBUG found GH zip for `resolution$ref`@`sha` in the cache"
return("Had")
}
}
## 4. Need to download the repo
"!DEBUG Need to download GH package `resolution$ref`@`sha`"
urls <- resolution$sources[[1]]
rel_zip <- paste0(rel_target, "-t")
type_github_download_repo(urls, target_tree, rel_zip, sha, package, cache,
on_progress, nocache)$
then(function() {
"!DEBUG Building package `resolution$package`"
return("Got")
})
}
type_github_download_repo <- function(urls, repo_zip, rel_zip, sha,
package, cache, on_progress, nocache) {
urls; repo_zip; sha; package; cache; on_progress; nocache
## TODO: progress
headers <- type_github_get_headers()
download_file(urls, repo_zip, on_progress = on_progress, headers = headers)$
then(function() {
if (!nocache) {
cache$package$add(
repo_zip, rel_zip, package = package, sha = sha, built = FALSE)
}
"Got"
})
}
## ----------------------------------------------------------------------
satisfy_remote_github <- function(resolution, candidate,
config, ...) {
## 1. package name must match
if (resolution$package != candidate$package) {
return(structure(FALSE, reason = "Package names differ"))
}
## 1. installed ref is good, if it has the same sha
if (candidate$type == "installed") {
want_reinst <- is_true_param(resolution$params[[1]], "reinstall")
if (want_reinst) {
return(structure(FALSE, reason = "Re-install requested"))
}
sha1 <- candidate$extra[[1]][["remotesha"]] %||% NA_character_
sha2 <- resolution$extra[[1]][["remotesha"]] %||% NA_character_
ok <- is_string(sha1) && is_string(sha2) && same_sha(sha1, sha2)
if (!ok) {
return(structure(FALSE, reason = "Installed package sha mismatch"))
} else {
return(TRUE)
}
}
## 2. local packages satisfy a GH remote
## See https://github.com/r-lib/pkgdepends/issues/229
if (candidate$type == "local") {
return (TRUE)
}
## 3. other refs are also good, as long as they have the same sha
sha1 <- (if (is.list(candidate$extra[[1]]))candidate$extra[[1]][["remotesha"]]) %||% NA_character_
sha2 <- resolution$extra[[1]][["remotesha"]] %||% NA_character_
ok <- is_string(sha1) && is_string(sha2) && same_sha(sha1, sha2)
if (!ok) {
return(structure(FALSE, reason = "Candidate package sha mismatch"))
} else {
return(TRUE)
}
}
installedok_remote_github <- function(installed, solution, config, ...) {
identical(installed$package, solution$package) &&
identical(installed$version, solution$version) &&
identical(installed[["remotesha"]], solution$metadata[[1]][["RemoteSha"]])
}
## ----------------------------------------------------------------------
## Internal functions
type_github_builtin_token <- function() {
pats <- c(
paste0("3687d8b", "b0556b7c3", "72ba1681d", "e5e689b", "3ec61279"),
paste0("8ffecf5", "13a136f3d", "23bfe46c4", "2d67b3c", "966baf7b")
)
once_per_session(cli::cli_alert_warning(c(
"Using bundled GitHub PAT. ",
"Please add your own PAT using {.code gitcreds::gitcreds_set()}."
)))
sample(pats, 1)
}
type_github_get_headers <- function() {
headers <- c(
"Accept" = "application/vnd.github.v3+json",
"Content-Type" = "application/json; charset=utf-8"
)
token <- NA_character_
if (Sys.getenv("CI", "") != "") {
token <- Sys.getenv("CI_GITHUB_TOKEN", NA_character_)
}
if (is.na(token)) token <- tryCatch(gitcreds_get()$password, error = function(e) NA_character_)
if (is.na(token)) token <- type_github_builtin_token()
headers <- c(headers, c("Authorization" = paste("token", token)))
headers <- c(headers, c("User-Agent" = "r-lib/pak"))
headers
}
type_github_get_data <- function(rem) {
dx <- if (!is.null(rem$pull) && rem$pull != "") {
type_github_get_data_pull(rem)
} else if (!is.null(rem$release) && rem$release != "") {
type_github_get_data_release(rem)
} else {
type_github_get_data_ref(rem)
}
dx$then(function(data) {
chain_error(
dsc <- desc::desc(text = data$desc),
new_github_baddesc_error(rem, call)
)
list(sha = data$sha, description = dsc)
})
}
type_github_get_data_ref <- function(rem) {
user <- rem$username
repo <- rem$repo
ref <- rem$commitish %|z|% "HEAD"
subdir <- rem$subdir %&z&% paste0(utils::URLencode(rem$subdir), "/")
query <- sprintf("{
repository(owner: \"%s\", name: \"%s\") {
description: object(expression: \"%s:%sDESCRIPTION\") {
... on Blob {
isBinary
text
}
}
sha: object(expression: \"%s\") {
oid
}
}
}",
user, repo, ref, subdir, ref)
github_query(query)$
then(function(resp) {
check_github_response_ref(resp$response, resp$obj, rem, call. = call)
})$
then(function(obj) {
list(
sha = obj[[c("data", "repository", "sha", "oid")]],
desc = obj[[c("data", "repository", "description", "text")]]
)
})
}
check_github_response_ref <- function(resp, obj, rem, call.) {
if (!is.null(obj$errors)) {
throw(new_github_query_error(rem, resp, obj, call.))
}
if (isTRUE(obj[[c("data", "repository", "description", "isBinary")]])) {
throw(new_github_baddesc_error(rem, call.))
}
if (is.null(obj[[c("data", "repository", "sha")]])) {
throw(new_github_noref_error(rem, call.))
}
if (is.null(obj[[c("data", "repository", "description", "text")]])) {
throw(new_github_no_package_error(rem, call.))
}
obj
}
type_github_get_data_pull <- function(rem) {
call <- sys.call(-1)
user <- rem$username
repo <- rem$repo
pull <- rem$pull
subdir <- rem$subdir %&z&% paste0(utils::URLencode(rem$subdir), "/")
query <- sprintf("{
repository(owner: \"%s\", name: \"%s\") {
pullRequest(number: %s) {
headRefOid
headRef {
target {
... on Commit {
file(path: \"%sDESCRIPTION\") {
object {
... on Blob {
isBinary
text
}
}
}
}
}
}
}
}
}",
user, repo, pull, subdir)
github_query(query)$
then(function(resp) {
check_github_response_pull(resp$response, resp$obj, rem, call. = call)
})$
then(function(obj) {
ref <- obj[[c("data", "repository", "pullRequest", "headRefOid")]]
txt <- obj[[c("data", "repository", "pullRequest", "headRef",
"target", "file", "object", "text")]]
list(sha = ref, desc = txt)
})
}
check_github_response_pull <- function(resp, obj, rem, call.) {
if (!is.null(obj$errors)) {
throw(new_github_query_error(rem, resp, obj, call.))
}
# No full coverage here, because unless something goes super wrong,
# these cases almost never happen.
if (!is.null(obj$errors)) {
throw(new_github_query_error(rem, resp, obj, call.)) # nocov
}
if (isTRUE(obj[[c("data", "repository", "pullRequest", "headRef",
"target", "file", "object", "isBinary")]])) {
throw(new_github_baddesc_error(rem, call.)) # nocov
}
if (is.null(obj[[c("data", "repository", "pullRequest", "headRef",
"target", "file", "object")]])) {
throw(new_github_no_package_error(rem, call.))
}
obj
}
type_github_get_data_release <- function(rem) {
call <- sys.call(-1)
user <- rem$username
repo <- rem$repo
ref <- NULL
subdir <- rem$subdir %&z&% paste0(utils::URLencode(rem$subdir), "/")
query <- sprintf("{
repository(owner: \"%s\", name:\"%s\") {
latestRelease {
tagName
tagCommit {
oid,
file(path: \"%sDESCRIPTION\") {
object {
... on Blob {
isBinary
text
}
}
}
}
}
}
}",
user, repo, subdir)
github_query(query)$
then(function(resp) {
check_github_response_release(resp$response, resp$obj, rem, call. = call)
})$
then(function(obj) {
ref <- obj[[c("data", "repository", "latestRelease", "tagCommit", "oid")]]
txt <- obj[[c("data", "repository", "latestRelease", "tagCommit", "file", "object", "text")]]
list(sha = ref, desc = txt)
})
}
check_github_response_release <- function(resp, obj, rem, call.) {
if (!is.null(obj$errors)) {
throw(new_github_query_error(rem, resp, obj, call.))
}
if (is.null(obj[[c("data", "repository", "latestRelease")]])) {
throw(new_github_no_release_error(rem, call.))
}
if (isTRUE(obj[[c("data", "repository", "latestRelease", "tagCommit", "file", "object", "isBinary")]])) {
throw(new_github_baddesc_error(rem, call.))
}
if (is.null(obj[[c("data", "repository", "latestRelease", "tagCommit", "file", "object")]])) {
throw(new_github_no_package_error(rem, call.))
}
obj
}
type_github_make_resolution <- function(data) {
deps <- resolve_ref_deps(
data$desc$get_deps(),
data$desc$get("Remotes"),
data$desc$get(extra_config_fields(data$desc$fields()))
)
url <- Sys.getenv("R_PKG_GITHUB_API_URL", "https://api.github.com")
proto <- sub(":.*$", "", url)
host <- sub("^[^:]*://", "", url)
sha <- data$sha
sha7 <- substr(sha, 1, 7)
username <- data$remote$username
repo <- data$remote$repo
subdir <- data$remote$subdir %|z|% NULL
commitish <- data$remote$commitish %|z|% NULL
pull <- data$remote$pull %|z|% NULL
release <- data$remote$release %|z|% NULL
package <- data$desc$get_field("Package")
version <- data$desc$get_field("Version")
dependencies <- data$dependencies
unknown <- deps$ref[deps$type %in% dependencies]
unknown <- setdiff(unknown, c(base_packages(), "R"))
meta <- c(
RemoteType = "github",
RemoteHost = host,
RemoteRepo = repo,
RemoteUsername = username,
RemotePkgRef = data$remote$ref,
RemoteRef = if (is.null(pull)) commitish %||% "HEAD" else NULL,
RemotePull = pull,
RemoteSha = sha,
RemoteSubdir = subdir,
GithubRepo = repo,
GithubUsername = username,
GithubRef = if (is.null(pull)) commitish %||% "HEAD" else NULL,
GitHubPull = pull,
GithubSHA1 = sha,
GithubSubdir = subdir)
list(
ref = data$remote$ref,
type = data$remote$type,
direct = data$direct,
status = "OK",
package = package,
version = version,
license = data$desc$get_field("License", NA_character_),
sources = sprintf(
"%s://%s/repos/%s/%s/zipball/%s", proto, host, username, repo, sha),
target = sprintf("src/contrib/%s_%s_%s.tar.gz", package, version, sha7),
remote = list(data$remote),
deps = list(deps),
unknown_deps = unknown,
extra = list(list(remotesha = sha)),
metadata = meta,
params = data$remote$params,
sysreqs = data$desc$get_field("SystemRequirements", "")
)
}
github_query <- function(query,
url = paste0(
Sys.getenv("R_PKG_GITHUB_API_URL",
"https://api.github.com"),
"/graphql"),
headers = character(), ...) {
query; url; headers; list(...)
headers <- c(headers, type_github_get_headers())
data <- tojson$write_str(
list(query = query),
opts = list(auto_unbox = TRUE)
)
resp <- NULL
obj <- NULL
http_post(url, data = data, headers = headers, ...)$
catch(error = function(err) throw(new_github_offline_error()))$
then(function(res) {
resp <<- res
json <- rawToChar(res$content %||% raw())
obj <<- if (nzchar(json)) jsonlite::fromJSON(json, simplifyVector = FALSE)
res
})$
then(http_stop_for_status)$
catch(async_http_error = function(err) {
throw(new_github_http_error(resp, obj), parent = err)
})$
then(function(res) {
list(response = resp, obj = obj)
})
}
# -----------------------------------------------------------------------
# Errors
new_github_error <- function(..., call. = NULL) {
cond <- new_error(..., call. = call.)
class(cond) <- c("github_error", class(cond))
cond
}
# No internet?
new_github_offline_error <- function(call. = NULL) {
new_github_error("Cannot query GitHub, are you offline?", call. = call.)
}
# HTTP error
new_github_http_error <- function(response, obj, call. = NULL) {
if (response$status_code == 401 &&
nzchar(obj$message) && grepl("Bad credentials", obj$message)) {
return(new_github_badpat_error(call. = call.))
}
new_github_error("GitHub HTTP error", call. = call.)
}
# Error in a query
new_github_query_error <- function(rem, response, obj, call. = NULL) {
if ("RATE_LIMITED" %in% vcapply(obj$errors, "[[", "type")) {
return(new_github_ratelimited_error(response, obj, call. = NULL))
# we don't actually get this response currently
} else if (grepl("Could not resolve to a User",
vcapply(obj$errors, "[[", "message"))) {
return(new_github_nouser_error(rem, obj, call. = call.)) # nocov
} else if (grepl("Could not resolve to a Repository",
vcapply(obj$errors, "[[", "message"))) {
return(new_github_norepo_error(rem, obj, call. = call.))
} else if (grepl("Could not resolve to a PullRequest",
vcapply(obj$errors, "[[", "message"))) {
return(new_github_nopr_error(rem, obj, call. = call.))
}
# Otherwise some generic code
ghmsgs <- sub("\\.?$", ".", vcapply(obj$errors, "[[", "message")) # nocov
msg <- paste0("GitHub error: ", paste0(ghmsgs, collapse = ", ")) # nocov
new_github_error(msg, call. = call.) # nocov
}
# No such user/org
new_github_nouser_error <- function(rem, obj, call. = NULL) { # nocov
new_github_error( # nocov
"Can't find GitHub user {rem$username}.", # nocov
call. = call. # nocov
) # nocov
}
# No such repo
new_github_norepo_error <- function(rem, obj, call. = NULL) {
new_github_error(
sprintf("Can't find GitHub repo %s/%s.", rem$username, rem$repo),
call. = call.
)
}
# Not an R package?
new_github_no_package_error <- function(rem, call. = NULL) {
subdir <- rem$subdir %&z&% paste0(" in directory '", rem$subdir, "'")
msg <- sprintf(
"Can't find R package in GitHub repo %s/%s%s", rem$username, rem$repo, subdir
)
new_github_error(msg, call. = call.)
}
# Invalid GitHub PAT
new_github_badpat_error <- function(call. = NULL) {
new_github_error(paste0(
"Bad GitHub credentials, ",
"make sure that your GitHub token is valid."
))
}
# DESCRIPTION does not parse
new_github_baddesc_error <- function(rem, call. = NULL) {
subdir <- rem$subdir %&z&% paste0(", in directory `", rem$subdir, "`")
msg <- sprintf(
"Can't parse DESCRIPTION file in GitHub repo %s/%s%s", rem$username, rem$repo, subdir
)
new_github_error(msg, call. = call.)
}
# No such PR
new_github_nopr_error <- function(rem, obj, call. = NULL) {
msg <- sprintf("Can't find PR #%s in GitHub repo %s/%s", rem$pull, rem$username, rem$repo)
new_github_error(msg, call. = call.)
}
# No releases
new_github_no_release_error <- function(rem, obj, call. = NULL) {
msg <- sprintf("Can't find any release in GitHub repo %s/%s.", rem$username, rem$repo)
new_github_error(msg, call. = call.)
}
# No such branch/tag/ref
new_github_noref_error <- function(rem, call. = NULL) {
ref <- rem$commitish %|z|% "HEAD"
msg <- sprintf("Can't find reference @%s in GitHub repo %s/%s.", ref, rem$username, rem$repo)
new_github_error(msg, call. = call.)
}
# Rate limited
new_github_ratelimited_error <- function(response, obj, call. = NULL) {
headers <- curl::parse_headers_list(response$headers)
ghmsgs <- sub("\\.?$", ".", vcapply(obj$errors, "[[", "message"))
msg <- paste0("GitHub error: ", paste0(ghmsgs, collapse = ", "))
if ("x-ratelimit-reset" %in% names(headers)) {
reset <- format(
.POSIXct(headers$`x-ratelimit-reset`, tz = "UTC"),
usetz = TRUE
)
msg <- paste0(msg, " Rate limit will reset at ", reset, ".")
}
new_github_error(msg, call. = call.)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.