my-emacs-d/elpa/magithub-20161013.2332/magithub-ci.el
Gergely Polonkai 5feea2e7f0 Update magithub
2016-10-14 12:22:53 +02:00

295 lines
11 KiB
EmacsLisp

;;; magithub-ci.el --- Show CI status as a magit-status header -*- lexical-binding: t; -*-
;; Copyright (C) 2016 Sean Allred
;; Author: Sean Allred <code@seanallred.com>
;; Keywords: tools
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; Provide the CI status of "origin" in the Magit status buffer.
;;; Code:
(require 'magit)
(require 'magit-section)
(require 'magit-popup)
(require 'dash)
(require 'magithub-core)
(require 'magithub-cache)
(defconst magithub-ci-status-symbol-alist
'(("" . success)
("" . failure) ; also means `error'... gross
("" . pending))
"Because hub 2.3 is silly and does silly things.
Reference: https://github.com/github/hub/blob/master/commands/ci_status.go#L107")
(defconst magithub-ci-status-regex
(rx bos
(group any) (* any) "\t"
(group (* any)) "\t"
(? (group (* any))) eos))
(defvar magithub-ci-urls nil
"An alist mapping of repositories to CI urls.")
(defun magithub-ci-enabled-p ()
"Non-nil if CI is enabled for this repository.
If magithub.ci.enabled is not set, CI is considered to be enabled."
(when (member (magit-get "magithub" "ci" "enabled") '(nil "yes")) t))
(defun magithub-ci-disable ()
"Disable CI for this repository."
(magit-set "no" "magithub" "ci" "enabled"))
(defun magithub-ci-enable ()
"Enable CI for this repository."
(magit-set "yes" "magithub" "ci" "enabled"))
(defun magithub-maybe-insert-ci-status-header ()
"If this is a GitHub repository, insert the CI status header."
(when (and (magithub-ci-enabled-p)
(magithub-usable-p))
(magithub-insert-ci-status-header)))
(defun magithub-ci-toggle ()
"Toggle CI integration."
(interactive)
(if (magithub-ci-enabled-p)
(magithub-ci-disable)
(magithub-ci-enable))
(when (derived-mode-p 'magit-status-mode)
(magit-refresh)))
(magit-define-popup-action 'magithub-dispatch-popup
?~ "Toggle CI for this repository" #'magithub-ci-toggle ?`)
(defun magithub-ci-status ()
"One of 'success, 'error, 'failure, 'pending, or 'no-status."
(unless (string-equal (magit-rev-parse "HEAD")
(magithub-ci-status-current-commit))
(magithub-cache-clear (magithub-repo-id) :ci-status))
(let ((cached-val (magithub-cache-value (magithub-repo-id) :ci-status)))
(if (and (consp cached-val) (eq (plist-get (car cached-val) :status) 'success))
cached-val
(magithub-cache (magithub-repo-id) :ci-status
'(magithub-ci-status--internal)))))
(defun magithub-ci-status-current-commit (&optional new-value)
"The commit our cached value corresponds to."
(let ((keys (list "magithub" "ci" "lastCommit")))
(if new-value (apply #'magit-set new-value keys)
(apply #'magit-get keys))))
(defun magithub-ci-status--parse-2.2.8 (output)
"Backwards compatibility for old versions of hub.
See `magithub-ci-status--parse'."
(-when-let (matches (cdr (s-match (rx bos (group (+ (any alpha space)))
(? ": " (group (+ (not (any " "))))) eos)
output)))
(list (list :status (intern (replace-regexp-in-string
"\s" "-" (car matches)))
:url (cadr matches)))))
(defun magithub-ci-status--internal (&optional for-commit)
"One of 'success, 'error, 'failure, 'pending, or 'no-status."
(let* ((current-commit (magit-rev-parse "HEAD"))
(last-commit (or for-commit current-commit))
(output (magithub--command-output "ci-status" `("-v" ,last-commit))))
(-if-let (checks (if (magithub-hub-version-at-least "2.3")
(magithub-ci-status--parse output)
(magithub-ci-status--parse-2.2.8 (car output))))
(let ((overall-status (car checks)))
(prog1 (or (and (plist-get overall-status :status) checks) 'no-status)
(if (not (or for-commit (plist-get overall-status :status)))
(let ((last-commit (magithub-ci-status--last-commit)))
(unless (string-equal current-commit last-commit)
(magithub-ci-status--internal last-commit))
(magithub-ci-status-current-commit current-commit))
(magithub-ci-status-current-commit current-commit))))
(beep)
(setq magithub-hub-error
(message
(concat "Hub didn't have any recognizable output for \"ci-status\"!\n"
"Are you connected to the internet?\n"
"Consider submitting an issue to github/hub.")))
'internal-error)))
(defun magithub-ci-status--parse (output)
"Parse a string OUTPUT into a list of statuses.
The first status will be an `overall' status."
(let ((statuses (mapcar #'magithub-ci-status--parse-line output))
(get-status (lambda (status) (lambda (s) (eq (plist-get s :status) status)))))
(cons
(list :check 'overall
:status
(cond
((-all? (funcall get-status 'success) statuses) 'success)
((-some? (funcall get-status 'pending) statuses) 'pending)
((-some? (funcall get-status 'error) statuses) 'error)
((-some? (funcall get-status 'failure) statuses) 'failure)))
statuses)))
(defun magithub-ci-status--parse-line (line)
"Parse a single LINE of status into a status plist."
(-if-let (matches (cdr (s-match magithub-ci-status-regex line)))
(list :status (cdr (assoc (car matches) magithub-ci-status-symbol-alist))
:url (car (cddr matches))
:check (cadr matches))
(if (string= line "no-status")
'no-status
(if (string= line "") 'no-output))))
(defun magithub-ci-status--last-commit ()
"Find the commit considered to have the current CI status.
Right now, this finds the most recent commit without
[ci skip]
or
[skip ci]
in the commit message.
See the following resources:
- https://docs.travis-ci.com/user/customizing-the-build#Skipping-a-build
- https://circleci.com/docs/skip-a-build/"
(let* ((args '("--invert-grep"
"--grep=\\[ci skip\\]"
"--grep=\\[skip ci\\]"
"--format=oneline"
"--max-count=1"))
(output (magit-git-lines "log" args)))
(car (split-string (car output)))))
(defvar magithub-ci-status-alist
'((no-status . "None")
(error . "Error")
(internal-error . magithub-ci--hub-error-string)
(failure . "Failure")
(pending . "Pending")
(success . "Success")))
(defun magithub-ci--hub-error-string ()
"Internal error string."
(format "Internal error!\n%s" magithub-hub-error))
(defface magithub-ci-no-status
'((((class color)) :inherit magit-dimmed))
"Face used when CI status is `no-status'."
:group 'magithub-faces)
(defface magithub-ci-error
'((((class color)) :inherit magit-signature-untrusted))
"Face used when CI status is `error'."
:group 'magithub-faces)
(defface magithub-ci-pending
'((((class color)) :inherit magit-signature-untrusted))
"Face used when CI status is `pending'."
:group 'magithub-faces)
(defface magithub-ci-success
'((((class color)) :inherit magit-signature-good))
"Face used when CI status is `success'."
:group 'magithub-faces)
(defface magithub-ci-failure
'((((class color)) :inherit magit-signature-bad))
"Face used when CI status is `'"
:group 'magithub-faces)
(defface magithub-ci-unknown
'((((class color)) :inherit magit-signature-untrusted))
"Face used when CI status is `unknown'."
:group 'magithub-faces)
(defun magithub-ci-visit ()
"Browse the CI.
Sets up magithub.ci.url if necessary."
(interactive)
(let* ((checks (magithub-ci-status))
(checks-alist
(magithub--zip
checks
(if (magithub-hub-version-at-least "2.3")
(lambda (c)
(format "%S: %s"
(plist-get c :status)
(plist-get c :check)))
:status)
:url))
(target-url
(if (= 1 (length checks-alist))
(cdar checks-alist)
(when checks-alist
(cdr (assoc (completing-read "CI Service: " checks-alist)
checks-alist))))))
(when (or (null target-url) (string= "" target-url))
(user-error "No CI URL detected"))
(browse-url target-url)))
(defvar magit-magithub-ci-status-section-map
(let ((map (make-sparse-keymap)))
(define-key map [remap magit-visit-thing] #'magithub-ci-visit)
(define-key map [remap magit-refresh] #'magithub-ci-refresh)
map)
"Keymap for `magithub-ci-status' header section.")
(defun magithub-ci-refresh ()
"Invalidate the CI cache and refresh the buffer."
(interactive)
(magithub-cache-clear (magithub-repo-id) :ci-status)
(when (derived-mode-p 'magit-status-mode)
(magit-refresh)))
(defun magithub-insert-ci-status-header ()
(let* ((checks (magithub-ci-status))
(status (if (consp checks) (plist-get (car checks) :status) checks))
(face (intern (format "magithub-ci-%s"
(symbol-name status))))
(status-val (cdr (assq status magithub-ci-status-alist))))
(magit-insert-section (magithub-ci-status)
(insert (format "%-10s" "CI: "))
(insert (propertize
(cond
((stringp status-val) status-val)
((functionp status-val) (funcall status-val))
(t (format "%S" status-val)))
'face (if (facep face) face 'magithub-ci-unknown)))
(when (and (consp checks) (not (eq status 'success)) (< 1 (length checks)))
(let* ((successes (-filter (lambda (c) (eq (plist-get c :status) 'success))
checks))
(numsuccesses (length successes))
(numchecks (length checks)))
(insert
(format " %d succeeded; %d did not; %s for details"
numsuccesses
(- numchecks numsuccesses)
(substitute-command-keys "\\[magit-visit-thing]")))))
(insert ?\n))))
(magithub--deftoggle magithub-toggle-ci-status-header
magit-status-headers-hook #'magithub-maybe-insert-ci-status-header "the CI header")
(when (executable-find magithub-hub-executable)
(magithub-toggle-ci-status-header))
(provide 'magithub-ci)
;;; magithub-ci.el ends here