build-cran-binaries/local/weekly-missing-binaries-audit.R

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

suppressPackageStartupMessages(library(data.table))
library(DBI, quietly = TRUE)
library(RPostgres, quietly = TRUE)
library(s3fs, quietly = TRUE)
library(jsonlite, quietly = TRUE)
library(httr2, quietly = TRUE)

# ---------------------------------------------------------------------------
# Environment / config
# ---------------------------------------------------------------------------
platform <- Sys.getenv("PLATFORM")
arch <- Sys.getenv("ARCH")

if (nchar(platform) == 0) {
  stop("PLATFORM env var is not set")
}
if (nchar(arch) == 0) {
  stop("ARCH env var is not set")
}

# Map platform names to S3 codenames
s3_codename <- gsub("-", "", platform)
s3_codename <- sub("^redhat", "rhel", s3_codename)
s3_codename <- sub("^ubuntu2204$", "jammy", s3_codename)
s3_codename <- sub("^ubuntu2404$", "noble", s3_codename)

# Derive OS family for the Forgejo issue title
os_family <- if (grepl("^ubuntu", platform)) {
  "Ubuntu"
} else if (grepl("^alpine", platform)) {
  "Alpine"
} else if (grepl("^redhat", platform)) {
  "Red Hat"
} else {
  platform
}

cat(sprintf(
  "Platform: %s | Arch: %s | S3 codename: %s | OS family: %s\n",
  platform,
  arch,
  s3_codename,
  os_family
))

# ---------------------------------------------------------------------------
# 1. Query PostgreSQL for known build failures (before s3fs init to avoid
#    C++ pointer conflicts between s3fs/curl and RPostgres/libpq)
# ---------------------------------------------------------------------------
cat("Connecting to PostgreSQL...\n")
con <- DBI::dbConnect(
  RPostgres::Postgres(),
  dbname = "build_metadata",
  host = "r-binaries.devxy.io",
  port = 15432,
  user = "rpkgs",
  password = Sys.getenv("PGPASS"),
  sslmode = "require"
)

errored_pkgs <- DBI::dbGetQuery(
  con,
  sprintf(
    "SELECT name, tag FROM single_builds WHERE error_occurred = TRUE AND platform = '%s' AND arch = '%s'",
    platform,
    arch
  )
)
DBI::dbDisconnect(con)

errored_dt <- as.data.table(errored_pkgs)
if (nrow(errored_dt) > 0) {
  setnames(errored_dt, c("Package", "Version"))
  setkey(errored_dt, Package, Version)
}
cat(sprintf(
  "Found %d known build failures for %s/%s\n",
  nrow(errored_dt),
  platform,
  arch
))

# ---------------------------------------------------------------------------
# 2. CRAN release packages (uses curl internally - must come after PG)
# ---------------------------------------------------------------------------
cat("Fetching CRAN package database...\n")
cran_release <- tools::CRAN_package_db()
cran_dt <- data.table(
  Package = as.character(cran_release$Package),
  Version = as.character(cran_release$Version)
)

# ---------------------------------------------------------------------------
# 3. S3 tarballs
# ---------------------------------------------------------------------------
cat("Connecting to S3...\n")
s3fs::s3_file_system(
  aws_access_key_id = Sys.getenv("B2_S3_ACCESS_KEY"),
  aws_secret_access_key = Sys.getenv("B2_S3_SECRET_KEY"),
  endpoint = "https://s3.eu-central-003.backblazeb2.com",
  region_name = "eu-central-003",
  refresh = TRUE
)

s3_path <- sprintf(
  "devxy-rpkgs-binaries/%s/%s/latest/src/contrib",
  arch,
  s3_codename
)
cat(sprintf("Listing S3 path: %s\n", s3_path))

s3_pkgs <- tryCatch(
  s3fs::s3_dir_ls(s3_path, recurse = FALSE),
  error = function(e) {
    cat(sprintf(
      "WARNING: Could not list S3 path %s: %s\n",
      s3_path,
      conditionMessage(e)
    ))
    character(0)
  }
)

file_names <- basename(s3_pkgs)
matches <- regexec("^([A-Za-z0-9.]+)_([0-9][^/]*)\\.tar\\.gz$", file_names)
parts <- regmatches(file_names, matches)
parts <- parts[sapply(parts, length) == 3]
if (length(parts) == 0) {
  s3_dt <- data.table(Package = character(0), Version = character(0))
} else {
  s3_dt <- data.table(
    Package = sapply(parts, `[`, 2),
    Version = sapply(parts, `[`, 3)
  )
}

cat(sprintf(
  "S3 contains %d tarballs for %s/%s\n",
  nrow(s3_dt),
  arch,
  s3_codename
))

# ---------------------------------------------------------------------------
# 4. Find missing packages (CRAN release version not in S3)
# ---------------------------------------------------------------------------
setkey(cran_dt, Package, Version)
setkey(s3_dt, Package, Version)
missing_dt <- cran_dt[!s3_dt]
cat(sprintf("%d CRAN release packages missing from S3\n", nrow(missing_dt)))

