build-cran-binaries/local/propose-patches.R

#!/usr/bin/env Rscript

# Propose registry patches for classified, auto-proposable build failures
# (issue #115, step 3: "propose, do not apply"). Queries `single_builds`,
# classifies failures, and for each *known, safe* fix lever affecting a package
# with no current registry entry, emits a pre-filled `registry.json` entry.
#
# The human gate stays: this never merges. Acceptance before merge is
#   1. `local/validate-patches.R` passes (checked here against a candidate
#      registry), and
#   2. an isolated trial build succeeds -- run `local/trial-build-patch.R <pkg>`
#      (this script prints the exact command per candidate).
# Novel source diffs and unknown signatures are never proposed (they carry
# `auto = FALSE` in the signature table).
#
# Usage:
#   PGPASS=... Rscript local/propose-patches.R [--platform P] [--arch A] [--min N]
#       (default)        print candidates + validation, take no action
#       --write          append candidates to local/patches/registry.json and
#                        the proposals ledger (commit + open a PR yourself)
#       --open-issue     post/update a Forgejo tracking issue (needs FORGEJO_TOKEN)
#       --json PATH      also write the machine-readable candidate list to PATH

options(error = function() {
  cat("ERROR:", geterrmessage(), "\n", file = stdout())
  q(status = 1)
})

suppressPackageStartupMessages({
  library(DBI, quietly = TRUE)
  library(RPostgres, quietly = TRUE)
  library(jsonlite, quietly = TRUE)
})

script_path <- local({
  a <- commandArgs(trailingOnly = FALSE)
  f <- sub("^--file=", "", a[grepl("^--file=", a)])
  if (length(f) == 1L && nzchar(f)) normalizePath(f) else NA_character_
})
script_dir <- if (is.na(script_path)) "local" else dirname(script_path)
source(file.path(script_dir, "failing-builds-classify.R"))
source(file.path(script_dir, "proposal-tracking-lib.R"))

# ---------------------------------------------------------------------------
# Arguments
# ---------------------------------------------------------------------------
args <- commandArgs(trailingOnly = TRUE)
opt_val <- function(flag, default = NA_character_) {
  i <- match(flag, args)
  if (!is.na(i) && i < length(args)) args[[i + 1L]] else default
}
platform <- opt_val("--platform", Sys.getenv("PLATFORM", ""))
arch <- opt_val("--arch", Sys.getenv("ARCH", ""))
json_out <- opt_val("--json")
min_count <- suppressWarnings(as.integer(opt_val("--min", "1")))
if (is.na(min_count)) {
  min_count <- 1L
}
do_write <- "--write" %in% args
do_issue <- "--open-issue" %in% args

if (nchar(Sys.getenv("PGPASS")) == 0L) {
  stop("PGPASS env var is not set; a DB password is required.")
}

registry_file <- file.path(script_dir, "patches", "registry.json")
ledger_file <- file.path(script_dir, "patches", "proposals-log.json")

# ---------------------------------------------------------------------------
# Query failing builds (same shape as failing-builds-report.R)
# ---------------------------------------------------------------------------
con <- DBI::dbConnect(
  RPostgres::Postgres(),
  dbname = "build_metadata",
  host = "r-binaries.devxy.io",
  port = 15432,
  user = "rpkgs",
  password = Sys.getenv("PGPASS"),
  sslmode = "require"
)
on.exit(DBI::dbDisconnect(con), add = TRUE)

where <- "error_occurred = TRUE AND removed = FALSE"
params <- list()
if (nzchar(platform)) {
  where <- paste0(where, " AND platform = $", length(params) + 1L)
  params <- c(params, platform)
}
if (nzchar(arch)) {
  where <- paste0(where, " AND arch = $", length(params) + 1L)
  params <- c(params, arch)
}
failures <- DBI::dbGetQuery(
  con,
  paste0(
    "SELECT name, tag, platform, arch, r_version, timestamp, error_text ",
    "FROM single_builds WHERE ",
    where
  ),
  params = if (length(params) > 0L) params else NULL
)
cat(sprintf("Queried single_builds: %d failing builds\n", nrow(failures)))

# ---------------------------------------------------------------------------
# Existing registry + classification
# ---------------------------------------------------------------------------
existing_entries <- if (file.exists(registry_file)) {
  jsonlite::fromJSON(registry_file, simplifyVector = FALSE)
} else {
  list()
}
registered_pkgs <- unique(vapply(
  existing_entries,
  function(e) as.character(e$package %||% ""),
  character(1L)
))

