R/github_release.R

In richfitz/datastorr: Simple Data Versioning

##' Create a github release for your package.  This tries very hard to
##' do the right thing but it's not always straightforward.  It first
##' looks for your package.  Then it will work out what your last
##' commit was (if \code{target} is NULL), the version of the package
##' (from the DESCRIPTION).  It then creates a release on GitHub with
##' the appropriate version number and uploads the file
##' \code{filename} to the release.  The version number in the
##' DESCRIPTION must be greater than the highest version number on
##' GitHub.
##'
##' This function requires a system git to be installed and on the
##' path.  The version does not have to be particularly recent.
##'
##' This function also requires the \code{GITHUB_TOKEN} environment
##' variable to be set, and for the token to be authorised to have
##' write access to your repositories.
##'
##' @title Create a github release
##'
##' @param info Result of running \code{github_release_info}
##'
##' @param description Optional text description for the release.  If
##'   this is omitted then GitHub will display the commit message from
##'   the commit that the release points at.
##'
##' @param filenames Filename to upload; optional if in \code{info}.
##'   If listed in \code{info}, \code{filename} can be different but
##'   the file will be renamed to \code{info$filename} on uploading.
##'   If given but not in \code{info}, the uploaded file will be
##'   \code{basename(filename)} (i.e., the directory will be
##'   stripped).
##'
##' @param target Target of the release.  This can be either the name
##'   of a branch (e.g., \code{master}, \code{origin/master}),
##'   existing tag \emph{without a current release} or an SHA of a
##'   commit.  It is an error if the commit that this resolves to
##'   locally is not present on GitHub (e.g., if your branch is ahead
##'   of GitHub).  Push first!
##'
##' @param ignore_dirty Ignore non-checked in files?  By default, your
##'   repository is expected to be in a clean state, though files not
##'   known to git are ignored (as are files that are ignored by git).
##'   But you must have no uncommited changes or staged but uncommited
##'   files.
##'   
##' @param  binary Arguement to determine whether to upload binaries, 
##'   or default to the source code generated in a version. If \code{binary}
##'   is \code{FALSE}, users can only pull \code{Source.zip} for that
##'   particular version.
##'
##' @param yes Skip the confirmation prompt?  Only prompts if
##'   interactive.
##'
##' @export
github_release_create <- function(info, description = NULL, filenames = NULL,
                                  target = NULL, ignore_dirty = FALSE, binary = TRUE, 
                                  yes = !interactive()) {
  if(binary) {
    if (is.null(filenames)) {
      if (is.null(info$filenames)) {
        stop("list of filenames must be given")
      }
      filenames <- info$filenames
    }
    ## resolve abbreviated filenames 
    resolved_filenames <- verify_files(filenames)
    info$filenames <- resolved_filenames
    fill_info_files(info, resolved_filenames)
  }

  dat <- github_release_package_info(info, target)

  github_release_create_(info, dat, resolved_filenames, binary, version, description,
                         ignore_dirty, yes)
}

github_release_create_ <- function(info, dat, filename, binary, version, description,
                                   ignore_dirty, yes) {
  if(binary) {
    
    ftarget <- if (is.null(info$filename)) basename(filename) else info$filename
    
    ## TODO: will this fail in the case where info$filename is null?
    msg_file <- sprintf("  file: %s (as %s) %.2f KB", filename, ftarget,
                        file.info(filename)$size / 1024)
  }
  
  github_release_preflight(dat, ignore_dirty)

  ## This is the complicated bit of the message; enough context to
  ## know if the message looks good.
  msg_at <- c("  at:",
              paste0("    sha: ", dat$sha_remote$sha),
              paste0("    date: ", dat$sha_remote$committer$date),
              paste0("    message: ",
                     paste(dat$sha_remote$message, collapse = "\n")),
              paste0("    by: ",
                     sprintf("%s <%s>",
                     dat$sha_remote$committer$name,
                     dat$sha_remote$committer$email)))

  version <- add_v(dat$version_local)
  target <- dat$sha_local

  message("Will create release:")
  message("  tag: ", version)
  message(paste(msg_at, collapse = "\n"))
  if(binary) message(msg_file)
  message("  description: ",
          if (is.null(description)) "(no description)" else description)

  if (!yes && !prompt_confirm()) {
    stop("Not creating release")
  }

  ret <- github_api_release_create(info, version, description, target)
  
  ## TODO: loop this to upload multiple files
  if(binary) {
    asset = list()
    for(index in 1:length(filename)) {
      asset[index] <- list(github_api_release_upload(info, version,filename[index], info$filename[index]))
    }
    ret$assets <- asset
  } 

  message("Created release!")
  message("Please check the page to make sure everything is OK:\n",
          ret$html_url)
  if (interactive() && !yes && prompt_confirm("Open in browser?")) {
    utils::browseURL(ret$html_url)
  }
  invisible(ret)
}

github_release_package_info <- function(info, sha_local = NULL,
                                        version = NULL) {
  ## This can be done with either system commands or with git2r.  Not
  ## entirely sure which is the least bad way of doing it.
  git <- Sys.which("git")
  if (git == "") {
    stop("Need a system git to create releases: http://git-scm.com")
  }

  if (is.null(version)) {
    git_root <- system2(git, c("rev-parse", "--show-toplevel"), stdout = TRUE)
    pkg_root <- find_package_root(git_root)
    dcf <- as.list(read.dcf(file.path(pkg_root, "DESCRIPTION"))[1,])
    version_local <- dcf$Version
  } else {
    version_local <- version
  }
  version_remote <- github_release_version_current(info, FALSE)

  if (is.null(sha_local)) {
    sha_local <- system2(git, c("rev-parse", "HEAD"), stdout = TRUE)
  } else {
    err <- tempfile()
    on.exit(file.remove(err))
    res <- suppressWarnings(
      system2(git, c("rev-parse", sha_local), stdout = TRUE, stderr = err))
    code <- attr(res, "status", exact = TRUE)
    if (!is.null(code) && code != 0L) {
      stop(paste(c("Did not find sha in local git tree: ", readLines(err)),
                 collapse = "\n"))
    }
    sha_local <- as.character(res)
  }
  sha_remote <- tryCatch(github_api_commit(info, sha_local),
                         error = function(e) NULL)

  status <- system2(git, c("status", "--porcelain", "--untracked-files=no"),
                    stdout = TRUE)
  dirty <- length(status) > 0L

  nversion_local <- numeric_version(version_local)
  if (is.null(version_remote)) {
    nversion_remote <- NULL
  } else {
    nversion_remote <- numeric_version(strip_v(version_remote))
  }

  list(version_local = version_local,
       version_remote = version_remote,
       nversion_local = nversion_local,
       nversion_remote = nversion_remote,
       sha_local = sha_local,
       sha_remote = sha_remote,
       status = status,
       dirty = dirty)
}

github_release_preflight <- function(dat, ignore_dirty = FALSE) {
  if (is.null(dat$sha_remote)) {
    stop(sprintf("Could not resolve sha %s on remote", dat$sha_local))
  }

  if (dat$dirty && !ignore_dirty) {
    msg <- paste(c("Local git is dirty (untracked files ignored):",
                   dat$status), collapse = "\n")
    stop(msg)
  }

  if (!is.null(dat$nversion_remote) &&
       dat$nversion_remote >= dat$nversion_local) {
    stop(sprintf("Local version (%s) is not ahead of remote version (%s)",
                 dat$version_local, dat$version_remote))
  }
}