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]
#                                              [--limit 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)
#       --open-pr        write the entries, push the `auto/registry-patch-proposals`
#                        branch, and open/update a PR autonomously. Uses
#                        FORGEJO_TOKEN for both the push and the PR API. The
#                        `trial-build-registry` pipeline is the merge gate.
#       --limit N        only act on the top-N candidates by failure volume
#                        (bounded batch; the rest are picked up on the next run)
#       --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
do_pr <- "--open-pr" %in% args
limit <- suppressWarnings(as.integer(opt_val("--limit", NA_character_)))

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")
# Branch the autonomous PR reuses, so re-runs update one PR instead of piling up.
pr_branch <- "auto/registry-patch-proposals"

# ---------------------------------------------------------------------------
# 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, carrying the group's
# build volume so we can prioritise the highest-impact fixes.
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,
      build_count = r$build_count,
      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) length(r$blocked_packages) > 0L,
  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$blocked_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)
}

# Prioritise by failure volume, then apply --limit so one run tackles a bounded
# batch (the rest are picked up on the next run).
candidates <- candidates[order(
  -vapply(candidates, function(c) c$build_count %||% 0L, integer(1L))
)]
deferred <- 0L
if (!is.na(limit) && limit >= 0L && length(candidates) > limit) {
  deferred <- length(candidates) - limit
  candidates <- utils::head(candidates, limit)
  cat(sprintf(
    "\nLimiting to top %d candidate(s) by failure volume; %d deferred to a later run.\n",
    limit,
    deferred
  ))
}

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 if (do_pr) {
  forgejo_token <- Sys.getenv("FORGEJO_TOKEN")
  if (nchar(forgejo_token) == 0L) {
    stop("--open-pr requires FORGEJO_TOKEN (to open the PR).")
  }
  suppressPackageStartupMessages(library(httr2, quietly = TRUE))
  forgejo_base <- "https://git.devxy.io/api/v1"
  repo <- "devxy/build-cran-binaries"

  # Write the entries + ledger, then commit them onto the reused auto branch.
  jsonlite::write_json(
    merged,
    registry_file,
    auto_unbox = TRUE,
    pretty = TRUE,
    null = "null"
  )
  save_ledger(merge_ledger(load_ledger(), new_ledger_records))

  git <- function(...) {
    # system2() with captured output runs via /bin/sh, so shell-quote every arg
    # (commit messages contain "()", refs contain "^{}", etc.).
    st <- system2("git", shQuote(c(...)), stdout = TRUE, stderr = TRUE)
    if (!identical(attr(st, "status"), NULL)) {
      stop(sprintf(
        "git %s failed:\n%s",
        paste(..., collapse = " "),
        paste(st, collapse = "\n")
      ))
    }
    invisible(st)
  }
  git("config", "user.name", Sys.getenv("GIT_USER", "devxy-bot"))
  git(
    "config",
    "user.email",
    Sys.getenv("GIT_EMAIL", "bot@devxy.io")
  )
  git("checkout", "-B", pr_branch)
  git(
    "add",
    file.path(script_dir, "patches", "registry.json"),
    ledger_file
  )
  git(
    "commit",
    "-m",
    sprintf(
      "feat(patches): auto-propose %d registry %s from classified failures",
      length(candidate_entries),
      if (length(candidate_entries) == 1L) "entry" else "entries"
    )
  )
  # Push over HTTPS with FORGEJO_TOKEN (same token used for the PR API), so no
  # separate write-scoped secret is needed. The read-only `origin` clone URL
  # can't push, so build an authenticated URL explicitly.
  push_target <- sprintf(
    "https://%s:%s@git.devxy.io/%s.git",
    Sys.getenv("GIT_REMOTE_USER", "pat-s"),
    forgejo_token,
    repo
  )
  git("push", "-f", push_target, sprintf("HEAD:refs/heads/%s", pr_branch))

  pr_title <- sprintf(
    "feat(patches): auto-proposed registry patches (%s)",
    now
  )
  body_lines <- c(
    sprintf(
      "_Auto-generated %s by `local/propose-patches.R --open-pr` from classified `single_builds` failures._",
      now
    ),
    "",
    sprintf(
      "Adds %d known-lever registry %s (top by failure volume%s).",
      length(candidate_entries),
      if (length(candidate_entries) == 1L) "entry" else "entries",
      if (deferred > 0L) {
        sprintf("; %d deferred to a later run", deferred)
      } else {
        ""
      }
    ),
    "",
    "**Merge gate:** the `trial-build-registry` pipeline builds each new entry in its target build-env image; merge only once it is green.",
    "Novel source diffs and unknown signatures are never auto-proposed.",
    "",
    "| package | signature | platforms |",
    "| --- | --- | --- |"
  )
  for (c in candidates) {
    body_lines <- c(
      body_lines,
      sprintf(
        "| %s | %s | %s |",
        c$package,
        c$signature,
        toString(as.character(c$entry$platforms))
      )
    )
  }
  new_body <- paste(body_lines, collapse = "\n")

  # One PR per reused branch: update if open, else create.
  pulls_url <- sprintf(
    "%s/repos/%s/pulls?state=open&limit=50",
    forgejo_base,
    repo
  )
  open_pulls <- httr2::request(pulls_url) |>
    httr2::req_headers(Authorization = paste("token", forgejo_token)) |>
    httr2::req_perform() |>
    httr2::resp_body_json(simplifyVector = FALSE)
  match_idx <- which(vapply(
    open_pulls,
    function(p) identical(p$head$ref, pr_branch),
    logical(1L)
  ))
  if (length(match_idx) > 0L) {
    num <- open_pulls[[match_idx[1]]]$number
    httr2::request(sprintf("%s/repos/%s/pulls/%d", forgejo_base, repo, num)) |>
      httr2::req_headers(
        Authorization = paste("token", forgejo_token),
        `Content-Type` = "application/json"
      ) |>
      httr2::req_body_json(list(title = pr_title, body = new_body)) |>
      httr2::req_method("PATCH") |>
      httr2::req_perform()
    cat(sprintf("\nUpdated auto-patch PR #%d (branch %s).\n", num, pr_branch))
  } else {
    created <- httr2::request(sprintf(
      "%s/repos/%s/pulls",
      forgejo_base,
      repo
    )) |>
      httr2::req_headers(
        Authorization = paste("token", forgejo_token),
        `Content-Type` = "application/json"
      ) |>
      httr2::req_body_json(list(
        title = pr_title,
        head = pr_branch,
        base = "main",
        body = new_body
      )) |>
      httr2::req_perform() |>
      httr2::resp_body_json()
    cat(sprintf(
      "\nOpened auto-patch PR #%d (branch %s).\n",
      created$number,
      pr_branch
    ))
  }
} else {
  cat(
    "\nDry run: no changes made. Re-run with --write, --open-issue, or --open-pr to act.\n"
  )
}