add default BioC_mirror for CI=TRUE env

R/repositories.R

@@ -1,4 +1,5 @@
-BINARY_BASE_URL <- "https://bioconductor.org/packages/%s/container-binaries/%s"
+.BINARY_SLUG_URL <- "/packages/%s/container-binaries/%s"
+.BIOC_DOMAIN_URL <- "https://bioconductor.org"
 
 .repositories_check_repos_envopt <-
     function()
@@ -68,11 +69,51 @@ BINARY_BASE_URL <- "https://bioconductor.org/packages/%s/container-binaries/%s"
     repos
 }
 
+.repositories_ci_mirror_envopt <-
+    function()
+{
+    opt <- Sys.getenv("BIOCMANAGER_USE_CI_MIRROR", TRUE)
+    opt <- getOption("BiocManager.use_ci_mirror", opt)
+    isTRUE(as.logical(opt)) && as.logical(Sys.getenv("CI", FALSE))
+}
+
+.repositories_config_mirror_url <- function(txt) {
+    section <- .version_config_section(txt, "^[^[:blank:]]", "mirrors:")
+    section <- .version_config_section(
+        trimws(section), "-\\sinstitution:.*", "Bioconductor.*CI.*"
+    )
+    mirror_value <- Filter(
+        function(x) startsWith(x, "https_mirror_url"), section
+    )
+    mirror <- sub("https_mirror_url:\\s*(.*)", "\\1", mirror_value)
+    if (!length(mirror) || !nzchar(mirror))
+        mirror <- .BIOC_DOMAIN_URL
+    mirror
+}
+
+.repositories_read_bioc_mirror <-
+    function(config)
+{
+    mirror <- .BIOC_DOMAIN_URL
+    if (.repositories_ci_mirror_envopt()) {
+        txt <- .version_map_read_online(config)
+        mirror <- .repositories_config_mirror_url(txt)
+    }
+    mirror
+}
+
+.repositories_bioc_mirror <- function() {
+    mirror_url <- .repositories_read_bioc_mirror(
+        "https://bioconductor.org/config.yaml"
+    )
+    getOption("BioC_mirror", mirror_url)
+}
+
 #' @importFrom stats setNames
 .repositories_bioc <-
     function(version, ..., type = NULL)
 {
-    mirror <- getOption("BioC_mirror", "https://bioconductor.org")
+    mirror <- .repositories_bioc_mirror()
     paths <- c(
         BioCsoft = "bioc",
         BioCann = "data/annotation",
@@ -150,8 +191,9 @@ BINARY_BASE_URL <- "https://bioconductor.org/packages/%s/container-binaries/%s"
 #' the appropriate CRAN repository.
 #'
 #' To install binary packages on containerized versions of Bioconductor,
-#' a default binary package location URL is set as a package constant,
-#' see `BiocManager:::BINARY_BASE_URL`. Binary package installations
+#' a default binary package location URL is resolved from the
+#' `getOption("BioC_mirror")` (or the default `https://bioconductor.org`)
+#' and the `BiocManager:::.BINARY_SLUG_URL`. Binary package installations
 #' are enabled by default for Bioconductor Docker containers. Anyone
 #' wishing to opt out of the binary package installation can set either the
 #' variable or the option, \env{BIOCONDUCTOR_USE_CONTAINER_REPOSITORY}, to
@@ -185,6 +227,12 @@ BINARY_BASE_URL <- "https://bioconductor.org/packages/%s/container-binaries/%s"
 #' `repositories()` as a basis for constructing the `repos =` argument
 #' to `install.packages()` and related functions.
 #'
+#' On Continuous Integration (CI) platforms, `BiocManager` re-routes
+#' requests to low-cost mirror sites. Users may opt out of this by
+#' setting either the option or the variable to `FALSE`, i.e.,
+#' `options(BiocManager.use_ci_mirror = FALSE)` or
+#' \env{BIOCMANAGER_USE_CI_MIRROR}.
+#'
 #' @return `repositories()`: named `character()` of repositories.
 #'
 #' @seealso
@@ -263,16 +311,14 @@ repositories <- function(
 
 #' @rdname repositories
 #'
-#' @aliases BINARY_BASE_URL
-#'
 #' @description `containerRepository()` reports the location of the repository
 #'     of binary packages for fast installation within containerized versions
 #'     of Bioconductor, if available.
 #'
 #' @details
 #'
-#' The unexported URL to the base repository is available with
-#' `BiocManager:::BINARY_BASE_URL`.
+#' The binary URL is a combination of `getOption("BioC_mirror")` and
+#' `BiocManager:::.BINARY_SLUG_URL`.
 #'
 #' \env{BIOCONDUCTOR_USE_CONTAINER_REPOSITORY} is an environment
 #' variable or global `options()` which, when set to `FALSE`, avoids
@@ -315,15 +361,35 @@ containerRepository <-
         return(character())
 
     ## does the binary repository exist?
-    binary_repos0 <- sprintf(BINARY_BASE_URL, version, platform)
+    mirror <- .repositories_bioc_mirror()
+    .repositories_try_container_url(version, mirror, platform)
+}
+
+.repositories_try_url_con <- function(version, mirror, platform, FUN, ...) {
+    bioc_url <- paste0(mirror, .BINARY_SLUG_URL)
+    binary_repos0 <- sprintf(bioc_url, version, platform)
     packages <- paste0(contrib.url(binary_repos0), "/PACKAGES.gz")
     url <- url(packages)
     tryCatch({
         suppressWarnings(open(url, "rb"))
-        close(url)
         setNames(binary_repos0, "BioCcontainers")
     }, error = function(...) {
-        close(url)
-        character()
-    })
+        FUN(...)
+    }, finally = {close(url)})
+}
+
+.repositories_try_container_url <- function(version, mirror, platform) {
+    .repositories_try_url_con(
+        version = version,
+        mirror = mirror,
+        platform = platform,
+        FUN = function(...) {
+            .repositories_try_url_con(
+                version = version,
+                mirror = .BIOC_DOMAIN_URL,
+                platform = platform,
+                FUN = character
+            )
+        }
+    )
 }

