R/steps-git.R

Defines functions step_push_deploy step_do_push_deploy step_setup_push_deploy

Documented in step_do_push_deploy step_push_deploy step_setup_push_deploy

# Git --------------------------------------------------------------------------

Git <- R6Class(
  "Git",
  public = list(
    initialize = function(path) {
      private$path <- path
    },

    cmd = function(...) {
      args <- c(...)
      message(paste("git", paste(args, collapse = " ")))
      status <- withr::with_dir(private$path, system2("git", args))
      if (status != 0) {
        stopc("git exited with status ", status)
      }
    },

    query = function(...) {
      args <- c(...)
      message(paste("git", paste(args, collapse = " ")))
      withr::with_dir(private$path, system2("git", args, stdout = TRUE))
    },

    init_repo = function() {
      message("Initializing Git repo at ", private$path)
      dir.create(private$path, recursive = TRUE, showWarnings = FALSE)
      private$repo <- git2r::init(private$path)
    },

    get_repo = function() {
      private$repo
    }
  ),

  private = list(
    path = NULL,
    repo = NULL
  )
)

# SetupPushDeploy --------------------------------------------------------------

SetupPushDeploy <- R6Class( # nolint
  "SetupPushDeploy",
  inherit = TicStep,


  public = list(
    initialize = function(path = ".",
                          branch = NULL,
                          orphan = FALSE,
                          remote_url = NULL,
                          checkout = TRUE) {
      if (is.null(branch) && orphan) {
        stopc("Cannot orphan the branch that has been used for the CI run.")
      }

      if (is.null(branch) && path != ".") {
        stopc("Must specify branch name if `path` is given.")
      }

      if (path != "." && !checkout && !orphan) {
        stopc(
          "If `checkout` is FALSE and `path` is set, `orphan` must be TRUE."
        )
      }

      if (is.null(branch)) {
        branch <- ci_get_branch()
      }

      if (is.null(remote_url)) {
        remote_url <- paste0("git@github.com:", ci_get_slug(), ".git")
      }

      private$git <- Git$new(path)
      private$branch <- branch
      private$orphan <- orphan
      private$remote_url <- remote_url
      private$checkout <- checkout
    },

    prepare = function() {
      verify_install("git2r")
      super$prepare()
    },

    run = function() {
      private$git$init_repo()
      private$init_author()
      private$fetch()
    }
  ),

  private = list(
    git = NULL,

    branch = NULL,
    orphan = FALSE,
    remote_url = NULL,
    checkout = FALSE,

    repo = NULL,
    remote_name = "tic-remote", # HACK

    init_author = function() {
      latest_commit <- get_head_commit(git2r_head(git2r::repository(".")))
      print(latest_commit)

      latest_author <- git2r_attrib(latest_commit, "author")
      print(latest_author)

      git2r::config(
        private$git$get_repo(),
        user.name = git2r_attrib(latest_author, "name"),
        user.email = git2r_attrib(latest_author, "email")
      )
    },

    fetch = function() {
      remote_name <- private$remote_name

      if (remote_name %in% git2r::remotes(private$git$get_repo())) {
        message("Not overriding existing remote ", remote_name)
      } else {
        message("Adding remote ", remote_name, " with URL ", private$remote_url)
        git2r::remote_add(
          private$git$get_repo(), remote_name, private$remote_url
        )
      }

      message("Setting branch name to ", private$branch)
      private$git$cmd("checkout", "-B", private$branch)

      if (!private$orphan) {
        message("Fetching from remote ", remote_name)
        tryCatch(
          {
            remote_branch <- private$try_fetch()
            if (!is.null(remote_branch)) {
              message("Remote branch is ", remote_branch$name)
              if (private$checkout) {
                git2r::checkout(
                  private$git$get_repo(),
                  private$branch,
                  create = TRUE,
                  force = TRUE
                )
              }
            }
          },
          error = function(e) {
            message(
              conditionMessage(e),
              "\nCould not fetch branch, will attempt to create new"
            )
          }
        )
      }
    },

    try_fetch = function() {
      remote_name <- private$remote_name
      private$git$cmd(
        "fetch", remote_name, paste0("refs/heads/", private$branch)
      )
      branches <- git2r::branches(private$git$get_repo(), "remote")
      branches[[paste0(remote_name, "/", private$branch)]]
    }
  )
)