report <- build_triage_report(failures, registered_pkgs)
report <- Filter(function(r) r$build_count >= min_count, report)

# Flatten auto-proposable groups into candidate records.
candidates <- list()
for (r in report) {
  if (is.null(r$proposed_entries)) {
    next
  }
  for (pkg in names(r$proposed_entries)) {
    candidates[[length(candidates) + 1L]] <- list(
      package = pkg,
      signature = r$signature,
      confidence = r$confidence,
      tier = r$tier,
      entry = r$proposed_entries[[pkg]]
    )
  }
}

# Groups blocked on a dependency (e.g. RcppParallel dependents) are reported,
# not proposed: fixing the named dependency clears them all at once.
blocked <- Filter(function(r) !is.null(r$blocked_on), report)
if (length(blocked) > 0L) {
  cat("\nBlocked on a dependency (fix the dependency, not each dependent):\n")
  for (r in blocked) {
    cat(sprintf(
      "  %s: %d package(s) fail because %s does not build\n",
      toString(r$blocked_on),
      length(r$packages),
      toString(r$blocked_on)
    ))
  }
}

# A package that maps to more than one auto-proposable signature is ambiguous
# (conflicting fix tiers) and would collide on the same registry key; route it
# to human triage instead of emitting both.
split_candidates <- dedupe_candidates(candidates)
candidates <- split_candidates$keep
if (length(split_candidates$ambiguous) > 0L) {
  cat("\nAmbiguous (multiple signatures) -> human triage, not proposed:\n")
  for (pkg in names(split_candidates$ambiguous)) {
    cat(sprintf(
      "  %s: %s\n",
      pkg,
      toString(split_candidates$ambiguous[[pkg]])
    ))
  }
}

if (length(candidates) == 0L) {
  cat(
    "\nNo auto-proposable candidates (nothing classified, safe, unregistered, and unambiguous).\n"
  )
  q(status = 0)
}

cat(sprintf(
  "\n%d candidate registry %s:\n",
  length(candidates),
  if (length(candidates) == 1L) "entry" else "entries"
))
cat(strrep("=", 78L), "\n", sep = "")
for (c in candidates) {
  j <- jsonlite::toJSON(
    c$entry,
    auto_unbox = TRUE,
    pretty = TRUE,
    null = "null"
  )
  cat(sprintf(
    "\n# %s  [signature: %s, %s confidence]\n",
    c$package,
    c$signature,
    c$confidence
  ))
  cat(j, "\n", sep = "")
  cat(sprintf(
    "  acceptance gate: PGPASS=... Rscript local/trial-build-patch.R %s\n",
    c$package
  ))
}

# ---------------------------------------------------------------------------
# Validate the candidate set against a temporary merged registry (never
# touches the real registry unless --write succeeds).
# ---------------------------------------------------------------------------
rscript <- file.path(R.home("bin"), "Rscript")
candidate_entries <- lapply(candidates, function(c) c$entry)
merged <- c(existing_entries, candidate_entries)

validate_registry <- function(entries) {
  tmp <- tempfile(fileext = ".json")
  on.exit(unlink(tmp), add = TRUE)
  jsonlite::write_json(
    entries,
    tmp,
    auto_unbox = TRUE,
    pretty = TRUE,
    null = "null"
  )
  status <- system2(
    rscript,
    file.path(script_dir, "validate-patches.R"),
    env = c(
      paste0("PATCH_DIR=", file.path(script_dir, "patches")),
      paste0("REGISTRY_FILE=", tmp)
    ),
    stdout = TRUE,
    stderr = TRUE
  )
  cat(paste0("  ", status, "\n"), sep = "")
  identical(attr(status, "status"), NULL) # NULL status attr == exit 0
}

cat("\n", strrep("=", 78L), "\n", sep = "")
cat("Validating candidate registry:\n")
ok <- validate_registry(merged)
if (!ok) {
  stop("Candidate registry failed validation; not writing or proposing.")
}

if (!is.na(json_out)) {
  jsonlite::write_json(
    candidates,
    json_out,
    auto_unbox = TRUE,
    pretty = TRUE,
    null = "null"
  )
  cat(sprintf("Wrote candidate list to %s\n", json_out))
}

