build-cran-binaries/R/build_binaries.R

#' Build R binary packages
#' @import progressr
#' @importFrom future plan
#' @importFrom future.apply future_mapply
#' @importFrom progressr with_progress progressor
#' @importFrom gert git_config_global_set git_clone
#' @importFrom pak local_install_dev_deps
#' @importFrom pkgbuild build
#' @export
build_binary_package <- function(package_name, tag = NULL, codename = NULL,
                                 r_minor_version = NULL, build_for_minor = TRUE,
                                 local_build_root = "/root",
                                 local_clone_dir = "/tmp",
                                 platform = NULL,
                                 install_system_dependencies = TRUE,
                                 debug = FALSE,
                                 force = FALSE) {
  cli::cli_h2("Preparations ({.pkg {package_name}})")
  codename <- set_codename(codename)

  if (debug) {
    cli::cli_alert_warning("DEBUG: codename {codename}.")
  }

  if (is.null(r_minor_version)) {
    r_minor_version <- sub("R version (\\d+\\.\\d+).*", "\\1", R.Version()$version.string)
  }

  # create directory structure
  dir_out_bin <- set_bin_path(r_minor_version, build_for_minor, local_build_root, codename)

  local_bin_path <- set_bin_path(r_minor_version, build_for_minor, local_build_root = local_build_root, codename)

  if (debug) {
    cli::cli_alert_warning("DEBUG: dir_out_bin {dir_out_bin}.")
  }

  dir_out_src <- sprintf("%s/src/contrib/Archive", local_build_root)
  if (debug) {
    cli::cli_alert("{.fun build_binary_package}: Creating bin dir {.path {dir_out_bin}}.")
    cli::cli_alert("{.fun build_binary_package}: Creating src dir {.path {dir_out_src}}.")
  }
  dir.create(sprintf("%s/Archive", dir_out_bin), sprintf("%s/Archive", dir_out_src),
    recursive = TRUE
  )

  cli::cli_h2("Installing system dependencies ({.pkg {package_name}})")

  gert::git_config_global_set("advice.detachedHead", "false")

  if (is.null(tag)) {
    gert::git_clone(sprintf("https://github.com/cran/%s", package_name),
      path = sprintf("%s/%s", tempdir(), "tmp1"),
      verbose = FALSE
    )
    # Retrieve all tags
    all_tags <- gert::git_tag_list(repo = sprintf("%s/%s", tempdir(), "tmp1"))
    # filter out tags that start with R- (= non-valid ones)
    all_tags <- all_tags[!grepl("R-", all_tags$name), ]

    unlink(sprintf("%s/%s", tempdir(), "tmp1"), force = TRUE, recursive = TRUE)
    tag <- all_tags$name
    package_name <- rep(package_name, length(tag))
  }

  ### Install system dependencies
  if (install_system_dependencies) {
    tryCatch(
      {
        install_package_system_dependencies(package_name, tag, platform, local_clone_dir)
      },
      # NB: here we need to use conditionMessage() to extract the actual error - as opposed to using $stderr for errors within the tryCatch used in the future* calls
      error = function(e) {
        cli::cli_alert_warning("Error in installing dependencies for package {.pkg {package_name[1]}} with tag {.field {tag[1]}}: {e}")
        store_build_metadata(package_name[1], tag[1], platform, error_occurred = TRUE, force = TRUE, error = conditionMessage(e))
        return(TRUE)
      }
    )
  }

  t1 <- Sys.time()
  cli::cli_h2("Building ({.pkg {package_name[1]}})")

  cli::cli_alert("Building binaries for {.pkg {package_name[[1]]}} with tags {.field {tag}}.")

  # Set up the progress handler
  progressr::handlers(global = TRUE)
  progressr::handlers("cli", "debug")

  out <- progressr::with_progress({
    p <- progressr::progressor(along = tag)
    future.apply::future_mapply(function(x, y) {
      tryCatch(
        {
          p()
          dump <- build_single_tag(x, y, dir_out_bin, local_clone_dir, platform = platform, debug = debug, force = force)

          # if for some reason an underlying error didnt' get caught in the tryCatch calls, we check again here for the existence of the binary file on disk and mark the build as failed if it is not found
          tarball_name <- sprintf("%s_%s.tar.gz", x, y)
          if (fs::file_exists(sprintf("%s/%s", local_bin_path, tarball_name))) {
            cli::cli_alert_success("Successfully built package {.pkg {x}} with tag {.field {y}}.")
          } else {
            cli::cli_alert_warning("Error in building package {.pkg {x}} with tag {.field {y}}: Uncommon/unspecific error during build.")
            store_build_metadata(x, y, platform, error_occurred = TRUE, force = TRUE, error = "Uncommon/unspecific error during build")
          }
        },
        error = function(e) {
          cli::cli_alert_warning("Error in building package {.pkg {package_name}} with tag {.field {tag}}: {e}")
          local_clone_dir_single <- sprintf("%s/%s_%s", local_clone_dir, x, y)
          unlink(local_clone_dir_single, force = TRUE, recursive = TRUE)
          # only stderr contains the important information why the build failed
          store_build_metadata(x, y, platform, error_occurred = TRUE, force = TRUE, error = e$stderr)
        }
      )
    }, package_name, tag, future.seed = TRUE)
  })

  total_build_time <- round(Sys.time() - t1, 2)
  cli::cli_alert("Execution time ({.pkg {package_name[[1]]}}) ({length(tag)} tags): {.strong {total_build_time} {units(difftime(Sys.time(), t1))}}.")

  cli::cli_h2("Uploading ({.pkg {package_name[1]}})")
  out <- progressr::with_progress({
    p <- progressr::progressor(along = tag)
    future.apply::future_mapply(function(x, y) {
      tryCatch(
        {
          p()
          dump <- upload_single_binary_to_s3(package_name = x, tag = y, force = force, build_for_minor = build_for_minor, debug = debug)
        },
        error = function(e) {
          message(sprintf("Error in uploading package %s with tag %s: %s", x, y, e))
        }
      )
    }, package_name, tag, future.seed = TRUE)
  })

  return(invisible(TRUE))
}

