build-cran-binaries/R/build_binaries.R

#' @import progressr
#' @importFrom future plan
#' @importFrom future.apply future_mapply
#' @importFrom gert git_config_set
#' @importFrom pak local_install_dev_deps
#' @importFrom pkgbuild build
#' @export
build_binary_package <- function(package_name, tag = NULL, codename = NULL,
                                 r_version_minor = NULL, build_for_minor = TRUE,
                                 local_build_root = "/root",
                                 local_clone_dir = "/tmp",
                                 platform = "redhat-9",
                                 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_version_minor)) {
    r_version_minor <- sub("R version (\\d+\\.\\d+).*", "\\1", R.Version()$version.string)
  }

  # create directory structure
  dir_out_bin <- set_bin_path(r_version_minor, build_for_minor, 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_info("{.fun build_binary_package}: Creating bin dir {.path {dir_out_bin}}.")
    cli::cli_alert_info("{.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)) {
    # get all tags of package
    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))

    # if (reset_db_metadata) {
    #   cli::cli_alert_warning("{.fun build_binary_package}: Resetting metadata for {.pkg {package_name}}.")

    #   con <- dbConnect(RSQLite::SQLite(), dbname = "metadata_summary.db")
    #   # Remove all entries from the metadata_summary table
    #   dbExecute(con, "DELETE FROM metadata_summary")
    # }
  }

  ### Install system dependencies
  if (install_system_dependencies) {
    install_package_system_dependencies(package_name, tag, platform, local_clone_dir)
  }

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

  cli::cli_alert_info("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_mapply(function(x, y) {
      tryCatch(
        {
          p()
          store_build_metadata(x, y, platform, error_occurred = FALSE, force = force)
          dump <- build_single_tag(x, y, dir_out_bin, local_clone_dir, platform = platform)
        },
        error = function(e) {
          message(sprintf("Error in processing package %s with tag %s: %s", x, y, e))
          local_clone_dir_single <- sprintf("%s/%s_%s", local_clone_dir, x, y)
          unlink(local_clone_dir_single, force = TRUE, recursive = TRUE)
          store_build_metadata(x, y, platform, error_occurred = TRUE, force = force)
        }
      )
    }, package_name, tag, future.seed = TRUE)
  })

  total_build_time <- round(Sys.time() - t1, 2)
  cli::cli_alert_info("Execution time for {.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_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_info
#' @importFrom pkgbuild build
#' @export
build_single_tag <- function(
    package_name, tag = NULL,
    platform,
    dir_out_bin,
    local_clone_dir) {
  cli::cli_alert_info("{.fun build_single_tag}: (1/4) 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
  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_info("{.fun build_single_tag}: (2/4). Tarball for package {.pkg {package_name}} with tag {.field {tag}} already exists. Skipping build.")
  } else {
    cli::cli_alert_info("{.fun build_single_tag}: (2/4). Building package {.pkg {package_name}} with tag {.field {tag}}.")

    t1 <- Sys.time()
    dump <- pkgbuild::build(
      path = sprintf("%s", local_clone_dir_single),
      binary = TRUE, vignettes = FALSE,
      dest_path = dir_out_bin, quiet = TRUE
    )

    if (!file.exists(sprintf("%s/%s_%s.tar.gz", dir_out_bin, package_name, tag))) {
      cli::cli_alert_info('{.fun build_single_tag}: (3/4). Moving package from {.path {sprintf("%s/%s*.tar.gz", dir_out_bin, package_name)}} to {.path {sprintf("%s/%s_%s.tar.gz", dir_out_bin, package_name, tag)}}')
      # remove _aarch64-unknown-linux-gnu part in filename
      system2("rsync", args = c(
        sprintf("%s/%s_%s*.tar.gz", dir_out_bin, package_name, tag),
        sprintf("%s/%s_%s.tar.gz", dir_out_bin, package_name, tag)
      ))
    } 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_info("{.fun build_single_tag}: (4/4) Removing {.path {local_clone_dir_single}}.")
    unlink(local_clone_dir_single, force = TRUE, recursive = TRUE)

    total_build_time <- round(Sys.time() - t1, 2)

    # skip DB connection if package already exists
    if (file.exists(sprintf("%s/%s_%s.tar.gz", dir_out_bin, package_name, tag))) {
      con <- DBI::dbConnect(RPostgres::Postgres(),
        dbname = "build_metadata", host = "postgres-arm-binaries-r.devxy.io",
        port = 15432, user = "arm_binaries", password = Sys.getenv("PGPASS")
      )
      dbExecute(con, sprintf(
        "UPDATE single_builds set build_duration = %s WHERE package_name = '%s' and platform = '%s' and tag = '%s'",
        total_build_time, package_name, platform, tag
      ))
      dbDisconnect(con)
    }
  }

  return(invisible(TRUE))
}