#' Step: Setup push deploy
#'
#' Clones a repo, inits author information, and sets up remotes
#' for a subsequent [step_do_push_deploy()].
#'
#' @param path `[string]`\cr
#'   Path to the repository, default `"."` which means setting up the current
#'   repository.
#' @param branch `[string]`\cr
#'   Target branch, default: current branch.
#' @param orphan `[flag]`\cr
#'   Create and force-push an orphan branch consisting of only one commit?
#'   This can be useful e.g. for `path = "docs", branch = "gh-pages"`,
#'   but cannot be applied for pushing to the current branch.
#' @param remote_url `[string]`\cr
#'   The URL of the remote Git repository to push to, defaults to the
#'   current GitHub repository.
#' @param checkout `[flag]`\cr
#'   Check out the current contents of the repository? Defaults to `TRUE`,
#'   set to `FALSE` if the build process relies on existing contents or
#'   if you deploy to a different branch.
#'
#' @family deploy steps
#' @family steps
#' @export
#' @examples
#' \dontrun{
#' dsl_init()
#'
#' get_stage("deploy") %>%
#'   add_step(step_setup_push_deploy(path = "docs", branch = "gh-pages")) %>%
#'   add_step(step_build_pkgdown())
#'
#' # This example needs a Git repository
#' if (rlang::is_installed("git2r") && git2r::in_repository()) {
#'   # Deployment only works if a companion step_do_push_deploy() is added
#'   get_stage("deploy") %>%
#'     add_step(step_do_push_deploy(path = "docs"))
#' }
#'
#' dsl_get()
#' }
step_setup_push_deploy <- function(path = ".",
                                   branch = NULL,
                                   orphan = FALSE,
                                   remote_url = NULL,
                                   checkout = TRUE) {
  SetupPushDeploy$new(
    path = path,
    branch = branch,
    orphan = orphan,
    remote_url = remote_url,
    checkout = checkout
  )
}

# DoPushDeploy -----------------------------------------------------------------

DoPushDeploy <- R6Class(
  "DoPushDeploy",
  inherit = TicStep,

  public = list(
    initialize = function(path = ".",
                          commit_message = NULL,
                          commit_paths = ".",
                          force = FALSE) {
      private$git <- Git$new(path)

      if (is.null(commit_message)) {
        commit_message <- private$format_commit_message()
      }
      private$commit_message <- commit_message
      private$commit_paths <- commit_paths
      private$force <- force
    },

    check = function() {
      !ci_is_tag()
    },

    prepare = function() {
      verify_install("git2r")
      super$prepare()
    },

    run = function() {
      private$git$init_repo()
      maybe_orphan <- is.null(git2r_head(private$git$get_repo()))
      if (private$commit()) {
        private$push(force = maybe_orphan)
      }
    }
  ),

  private = list(
    git = NULL,

    commit_message = NULL,
    commit_paths = NULL,

    repo = NULL,
    remote_name = "tic-remote", # HACK
    force = FALSE,

    commit = function() {
      message("Staging: ", paste(private$commit_paths, collapse = ", "))
      git2r::add(private$git$get_repo(),
        private$commit_paths,
        force = private$force
      )

      message("Checking changed files")
      status <- git2r::status(
        private$git$get_repo(),
        staged = TRUE,
        unstaged = FALSE,
        untracked = FALSE,
        ignored = FALSE
      )
      if (length(status$staged) == 0) {
        message("Nothing to commit!")
        return(FALSE)
      }

      message("Committing to ", git2r_attrib(private$git$get_repo(), "path"))
      new_commit <-
        git2r::commit(private$git$get_repo(), private$commit_message)$sha

      local <- git2r_head(private$git$get_repo())
      upstream <- git2r::branch_get_upstream(local)
      if (is.null(upstream)) {
        message("No upstream branch found")
        return(TRUE)
      }

      message("Wiping repository")
      private$git$cmd("checkout .")
      private$git$cmd("clean -fdx")

      message("Pulling new changes")
      private$git$cmd("fetch")

      ## Needed to handle empty commits, pull, rebase or default cherry-pick
      ## have bad default behavior here (#160)
      private$git$cmd("reset", "--hard", git2r::branch_target(upstream))
      private$git$cmd("cherry-pick", "--no-commit", new_commit)
      private$git$cmd("commit", "--no-edit", "--allow-empty")

      c_local <-
        git2r::lookup(private$git$get_repo(), git2r::branch_target(local))
      c_upstream <-
        git2r::lookup(private$git$get_repo(), git2r::branch_target(upstream))

      # FIMXE: Why does this error in https://github.com/mlr-org/mlr3gallery/runs/652401257?check_suite_focus=true#step:20:268
      # ab <- git2r::ahead_behind(c_local, c_upstream)
      # message("Ahead: ", ab[[1]], ", behind: ", ab[[2]])
      # ab[[1]] > 0
      TRUE
    },

    push = function(force) {
      message("Pushing to remote")
      private$git$cmd(
        "push",
        if (force) "--force",
        private$remote_name,
        "HEAD"
      )
    },

    format_commit_message = function() {
      paste0(
        "Deploy from ", ci_get_build_number(), " [ci skip]\n\n",
        if (!is.null(ci_get_build_url())) {
          paste0("Build URL: ", ci_get_build_url(), "\n")
        },
        "Commit: ", ci_get_commit()
      )
    }
  )
)