#' @importFrom cli cli_alert
#' @importFrom pkgbuild build
#' @importFrom fs file_size file_move
#' @export
build_single_tag <- function(
    package_name, tag = NULL,
    platform,
    dir_out_bin,
    local_clone_dir,
    debug = FALSE,
    force = FALSE) {
  cli::cli_alert("{.fun build_single_tag}: (1/3) Cloning package {.pkg {package_name}} with tag {.field {tag}}.")

  local_clone_dir_single <- sprintf("%s/%s_%s", local_clone_dir, package_name, tag)

  # Using system git here as {gert} does not provide this functionality to checkout a branch by tag
  system2("git", args = c(
    "clone", "-q", sprintf("--branch=%s", tag),
    sprintf("https://github.com/cran/%s", package_name), local_clone_dir_single
  ))

  if (file.exists(sprintf("%s/%s_%s.tar.gz", dir_out_bin, package_name, tag))) {
    cli::cli_alert("{.fun build_single_tag}: (2/3) Tarball for package {.pkg {package_name}} with tag {.field {tag}} already exists. Skipping build.")
  } else {
    cli::cli_alert("{.fun build_single_tag}: (2/3) Building package {.pkg {package_name}} with tag {.field {tag}}.")

    t1 <- Sys.time()
    tryCatch(
      {
        dump <- pkgbuild::build(
          path = sprintf("%s", local_clone_dir_single),
          binary = TRUE, vignettes = FALSE,
          dest_path = dir_out_bin, quiet = TRUE
        )
      },
      error = function(e) {
        cli::cli_alert_warning("Error in starting build command for package {.pkg {package_name}} with tag {.field {tag}}: {e}")
        local_clone_dir_single <- sprintf("%s/%s_%s", local_clone_dir, package_name, tag)
        unlink(local_clone_dir_single, force = TRUE, recursive = TRUE)
        store_build_metadata(package_name, tag, platform, error_occurred = TRUE, force = TRUE, error = "Error trying to initiate pkgbuild - likely a non-valid R package structure")
        return(invisible(TRUE))
      }
    )

    if (!file.exists(sprintf("%s/%s_%s.tar.gz", dir_out_bin, package_name, tag))) {
      if (debug) {
        cli::cli_alert_info('{.fun build_single_tag}: Moving package from {.path {sprintf("%s/%s_%s_R_aarch64-unknown-linux-gnu.tar.gz", dir_out_bin, package_name, tag)}} to {.path {sprintf("%s/%s_%s.tar.gz", dir_out_bin, package_name, tag)}}')
      }
      # double-check that file exists (some packages like https://github.com/cran/BACCO/tree/1.0-14 don't include R/ and hence don't procude a valid binary)
      if (fs::file_exists(sprintf("%s/%s_%s_R_aarch64-unknown-linux-gnu.tar.gz", dir_out_bin, package_name, tag))) {
        # remove _aarch64-unknown-linux-gnu part in filename
        fs::file_move(
          sprintf("%s/%s_%s_R_aarch64-unknown-linux-gnu.tar.gz", dir_out_bin, package_name, tag),
          sprintf("%s/%s_%s.tar.gz", dir_out_bin, package_name, tag)
        )
      } else {
        cli::cli_alert_info('{.fun build_single_tag}: File for package {.pkg {package_name}} {.field {tag}} at {.path {sprintf("%s/%s_%s_R_aarch64-unknown-linux-gnu.tar.gz", dir_out_bin, package_name, tag)}} does not exist - skipping.')
      }
    } else {
      cli::cli_alert_warning('{.fun build_single_tag}: Binary {sprintf("%s_%s.tar.gz", package_name, tag)} already exists. Skipping copy.')
    }
    unlink(sprintf("%s/%s_%s_R*.tar.gz", dir_out_bin, package_name, tag))

    cli::cli_alert("{.fun build_single_tag}: (3/3) Removing {.path {local_clone_dir_single}}.")
    unlink(local_clone_dir_single, force = TRUE, recursive = TRUE)

    total_build_time <- round(as.numeric(difftime(Sys.time(), t1, units = "secs")), 2)

    # bytes to MB in binary format
    file_size <- round(as.numeric(fs::file_size(sprintf("%s/%s_%s.tar.gz", dir_out_bin, package_name, tag))) / (1024^2), 2)

    if (debug) {
      cli::cli_alert_warning("DEBUG: total_build_time: {total_build_time}")
      cli::cli_alert_warning("DEBUG: file_size: {file_size}")
    }

    tarball_name <- sprintf("%s_%s.tar.gz", package_name, tag)
    if (fs::file_exists(sprintf("%s/%s", dir_out_bin, tarball_name))) {
      store_build_metadata(package_name, tag, platform, error_occurred = FALSE, force = force, build_duration = total_build_time, size = file_size)
    }
  }

  return(invisible(TRUE))
}