R/version.R

@@ -100,26 +100,27 @@ format.version_sentinel <-
     txt
 }
 
-.version_map_config_element <-
-    function(txt, tag)
-{
-    grps <- grep("^[^[:blank:]]", txt)
+.version_config_section <- function(txt, grp, tag) {
+    grps <- grep(grp, txt)
     start <- match(grep(tag, txt), grps)
     if (!length(start))
         return(setNames(character(), character()))
     end <- ifelse(length(grps) < start + 1L, length(txt), grps[start + 1] - 1L)
-    map <- txt[seq(grps[start] + 1, end)]
-    map <- trimws(gsub("\"", "", sub(" #.*", "", map)))
+    txt[seq(grps[start] + 1, end)]
+}
 
+.version_map_config_element <-
+    function(txt, tag)
+{
+    map <- .version_config_section(txt = txt, grp = "^[^[:blank:]]", tag = tag)
+    map <- trimws(gsub("\"", "", sub(" #.*", "", map)))
     pattern <- "(.*): (.*)"
     key <- sub(pattern, "\\1", map)
     value <- sub(pattern, "\\2", map)
     setNames(value, key)
 }
 
-.version_map_get_online <-
-    function(config)
-{
+.version_map_read_online <- function(config) {
     toggle_warning <- FALSE
     withCallingHandlers({
         txt <- .version_map_get_online_config(config)
@@ -130,7 +131,13 @@ format.version_sentinel <-
     })
     if (toggle_warning)
         .VERSION_MAP$WARN_NO_ONLINE_CONFIG <- FALSE
+    txt
+}
 
+.version_map_get_online <-
+    function(config)
+{
+    txt <- .version_map_read_online(config = config)
     if (!length(txt) || inherits(txt, "error"))
         return(.VERSION_MAP_SENTINEL)
 
@@ -170,7 +177,7 @@ format.version_sentinel <-
         BiocStatus = factor(
             status,
             levels = .VERSION_TAGS
-        )  
+        )
     ))
 }
 

tests/testthat/test_repositories.R

@@ -169,6 +169,33 @@ test_that("'.repositories_filter()' works", {
     expect_equal(.repositories_filter(repos), repos0)
 })
 
+test_that("config.yaml is parsed correctly", {
+    test.config <- c(
+        "mirrors:",
+        "  - 1-Bioconductor:",
+        "    - institution: Bioconductor CI redirect",
+        "      https_mirror_url: https://foobar.com/"
+    )
+    expect_identical(
+        .repositories_config_mirror_url(
+            test.config
+        ),
+        "https://foobar.com/"
+    )
+    test.config <- c(
+        "mirrors:",
+        "  - 1-Bioconductor:",
+        "    - institution: Bioconductor CI redirect",
+        "      https_mirror_url: "
+    )
+    expect_identical(
+        .repositories_config_mirror_url(
+            test.config
+        ),
+        .BIOC_DOMAIN_URL
+    )
+})
+
 test_that("'containerRepository' uses 'type' argument", {
     skip_if_offline()
     bin_url <- "https://bioconductor.org/packages/%s/container-binaries/%s"