# ---------------------------------------------------------------------------
# Actions (default: none)
# ---------------------------------------------------------------------------
now <- format(Sys.time(), "%Y-%m-%d %H:%M:%S")
new_ledger_records <- lapply(candidates, function(c) {
  list(
    package = c$package,
    signature = c$signature,
    tier = c$tier,
    confidence = c$confidence,
    versions = c$entry$versions,
    platforms = as.character(c$entry$platforms),
    proposed_at = now,
    status = "proposed"
  )
})
load_ledger <- function() {
  if (file.exists(ledger_file)) {
    jsonlite::fromJSON(ledger_file, simplifyVector = FALSE)
  } else {
    list()
  }
}
save_ledger <- function(led) {
  jsonlite::write_json(
    led,
    ledger_file,
    auto_unbox = TRUE,
    pretty = TRUE,
    null = "null"
  )
}

if (do_write) {
  jsonlite::write_json(
    merged,
    registry_file,
    auto_unbox = TRUE,
    pretty = TRUE,
    null = "null"
  )
  save_ledger(merge_ledger(load_ledger(), new_ledger_records))
  cat(sprintf(
    "\nWrote %d entries to %s and updated %s.\n",
    length(candidate_entries),
    registry_file,
    ledger_file
  ))
  cat(
    "Next: run the acceptance-gate trial build(s), then commit and open a PR.\n"
  )
} else if (do_issue) {
  forgejo_token <- Sys.getenv("FORGEJO_TOKEN")
  if (nchar(forgejo_token) == 0L) {
    stop("--open-issue requires FORGEJO_TOKEN.")
  }
  suppressPackageStartupMessages(library(httr2, quietly = TRUE))
  forgejo_base <- "https://git.devxy.io/api/v1"
  repo <- "devxy/build-cran-binaries"
  issue_title <- "Auto-proposed registry patches (classifier #115)"
  body_lines <- c(
    sprintf("_Generated %s from `single_builds` failures._", now),
    "",
    "The failure classifier proposes these registry entries for packages with no current entry.",
    "Each is a known, safe fix lever; **review, trial-build, and open a PR** -- nothing is applied automatically.",
    ""
  )
  for (c in candidates) {
    j <- jsonlite::toJSON(
      c$entry,
      auto_unbox = TRUE,
      pretty = TRUE,
      null = "null"
    )
    body_lines <- c(
      body_lines,
      sprintf(
        "### %s (%s, %s confidence)",
        c$package,
        c$signature,
        c$confidence
      ),
      "",
      "```json",
      as.character(j),
      "```",
      sprintf(
        "Acceptance gate: `PGPASS=... Rscript local/trial-build-patch.R %s`",
        c$package
      ),
      ""
    )
  }
  new_body <- paste(body_lines, collapse = "\n")

  search_url <- sprintf(
    "%s/repos/%s/issues?type=issues&state=open&q=%s&limit=50",
    forgejo_base,
    repo,
    utils::URLencode(issue_title, reserved = TRUE)
  )
  existing <- httr2::request(search_url) |>
    httr2::req_headers(Authorization = paste("token", forgejo_token)) |>
    httr2::req_perform() |>
    httr2::resp_body_json(simplifyVector = FALSE)
  match_idx <- which(vapply(
    existing,
    function(x) identical(x$title, issue_title),
    logical(1L)
  ))
  if (length(match_idx) > 0L) {
    num <- existing[[match_idx[1]]]$number
    httr2::request(sprintf("%s/repos/%s/issues/%d", forgejo_base, repo, num)) |>
      httr2::req_headers(
        Authorization = paste("token", forgejo_token),
        `Content-Type` = "application/json"
      ) |>
      httr2::req_body_json(list(body = new_body)) |>
      httr2::req_method("PATCH") |>
      httr2::req_perform()
    cat(sprintf("Updated tracking issue #%d.\n", num))
  } else {
    created <- httr2::request(sprintf(
      "%s/repos/%s/issues",
      forgejo_base,
      repo
    )) |>
      httr2::req_headers(
        Authorization = paste("token", forgejo_token),
        `Content-Type` = "application/json"
      ) |>
      httr2::req_body_json(list(title = issue_title, body = new_body)) |>
      httr2::req_perform() |>
      httr2::resp_body_json()
    cat(sprintf("Opened tracking issue #%d.\n", created$number))
  }
  save_ledger(merge_ledger(load_ledger(), new_ledger_records))
} else {
  cat(
    "\nDry run: no changes made. Re-run with --write or --open-issue to act.\n"
  )
}