diff --git a/NAMESPACE b/NAMESPACE index 57b020a5..9fac6bcb 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -84,6 +84,7 @@ export(install_github) export(install_gitlab) export(install_local) export(install_remote) +export(install_runiverse) export(install_svn) export(install_url) export(install_version) diff --git a/R/install-runiverse.R b/R/install-runiverse.R new file mode 100644 index 00000000..ad31ae89 --- /dev/null +++ b/R/install-runiverse.R @@ -0,0 +1,112 @@ +#' Install a package from R-Universe +#' +#' `install_runiverse()` retrieves the canonical universe for a CRAN package +#' using the R-Universe API, +#' then downloads and installs the package from that universe. +#' If the package has a `Remotes` field, +#' dependencies will be installed first from the appropriate remote repositories +#' using the same function. +#' +#' @param package The package name to install. +#' @param universe The R-Universe to use, infer from the package if `NULL`. +#' @param ... Additional arguments passed to `install_cran()`. +#' @param linux_distro A string specifying the Linux distribution +#' for the installation of binary packages on Linux. +#' @return A character vector of the names of installed packages, invisibly. +#' @family package installation +#' @export +#' @examples +#' \dontrun{ +#' # From GitHub +#' install_runiverse("dplyr") +#' +#' # From GitLab +#' install_runiverse("iemiscdata") +#' +#' # From Bitbucket +#' install_runiverse("argparser") +#' } +install_runiverse <- function(package, universe = NULL, ..., linux_distro = NULL) { + if (...length() > 0) { + stop( + "Additional arguments (...) are not supported by install_runiverse()", + call. = FALSE + ) + } + + if (is.null(universe)) { + universe <- get_runiverse_for_package(package) + } else if (length(universe) != 1 || !is.character(universe)) { + stop("'universe' must be a single string", call. = FALSE) + } + + # https://github.com/r-lib/remotes/issues/618#issuecomment-3333533114 + # https://docs.r-universe.dev/install/binaries.html#how-to-install-linux-binary-packages + if (is.null(linux_distro)) { + repo <- paste0("https://", universe, ".r-universe.dev/", package) + } else { + repo <- paste0( + "https://", universe, ".r-universe.dev/", package, + "/bin/linux/", linux_distro, "-", R.version$arch, "/", + substr(getRversion(), 1, 3) + ) + } + + tempdir <- tempfile("remotes") + dir.create(tempdir) + on.exit(unlink(tempdir, recursive = TRUE), add = TRUE) + + # available.packages() does not work for the repo + download <- utils::download.packages(package, destdir = tempdir, repos = repo)[, 2] + + untar_success <- utils::untar(download, file.path(package, "DESCRIPTION"), exdir = tempdir) + if (untar_success != 0) { + stop("Failed to extract package DESCRIPTION from downloaded tarball", call. = FALSE) + } + + desc_path <- file.path(tempdir, package, "DESCRIPTION") + desc <- read_dcf(desc_path) + + installed <- character() + + if (!is.null(desc$Remotes)) { + message("Installing dependencies from Remotes field: ", desc$Remotes) + + remotes <- strsplit(desc$Remotes, "[ \n]*,[ \n]*")[[1]] + org_pkg <- re_match(remotes, "^(?:github::)?(?[^/:]+)/(?[^/@#]+)$") + + for (i in seq_len(nrow(org_pkg))) { + if (is.na(org_pkg$.match[[i]])) { + install_remote(org_pkg$.text[[i]]) + } else { + install_runiverse(org_pkg$pkg[[i]], universe = org_pkg$org[[i]], linux_distro = linux_distro) + } + } + } + + # We already downloaded but can't provide a correct `type` argument + install_cran(package, repos = repo, dependencies = FALSE) +} + +get_runiverse_for_package <- function(package) { + # Can't use httr2, only curl + if (!requireNamespace("curl", quietly = TRUE)) { + stop("Package 'curl' is required to install from R-Universe", call. = FALSE) + } + + handle <- curl::new_handle() + curl::handle_setheaders(handle, `User-Agent` = "r-lib/remotes") + + packages_raw <- curl::curl_fetch_memory( + paste0("https://r-universe.dev/api/search?q=package:", package) + ) + + packages <- json$parse(rawToChar(packages_raw$content)) + + results <- packages$results + if (length(results) == 0) { + stop(sprintf("Package '%s' not found on R-Universe", package), call. = FALSE) + } + + packages$results[[1]]$"_user" +}