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) {
  cli::cli_h2("Preparations")
  codename <- set_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)
  dir_out_src <- sprintf("%s/src/contrib/Archive", local_build_root)
  cli::cli_alert_info("{.fun build_binary_package}: Creating dir {.path {dir_out_bin}}.")
  cli::cli_alert_info("{.fun build_binary_package}: Creating 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")

  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"))
    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")

  cli::cli_alert_info("Building binaries for {.pkg {package_name[[1]]}} with tags {.strong {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, FALSE)
          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, TRUE)
        }
      )
    }, package_name, tag, future.seed = TRUE)
  })

  # round(Sys.time() - t1, 2)}} {units(difftime(Sys.time(), t1))}

  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")
  out <- progressr::with_progress({
    p <- progressr::progressor(along = tag)
    future_mapply(function(x, y) {
      tryCatch(
        {
          p()
          upload_single_binary_to_s3(package_name = x, tag = y, debug = F)
        },
        error = function(e) {
          message("Error in uploading package ", x, " with tag ", y, ": ")
        }
      )
    }, package_name, tag, future.seed = TRUE)
  })

  return(invisible(TRUE))
}

#' @export
install_package_system_dependencies <- function(package_name,
                                                tag,
                                                platform = "redhat-9",
                                                local_clone_dir) {
  cli::cli_alert_info("{.fun install_package_system_dependencies}: Cloning package {.pkg {package_name[1]}} with tag {.strong {tag}}.")

  local_clone_dir_single <- sprintf("%s/%s_%s", local_clone_dir, package_name[1], tail(tag, 1))

  if (!dir.exists(local_clone_dir_single)) {
    system2("git", args = c(
      "clone", "-q", sprintf("--branch=%s", tail(tag, 1)),
      sprintf("https://github.com/cran/%s", package_name[1]), local_clone_dir_single
    ))
  }

  Sys.setenv(PKG_SYSREQS_PLATFORM = platform)
  Sys.setenv(PKG_SYSREQS = TRUE)
  Sys.setenv(PKG_SYSREQS_VERBOSE = TRUE)
  pak::local_install_dev_deps(sprintf("%s", local_clone_dir_single))

  cli::cli_alert_info("{.fun install_package_system_dependencies}: 4. Removing {.path {local_clone_dir_single}}.")

  unlink(sprintf("%s", local_clone_dir_single), recursive = TRUE, force = 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. Cloning package {.pkg {package_name}} with tag {.strong {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. Tarball for package {.pkg {package_name}} with tag {.strong {tag}} already exists. Skipping build.")
  } else {
    cli::cli_alert_info("{.fun build_single_tag}: 2. Building package {.pkg {package_name}} with tag {.strong {tag}}.")

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

    if (!file.exists(sprintf("%s/%s_%s.tar.gz", dir_out_bin, package_name, tag))) {
      cli::cli_alert_info('{.fun build_single_tag}: 3. 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. 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))
}