# ---------------------------------------------------------------------------
# 5. Remove excluded packages
# ---------------------------------------------------------------------------
script_dir <- tryCatch(
  dirname(normalizePath(
    if (exists("ofile", envir = sys.frame(1), inherits = FALSE)) {
      sys.frame(1)$ofile
    } else {
      commandArgs(trailingOnly = FALSE)[grepl(
        "--file=",
        commandArgs(trailingOnly = FALSE)
      )] |>
        sub("--file=", "", x = _)
    },
    mustWork = FALSE
  )),
  error = function(e) "local"
)
excluded_path <- file.path(script_dir, "excluded-packages.json")

excluded_pkgs <- data.table(package = character(0), reason = character(0))
if (file.exists(excluded_path)) {
  excluded_raw <- jsonlite::fromJSON(excluded_path)
  excluded_pkgs <- as.data.table(excluded_raw)
  cat(sprintf(
    "Loaded %d excluded packages from %s\n",
    nrow(excluded_pkgs),
    excluded_path
  ))
  missing_dt <- missing_dt[!Package %in% excluded_pkgs$package]
  cat(sprintf(
    "%d packages remain after removing exclusions\n",
    nrow(missing_dt)
  ))
} else {
  cat(sprintf(
    "No excluded-packages.json found at %s -- skipping exclusion step\n",
    excluded_path
  ))
}

# ---------------------------------------------------------------------------
# 6. Split into rebuildable vs known failures
# ---------------------------------------------------------------------------
if (nrow(errored_dt) > 0) {
  known_failures_dt <- missing_dt[errored_dt, nomatch = 0]
  rebuildable_dt <- missing_dt[!errored_dt]
} else {
  known_failures_dt <- missing_dt[0]
  rebuildable_dt <- missing_dt
}

cat(sprintf(
  "Rebuildable: %d | Known failures: %d\n",
  nrow(rebuildable_dt),
  nrow(known_failures_dt)
))

# ---------------------------------------------------------------------------
# 7. Write rebuildable package names to cache RDS
# ---------------------------------------------------------------------------
cache_dir <- "/mnt/cache/packages"
cache_file <- file.path(
  cache_dir,
  sprintf("weekly_rebuild_%s_%s.rds", platform, arch)
)

if (dir.exists(cache_dir)) {
  saveRDS(rebuildable_dt$Package, cache_file)
  cat(sprintf(
    "Wrote %d rebuildable packages to %s\n",
    nrow(rebuildable_dt),
    cache_file
  ))
} else {
  cat(sprintf("Cache dir %s does not exist -- skipping RDS write\n", cache_dir))
}

