Get bioconductor HEAD commits

bioc.R

library(curl)
library(yaml)

parse_raw_gitpack <- function(buf){
  con <- rawConnection(buf)
  on.exit(close(con))
  txt <- readLines(con, warn = FALSE)
  stopifnot(grepl('^[0-9a-f]{4}#', txt[1]))
  stopifnot(grepl('service=', txt[1]))
  if(length(txt) == 2 && txt[2] == '00000000'){
    return(NULL) #empty repo
  }
  stopifnot(utils::tail(txt, 1) == '0000')
  refs <- utils::head(txt, -1)
  if(grepl("git-upload-pack0000", txt[1])){
    # bitbucket.org seems to omit LF after 1st line
    refs[1] <- sub('.*git-upload-pack', "", refs[1])
  } else {
    refs <- utils::tail(refs, -1)
  }
  refs[1] <- sub("^0000", "", refs[1])
  substring(refs, 5)
}

remote_heads_many <- function(repos, refs = NULL, verbose = TRUE){
  pool <- curl::multi_set(multiplex = FALSE) # use default pool
  len <- length(repos)
  out <- rep(NA_character_, len)
  completed <- 0
  lapply(seq_len(len), function(i){
    k <- i
    url <- sprintf('%s/info/refs?service=git-upload-pack', repos[i])
    ref <- ifelse(length(refs) && !is.na(refs[i]), refs[i], "HEAD")
    h <- curl::new_handle(useragent = 'git/2.35.1.windows.2', failonerror = TRUE)
    curl::curl_fetch_multi(url, handle = h, done = function(res){
      txt <- parse_raw_gitpack(res$content)
      if(!length(txt)){
        message("Failed to get HEAD ref: ", repos[i])
        return()
      }
      pattern <- ifelse(ref=='HEAD', 'HEAD$', sprintf("\\/%s$", ref))
      match <- grep(pattern, txt, value = TRUE)
      out[k] <<- ifelse(length(match), sub(" .*$", "", match), NA_character_)
      
      # In case of annotated tags, we actually need the dereferenced ^{} value
      if(!identical(ref, 'HEAD')){
        match <- grep(sprintf('refs/tags/%s^{}', ref), txt, fixed = TRUE, value = TRUE)
        if(length(match)){
          out[k] <<- sub(" .*$", "", match)
        }
      }
      
      if(verbose) {
        completed <<- completed + 1
        if((len-completed) %% 100 == 0)
          cat(sprintf("\rScanning for changes... %d/%d", as.integer(completed), as.integer(len)), file = stderr())
      }
    }, fail = message, pool = pool)
  })
  curl::multi_run(pool = pool)
  cat("\n", file = stderr())
  out
}

get_bioc_heads <- function(){
  yml <- yaml::read_yaml("https://bioconductor.org/config.yaml")
  bioc_version <- yml$devel_version
  bioc <- jsonlite::read_json(sprintf('https://bioconductor.org/packages/json/%s/bioc/packages.json', bioc_version))
  repos <- names(bioc)
  heads <- remote_heads_many(paste0("https://git.bioconductor.org/packages/", repos))
  data.frame(repos = repos, heads = heads)
}

bioc_heads <- get_bioc_heads()