Check URLs

check_urls.R

library(xfun)

#' Check and optionally fix all URLs found under a directory.
#'
#' Scans every file whose MIME type starts with "text/" (as reported by
#' xfun::mime_type()), extracts all http(s) URLs via regex, resolves their
#' final destinations with xfun::url_destination(), and optionally rewrites
#' redirected URLs in place.
check_urls = function(dir = ".", update = FALSE, filter = NULL, ignore = NULL) {
  all_files = list.files(dir, recursive = TRUE, full.names = TRUE)
  if (is.null(filter)) filter = function(f) {
    f[startsWith(mime_type(f), "text/")]
  }
  files = filter(all_files)
  lapply(files, process_urls, update, ignore)
  invisible()
}

process_urls = function(path, update, ignore) {
  lines = read_utf8(path)
  # matches http(s):// URLs; character class covers RFC 3986 unreserved +
  # sub-delimiters + pct-encoded sequences.
  url_re  = "https?://[A-Za-z0-9\\-._~:/?#\\[\\]@!$&'()*+,;=%]+"
  trim_re = "[.,;:!?)>\"'`]+$"   # trailing punctuation artifacts
  m = gregexpr(url_re, lines, perl = TRUE)
  hits = regmatches(lines, m)
  updated = FALSE
  regmatches(lines, m) = lapply(regmatches(lines, m), function(x) {
    urls = sub(trim_re, "", x, perl = TRUE)
    punc = substr(x, nchar(urls) + 1L, nchar(x))
    i = !urls %in% ignore
    dest = urls
    dest[i] = url_destination(urls[i])
    if (any(i <- dest != urls)) {
      updated <<- TRUE
      message("Redirected URLs in ", path, ":\n",
              paste0("  ", urls[i], " -> ", dest[i], collapse = "\n"))
    }
    paste0(dest, punc)
  })
  if (update && updated) write_utf8(lines, path)
}