#' Step: Perform push deploy
#'
#' @description
#' Commits and pushes to a repo prepared by [step_setup_push_deploy()].
#'
#' Deployment usually requires setting up SSH keys with
#' [use_tic()].
#'
#'
#' @details
#' It is highly recommended to restrict the set of files
#' touched by the deployment with the `commit_paths` argument:
#' this step assumes that it can freely overwrite all changes to all files
#' below `commit_paths`, and will not warn in case of conflicts.
#'
#' To mitigate conflicts race conditions to the greatest extent possible,
#' the following strategy is used:
#'
#' - The changes are committed to the branch
#' - Before pushing, new commits are fetched, and the changes are cherry-picked
#'   on top of the new commits
#'
#' If no new commits were pushed after the CI run has started,
#' this strategy is equivalent to committing and pushing.
#' In the opposite case, if the remote repo has new commits,
#' the deployment is safely applied to the current tip.
#'
#' @inheritParams step_setup_push_deploy
#' @param commit_message `[string]`\cr
#'   Commit message to use, defaults to a useful message linking to the CI build
#'   and avoiding recursive CI runs.
#' @param commit_paths `[character]`\cr
#'   Restrict the set of directories and/or files added to Git before deploying.
#'   Default: deploy all files.
#' @param force `[logical]`\cr
#'   Add `--force` flag to git commands?
#'
#' @family deploy steps
#' @family steps
#'
#' @export
#' @examples
#' \dontrun{
#' dsl_init()
#'
#' # Deployment only works if a companion step_setup_push_deploy() is added
#' get_stage("deploy") %>%
#'   add_step(step_setup_push_deploy(path = "docs", branch = "gh-pages")) %>%
#'   add_step(step_build_pkgdown())
#'
#' if (rlang::is_installed("git2r") && git2r::in_repository()) {
#'   get_stage("deploy") %>%
#'     add_step(step_do_push_deploy(path = "docs"))
#' }
#'
#' dsl_get()
#' }
step_do_push_deploy <- function(path = ".",
                                commit_message = NULL,
                                commit_paths = ".",
                                force = FALSE) {
  DoPushDeploy$new(
    path = path,
    commit_message = commit_message,
    commit_paths = commit_paths,
    force = force
  )
}

# PushDeploy -------------------------------------------------------------------

PushDeploy <- R6Class(
  "PushDeploy",
  inherit = TicStep,

  public = list(
    initialize = function(path = ".",
                          branch = ci_get_branch(),
                          remote_url =
                            paste0("git@github.com:", ci_get_slug(), ".git"),
                          commit_message = NULL,
                          commit_paths = ".",
                          force = FALSE) {
      orphan <- (path != ".")

      private$setup <- step_setup_push_deploy(
        path = path,
        branch = branch,
        orphan = orphan,
        remote_url = remote_url,
        checkout = FALSE
      )

      private$do <- step_do_push_deploy(
        path = path,
        commit_message = commit_message,
        commit_paths = commit_paths,
        force = force
      )
    },

    check = function() {
      private$setup$check() && private$do$check()
    },

    prepare = function() {
      private$setup$prepare()
      private$do$prepare()
    },

    run = function() {
      private$setup$run()
      private$do$run()
    }
  ),

  private = list(
    setup = NULL,
    do = NULL
  )
)

# step_push_deploy -------------------------------------------------------------

#' Step: Setup and perform push deploy
#'
#' @description
#' Clones a repo, initializes author information, sets up remotes,
#' commits, and pushes.
#' Combines [step_setup_push_deploy()] with `checkout = FALSE` and
#' a suitable `orphan` argument,
#' and [step_do_push_deploy()].
#'
#' Deployment usually requires setting up SSH keys with
#' [use_tic()].
#'
#' @details
#' Setup and deployment are combined in one step,
#' the files to be deployed must be prepared in a previous step.
#' This poses some restrictions on how the repository can be initialized,
#' in particular for a nonstandard `path` argument only `orphan = TRUE`
#' can be supported (and will be used).
#'
#' For more control, create two separate steps with
#' `step_setup_push_deploy()` and `step_do_push_deploy()`,
#' and create the files to be deployed in between these steps.
#'
#' @inheritParams step_setup_push_deploy
#' @inheritParams step_do_push_deploy
#'
#' @family deploy steps
#' @family steps
#'
#' @export
#' @examples
#' \dontrun{
#' dsl_init()
#'
#' get_stage("script") %>%
#'   add_step(step_push_deploy(commit_paths = c("NAMESPACE", "man")))
#'
#' dsl_get()
#' }
step_push_deploy <- function(path = ".",
                             branch = NULL,
                             remote_url = NULL,
                             commit_message = NULL,
                             commit_paths = ".",
                             force = FALSE) {
  PushDeploy$new(
    path = path,
    branch = branch,
    remote_url = remote_url,
    commit_message = commit_message,
    commit_paths = commit_paths,
    force = force
  )
}
ropensci/tic documentation built on Jan. 18, 2024, 3:57 a.m.