# ---------------------------------------------------------------------------
# 8. Update Forgejo issue
# ---------------------------------------------------------------------------
forgejo_token <- Sys.getenv("FORGEJO_TOKEN")
if (nchar(forgejo_token) == 0) {
  cat("FORGEJO_TOKEN not set -- skipping issue update\n")
} else {
  issue_title <- sprintf(
    "Missing package binaries for latest version (%s)",
    os_family
  )

  n_missing <- nrow(missing_dt)
  n_rebuild <- nrow(rebuildable_dt)

  arch_lines <- sprintf(
    "### %s (%d missing, %d to rebuild)",
    arch,
    n_missing,
    n_rebuild
  )
  if (nrow(rebuildable_dt) > 0) {
    arch_lines <- c(
      arch_lines,
      paste0("- ", rebuildable_dt$Package, " (", rebuildable_dt$Version, ")")
    )
  } else {
    arch_lines <- c(arch_lines, "_None_")
  }
  if (nrow(known_failures_dt) > 0) {
    arch_lines <- c(
      arch_lines,
      "",
      "#### Known build failures",
      paste0(
        "- ",
        known_failures_dt$Package,
        " (",
        known_failures_dt$Version,
        ")"
      )
    )
  }

  build_excluded_footer <- function() {
    if (nrow(excluded_pkgs) == 0) {
      return(character(0))
    }
    entries <- paste(
      paste0(excluded_pkgs$package, " (", excluded_pkgs$reason, ")"),
      collapse = ", "
    )
    c("---", "", "## Excluded packages", entries)
  }

  forgejo_base <- "https://git.devxy.io/api/v1"
  repo <- "devxy/build-cran-binaries"

  search_url <- sprintf(
    "%s/repos/%s/issues?type=issues&state=open&q=%s&limit=50",
    forgejo_base,
    repo,
    utils::URLencode(issue_title, reserved = TRUE)
  )
  search_resp <- httr2::request(search_url) |>
    httr2::req_headers(Authorization = paste("token", forgejo_token)) |>
    httr2::req_perform()

  existing_issues <- httr2::resp_body_json(search_resp, simplifyVector = FALSE)

  match_idx <- which(
    sapply(existing_issues, function(x) x$title) == issue_title
  )

  today_str <- format(Sys.Date(), "%Y-%m-%d")

  if (length(match_idx) > 0) {
    # ---- Update existing issue ----
    issue_number <- existing_issues[[match_idx[1]]]$number
    old_body <- existing_issues[[match_idx[1]]]$body
    if (is.null(old_body)) {
      old_body <- ""
    }

    lines <- strsplit(old_body, "\n", fixed = TRUE)[[1]]

    # Update timestamp
    ts_idx <- which(grepl("^_Last updated:", lines))
    if (length(ts_idx) > 0) {
      lines[ts_idx[1]] <- sprintf("_Last updated: %s_", today_str)
    } else {
      lines <- c(sprintf("_Last updated: %s_", today_str), "", lines)
    }

    plat_header <- sprintf("## %s", platform)

    plat_idx <- which(lines == plat_header)

    if (length(plat_idx) == 0) {
      # Platform section missing -- insert before --- footer
      footer_idx <- which(lines == "---")
      insert_at <- if (length(footer_idx) > 0) {
        footer_idx[length(footer_idx)]
      } else {
        length(lines) + 1
      }

      new_plat_block <- c(sprintf("## %s", platform), "", arch_lines, "")
      lines <- c(
        lines[seq_len(insert_at - 1)],
        new_plat_block,
        lines[seq(insert_at, length(lines))]
      )
    } else {
      pi <- plat_idx[1]

      # End of platform section: next ## or --- at a higher level, or EOF
      next_section <- which(grepl("^## |^---", lines) & seq_along(lines) > pi)
      plat_end <- if (length(next_section) > 0) {
        next_section[1] - 1
      } else {
        length(lines)
      }

      plat_lines <- lines[seq(pi, plat_end)]

      # Arch subsection headers within the platform block (### arm64 / ### amd64).
      # Match by prefix: headers carry a " (N missing, M to rebuild)" suffix, so
      # exact-equality matching never found the existing block and silently
      # appended a duplicate on every run. Remove *all* blocks for this arch
      # (collapsing any previously accumulated duplicates), then write one fresh
      # block, so the issue holds a single current subsection per arch.
      sub_hdr <- which(grepl("^### ", plat_lines))
      arch_re <- sprintf("^### %s( |$)", arch)

      if (length(sub_hdr) == 0) {
        # No arch subsections yet -- append after the platform header/preamble.
        new_plat_lines <- c(plat_lines, "", arch_lines)
      } else {
        preamble <- plat_lines[seq_len(sub_hdr[1] - 1)]
        # Each subsection runs from its ### header to the line before the next
        # ### header (#### known-failures stays inside its own block).
        sub_end <- c(sub_hdr[-1] - 1, length(plat_lines))
        kept <- character(0)
        for (k in seq_along(sub_hdr)) {
          block <- plat_lines[seq(sub_hdr[k], sub_end[k])]
          if (!grepl(arch_re, block[1])) {
            kept <- c(kept, block)
          }
        }
        new_plat_lines <- c(preamble, kept, "", arch_lines)
      }

      tail_lines <- if (plat_end < length(lines)) {
        lines[seq(plat_end + 1, length(lines))]
      } else {
        character(0)
      }
      lines <- c(lines[seq_len(pi - 1)], new_plat_lines, tail_lines)
    }

    # Rebuild excluded footer
    excl_hdr_idx <- which(lines == "## Excluded packages")
    if (length(excl_hdr_idx) > 0) {
      pre_dash <- which(lines == "---" & seq_along(lines) < excl_hdr_idx[1])
      remove_from <- if (length(pre_dash) > 0) {
        pre_dash[length(pre_dash)]
      } else {
        excl_hdr_idx[1]
      }
      lines <- lines[seq_len(remove_from - 1)]
    }
    footer <- build_excluded_footer()
    if (length(footer) > 0) {
      lines <- c(lines, "", footer)
    }

    new_body <- paste(lines, collapse = "\n")

    patch_url <- sprintf(
      "%s/repos/%s/issues/%d",
      forgejo_base,
      repo,
      issue_number
    )
    httr2::request(patch_url) |>
      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 Forgejo issue #%d: %s\n", issue_number, issue_title))
  } else {
    # ---- Create new issue ----
    body_lines <- c(
      sprintf("_Last updated: %s_", today_str),
      "",
      sprintf("## %s", platform),
      "",
      arch_lines
    )
    footer <- build_excluded_footer()
    if (length(footer) > 0) {
      body_lines <- c(body_lines, "", footer)
    }

    post_url <- sprintf("%s/repos/%s/issues", forgejo_base, repo)
    create_resp <- httr2::request(post_url) |>
      httr2::req_headers(
        Authorization = paste("token", forgejo_token),
        `Content-Type` = "application/json"
      ) |>
      httr2::req_body_json(list(
        title = issue_title,
        body = paste(body_lines, collapse = "\n")
      )) |>
      httr2::req_perform()

    new_issue <- httr2::resp_body_json(create_resp)
    cat(sprintf(
      "Created Forgejo issue #%d: %s\n",
      new_issue$number,
      issue_title
    ))
  }
}

cat("Done.\n")