├── README.md ├── build-status.el ├── example-failing.png ├── example-passing.png └── example-running.png /README.md: -------------------------------------------------------------------------------- 1 | # build-status 2 | 3 | Emacs minor mode that shows a buffer's build status in the mode line. 4 | 5 | ![build-status example running](example-running.png) 6 | ![build-status example passing](example-passing.png) 7 | ![build-status example failing](example-failing.png) 8 | 9 | ## Installation 10 | 11 | From MELPA 12 | 13 | Run `M-x package-install` `build-status` 14 | 15 | Manual installation 16 | 17 | Add `build-status.el`'s directory to `load-path` 18 | 19 | ```el 20 | (require 'build-status) 21 | (put 'build-status-mode-line-string 'risky-local-variable t) 22 | ``` 23 | 24 | ## Usage 25 | 26 | `M-x build-status-mode` in a buffer that's part of a CI project. 27 | 28 | By default the build status will be checked every 5 minutes. To change this 29 | set `build-status-check-interval` to the desired interval, in seconds. 30 | 31 | API tokens can be set via the service-specific variable (see below) or via `git config`: 32 | 33 | ``` 34 | git config --add build-status.api-token TOKEN 35 | ``` 36 | 37 | To open the CI service's web page for buffer's build click on the mode's lighter or 38 | run `M-x build-status-open`. 39 | 40 | ## Status Mapping 41 | 42 | `build-status` will try to convert the CI service's status to one of the following: 43 | 44 | * failed 45 | * passed 46 | * queued 47 | * running 48 | 49 | This is done via the service's status mapping alist. 50 | 51 | If the status is not mapped it's treated as unknown (lighter is `"?"` and mouseover shows 52 | the status as is). You can ignore a status by mapping it to the symbol `ignored`. 53 | 54 | See the [Supported Services section](#supported-services) below for more information. 55 | 56 | ## Status Mode Line Faces 57 | 58 | Each status indicator has an associated face. They're are listed below. 59 | 60 | If you'd like to change the color and/or style of an indicator just 61 | [update the appropriate face](https://www.gnu.org/software/emacs/manual/html_node/elisp/Attribute-Functions.html#Attribute-Functions). 62 | 63 | You can add a face for an unsupported status by creating a face named `build-status-STATUS-face` where `STATUS` is the name of the 64 | status with non-word characters replaced by "-". 65 | 66 | ### `build-status-face` 67 | 68 | All faces inherit from this face. 69 | 70 | Attributes: none 71 | 72 | ### `build-status-failed-face` 73 | 74 | Attributes: `:background "red"` 75 | 76 | ### `build-status-passed-face` 77 | 78 | Attributes: `:background "green"` 79 | 80 | ### `build-status-queued-face` 81 | 82 | Attributes: `:background "yellow"` 83 | 84 | ### `build-status-running-face` 85 | 86 | Attributes: `:background "yellow"` 87 | 88 | ### `build-status-unknown-face` 89 | 90 | Used when the build status returns an unknown value. For more info see [status mapping](#status-mapping). 91 | 92 | Attributes: none 93 | 94 | ## Supported Services 95 | 96 | ### CircleCI 97 | 98 | The buffer's directory or one of its ancestors must contain a `circle.yml` file or `.circleci` directory. 99 | 100 | To set a token (but also see [`git config` tokens](#usage)): 101 | 102 | ```el 103 | (setq build-status-circle-ci-token "YOUR-TOKEN") 104 | ``` 105 | 106 | Status mapping is controlled via `build-status-circle-ci-status-mapping-alist`. It 107 | defaults to: 108 | 109 | ```el 110 | '(("infrastructure_fail" . "failed") 111 | ("not_running" . "queued") 112 | ("success" . "passed") 113 | ("scheduled" . "queued") 114 | ("timedout" . "failed")) 115 | ``` 116 | 117 | ### Travis CI 118 | 119 | The buffer's directory or one of its ancestors must contain a `.travis.yml` file. 120 | 121 | To set a token (but also see [`git config` tokens](#usage)): 122 | 123 | ```el 124 | (setq build-status-travis-ci-token "YOUR-TOKEN") 125 | ``` 126 | 127 | Status mapping is controlled via `build-status-travis-ci-status-mapping-alist`. It 128 | defaults to: 129 | 130 | ```el 131 | '(("errored" . "failed") 132 | ("started" . "running") 133 | ("created" . "queued")) 134 | ``` 135 | 136 | By default, the open source Travis CI (travis-ci.org) is used. To use the pro or 137 | enterprise versions, set the `build-status-travis-ci-domain` variable to 138 | `travis-ci.com`, or the domain of your enterprise instance. If you have projects 139 | in both, [directory 140 | variables](https://www.gnu.org/software/emacs/manual/html_node/emacs/Directory-Variables.html#Directory-Variables) 141 | are a good way to set up domain and token on a per-project basis. 142 | 143 | ## TODOs 144 | 145 | * Support for Enterprise GitHub 146 | * Support for VCS mode hooks 147 | * Support for AppVeyor 148 | 149 | ## See Also 150 | 151 | * [jenkins-watch](https://github.com/ataylor284/jenkins-watch) 152 | * [github-notifier](https://github.com/xuchunyang/github-notifier.el) 153 | 154 | ## Author 155 | 156 | Skye Shaw [skye.shaw AT gmail.com] 157 | -------------------------------------------------------------------------------- /build-status.el: -------------------------------------------------------------------------------- 1 | ;;; build-status.el --- Mode line build status indicator -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2017 Skye Shaw 4 | ;; Author: Skye Shaw 5 | ;; Version: 0.0.3 (unreleased) 6 | ;; Keywords: mode-line, ci, circleci, travis-ci 7 | ;; Package-Requires: ((cl-lib "0.5")) 8 | ;; URL: http://github.com/sshaw/build-status 9 | 10 | ;; This file is NOT part of GNU Emacs. 11 | 12 | ;;; License: 13 | 14 | ;; This program is free software: you can redistribute it and/or modify 15 | ;; it under the terms of the GNU General Public License as published by 16 | ;; the Free Software Foundation, either version 3 of the License, or 17 | ;; (at your option) any later version. 18 | 19 | ;; This program is distributed in the hope that it will be useful, 20 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 21 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 22 | ;; GNU General Public License for more details. 23 | 24 | ;; You should have received a copy of the GNU General Public License 25 | ;; along with this program. If not, see . 26 | 27 | ;;; Commentary: 28 | 29 | ;; Global minor mode that shows a buffer's build status in the mode line. 30 | 31 | ;;; Change Log: 32 | 33 | ;; 2017-10-31 - v0.0.2 34 | ;; * Add support for CircleCI 2.0 35 | 36 | ;;; Code: 37 | 38 | (require 'cl-lib) 39 | (require 'json) 40 | (require 'url) 41 | 42 | (defvar build-status-check-interval 300 43 | "Interval at which to check the build status. Given in seconds, defaults to 300.") 44 | 45 | (defvar build-status-circle-ci-token nil 46 | "CircleCI API token. 47 | The API token can also be sit via: `git config --add build-status.api-token`.") 48 | 49 | (defvar build-status-travis-ci-token nil 50 | "Travis CI API token. 51 | The API token can also be sit via: `git config --add build-status.api-token`.") 52 | 53 | (defvar build-status-travis-ci-domain nil 54 | "Travis CI domain. 55 | It can be travis-ci.org, travis-ci.com, or the domain of your own enterprise instance.") 56 | 57 | (defvar build-status-circle-ci-status-mapping-alist 58 | '(("infrastructure_fail" . "failed") 59 | ("not_running" . "queued") 60 | ("success" . "passed") 61 | ("scheduled" . "queued") 62 | ("timedout" . "failed")) 63 | "Alist of CircleCI status to build-status statuses. 64 | build-status statuses are: failed, passed, queued, running. 65 | When set to the symbol `ignored' the status will be ignored") 66 | 67 | (defvar build-status-travis-ci-status-mapping-alist 68 | '(("errored" . "failed") 69 | ("started" . "running") 70 | ("created" . "queued")) 71 | "Alist of TravsCI status to build-status statuses. 72 | build-status statuses are: failed, passed, queued, running. 73 | When set to the symbol `ignored' the status will be ignored") 74 | 75 | (defvar build-status--project-status-alist '() 76 | "Alist of project roots and their build status.") 77 | 78 | (defvar build-status--timer nil) 79 | (defvar build-status--remote-regex 80 | "\\(github\\|bitbucket\\).com\\(?:/\\|:[0-9]*/?\\)\\([^/]+\\)/\\([^/]+?\\)\\(?:\\.git\\)?$") 81 | 82 | (defvar build-status--mode-line-map (make-sparse-keymap)) 83 | (define-key build-status--mode-line-map [mode-line mouse-1] 'build-status-open) 84 | 85 | (defgroup build-status nil 86 | "Mode line build status indicator" 87 | :group 'programming) 88 | 89 | (defface build-status-face 90 | '((t . (:inherit 'mode-line))) 91 | "Faces for build status indicators" 92 | :group 'build-status) 93 | 94 | (defface build-status-failed-face 95 | '((t . (:inherit 'build-status-face :background "red"))) 96 | "Face for failed build indicator" 97 | :group 'build-status) 98 | 99 | (defface build-status-passed-face 100 | '((t . (:inherit 'build-status-face :background "green"))) 101 | "Face for passed build indicator" 102 | :group 'build-status) 103 | 104 | (defface build-status-queued-face 105 | '((t . (:inherit 'build-status-face :background "yellow"))) 106 | "Face for queued build indicator" 107 | :group 'build-status) 108 | 109 | (defface build-status-running-face 110 | '((t . (:inherit 'build-status-face :background "yellow"))) 111 | "Face for running build indicator" 112 | :group 'build-status) 113 | 114 | (defface build-status-unknown-face 115 | '((t . (:inherit 'build-status-face))) 116 | "Face for unknown build status indicator" 117 | :group 'build-status) 118 | 119 | (defun build-status--git(&rest args) 120 | (car (apply 'process-lines `("git" ,@(when args args))))) 121 | 122 | (defun build-status--config (path setting) 123 | ;; Non-zero exit if config doesn't exist, ignore it. 124 | (ignore-errors (build-status--git "-C" path "config" "--get" setting))) 125 | 126 | (defun build-status--remote (path branch) 127 | (let* ((get-remote (lambda (path branch) 128 | (build-status--config path (format "branch.%s.remote" branch)))) 129 | (remote (funcall get-remote path branch))) 130 | 131 | ;; From git-link. 132 | ;; 133 | ;; Git defaults to "." if the branch has no remote. 134 | ;; If the branch has no remote we try master's, which may be set. 135 | ;; Otherwise, we default to origin. 136 | (if (or (null remote) 137 | (and (string= remote ".") 138 | (not (string= branch "master")))) 139 | (setq remote (funcall get-remote path "master"))) 140 | 141 | (when (or (null remote) 142 | (string= remote ".")) 143 | (setq remote "origin")) 144 | 145 | (build-status--config path (format "remote.%s.url" remote)))) 146 | 147 | (defun build-status--branch (path) 148 | (build-status--git "-C" path "symbolic-ref" "--short" "HEAD")) 149 | 150 | (defun build-status--project-root (path looking-for) 151 | (when path 152 | (setq path (locate-dominating-file path looking-for)) 153 | (when path 154 | (expand-file-name path)))) 155 | 156 | (defun build-status--any-open-buffers (root buffers) 157 | (stringp (cl-find root 158 | buffers 159 | :test (lambda (start-with buffer) 160 | (eq t 161 | ;; prefer compare-string as it's not strict with bounds like substring 162 | (compare-strings start-with 0 (length start-with) 163 | buffer 0 (length start-with))))))) 164 | 165 | (defun build-status--project (filename) 166 | "Return a list containing information on `FILENAME''s CI project. 167 | The list contains: 168 | CI service, api token, project root directory, VCS service, username, project, branch. 169 | 170 | If `FILENAME' is not part of a CI project return nil." 171 | (let (branch project remote root token) 172 | (cond 173 | ((setq root (build-status--circle-ci-project-root filename)) 174 | (setq project 'circle-ci) 175 | (setq token build-status-circle-ci-token)) 176 | ((setq root (build-status--travis-ci-project-root filename)) 177 | (setq project 'travis-ci) 178 | (setq token build-status-travis-ci-token))) 179 | 180 | (when root 181 | (setq branch (build-status--branch root)) 182 | (setq remote (build-status--remote root branch)) 183 | (when (and remote (string-match build-status--remote-regex remote)) 184 | (list project 185 | (or (build-status--config root "build-status.api-token") token) 186 | root 187 | (match-string 1 remote) 188 | (match-string 2 remote) 189 | (match-string 3 remote) 190 | branch))))) 191 | 192 | (defun build-status--circle-ci-project-root (path) 193 | (or (build-status--project-root path "circle.yml") 194 | (build-status--project-root path ".circleci"))) 195 | 196 | (defun build-status--travis-ci-project-root (path) 197 | (build-status--project-root path ".travis.yml")) 198 | 199 | (defun build-status--circle-ci-url (project) 200 | (let ((root (if (string= "github" (nth 3 project)) "gh" "bb"))) 201 | (format "https://circleci.com/%s/%s/%s/tree/%s" 202 | root 203 | (nth 4 project) 204 | (nth 5 project) 205 | (nth 6 project)))) 206 | 207 | (defun build-status--travis-ci-domain () 208 | (or build-status-travis-ci-domain 209 | "travis-ci.org")) 210 | 211 | (defun build-status--travis-ci-url (project) 212 | (let* ((json (build-status--travis-ci-branch-request project)) 213 | (build (cdr (assq 'id (assq 'branch json))))) 214 | (format "https://%s/%s/%s/builds/%s" 215 | (build-status--travis-ci-domain) 216 | (nth 4 project) 217 | (nth 5 project) 218 | build))) 219 | 220 | (defun build-status--http-request (url) 221 | "Make an HTTP request to `URL', parse the JSON response and return it. 222 | Signals an error if the response does not contain an HTTP 200 status code." 223 | (with-current-buffer (url-retrieve-synchronously url) 224 | ;; (message "%s\n%s" url (buffer-substring-no-properties 1 (point-max))) 225 | (goto-char (point-min)) 226 | (when (and (search-forward-regexp "HTTP/1\\.[01] \\([0-9]\\{3\\}\\)" nil t) 227 | (not (string= (match-string 1) "200"))) 228 | (error "Request to %s failed with HTTP status %s" url (match-string 1))) 229 | 230 | (search-forward-regexp "\n\n") 231 | (json-read))) 232 | 233 | (defun build-status--circle-ci-status (project) 234 | "Get the Circle CI build status of `PROJECT'." 235 | (let* ((url (apply 'format "https://circleci.com/api/v1.1/project/%s/%s/%s/tree/%s?limit=1" 236 | `(,@(cdddr project)))) 237 | (url-request-method "GET") 238 | (url-request-extra-headers '(("Accept" . "application/json"))) 239 | (token (nth 1 project)) 240 | json 241 | status) 242 | 243 | (when token 244 | (setq url (format "%s&circle-token=%s" url token))) 245 | 246 | (setq json (build-status--http-request url)) 247 | ;; When branch is not found a 200 is returned but the array is empty 248 | (when (> (length json) 0) 249 | (setq status (or (cdr (assq 'outcome (elt json 0))) 250 | (cdr (assq 'status (elt json 0))))) 251 | 252 | (or (cdr (assoc status build-status-circle-ci-status-mapping-alist)) 253 | status)))) 254 | 255 | (defun build-status--travis-ci-request (url &optional token) 256 | "Generic Travis CI request to `URL' using `TOKEN', if given." 257 | (let ((url-request-method "GET") 258 | (url-request-extra-headers '(("Accept" . "application/vnd.travis-ci.2+json")))) 259 | 260 | (when token 261 | (push (cons "Authorization" (format "token %s" token)) url-request-extra-headers)) 262 | 263 | (build-status--http-request url))) 264 | 265 | (defun build-status--travis-ci-branch-request (project) 266 | "Get the Travis CI build status of `PROJECT'." 267 | (let ((url (format "https://api.%s/repos/%s/%s/branches/%s" 268 | (build-status--travis-ci-domain) 269 | (nth 4 project) 270 | (nth 5 project) 271 | (nth 6 project))) 272 | (token (nth 1 project))) 273 | 274 | (build-status--travis-ci-request url token))) 275 | 276 | (defun build-status--travis-ci-status (project) 277 | (let* ((json (build-status--travis-ci-branch-request project)) 278 | (status (cdr (assq 'state (assq 'branch json))))) 279 | 280 | (or (cdr (assoc status build-status-travis-ci-status-mapping-alist)) 281 | status))) 282 | 283 | (defun build-status--update-status () 284 | (let ((buffers (delq nil (mapcar 'buffer-file-name (buffer-list)))) 285 | config 286 | project 287 | new-status) 288 | 289 | (dolist (root (mapcar 'car build-status--project-status-alist)) 290 | (setq config (assoc root build-status--project-status-alist)) 291 | (setq project (build-status--project root)) 292 | (if (and project (build-status--any-open-buffers root buffers)) 293 | (condition-case e 294 | (progn 295 | (setq new-status (if (eq (car project) 'circle-ci) 296 | (build-status--circle-ci-status project) 297 | (build-status--travis-ci-status project))) 298 | ;; Don't show queued state unless we have no prior state 299 | ;; Option to control this behavior? 300 | (when (and (not (eq new-status 'ignore)) 301 | (or (not (string= new-status "queued")) 302 | (null (cdr config)))) 303 | (setcdr config new-status))) 304 | (error (message "Failed to update status for %s: %s" root (cadr e)))) 305 | (setq build-status--project-status-alist 306 | (delete config build-status--project-status-alist)))) 307 | 308 | (force-mode-line-update t) 309 | (setq build-status--timer 310 | (run-at-time build-status-check-interval nil 'build-status--update-status)))) 311 | 312 | (defun build-status--select-face (status) 313 | (let ((face (intern (format "build-status-%s-face" 314 | (replace-regexp-in-string "[[:space:]]+" "-" status))))) 315 | (when (not (facep face)) 316 | (setq face 'build-status-unknown-face)) 317 | face)) 318 | 319 | (defun build-status--propertize (lighter status) 320 | (let ((face (build-status--select-face status))) 321 | (propertize (if (face-differs-from-default-p face) (concat " " lighter " ") lighter) 322 | 'help-echo (concat "Build " status) 323 | 'local-map build-status--mode-line-map 324 | 'mouse-face 'mode-line-highlight 325 | 'face face))) 326 | 327 | (defvar build-status-mode-line-string 328 | '(:eval 329 | (let* ((root (or (build-status--circle-ci-project-root (buffer-file-name)) 330 | (build-status--travis-ci-project-root (buffer-file-name)))) 331 | (status (cdr (assoc root build-status--project-status-alist)))) 332 | (if (null status) 333 | "" 334 | (concat " " 335 | (cond 336 | ((string= status "passed") 337 | (build-status--propertize "P" status)) 338 | ((string= status "running") 339 | (build-status--propertize "R" status)) 340 | ((string= status "failed") 341 | (build-status--propertize "F" status)) 342 | ((string= status "queued") 343 | (build-status--propertize "Q" status)) 344 | (t 345 | (build-status--propertize "?" (replace-regexp-in-string "[^a-zA-Z0-9[:space:]]+" " " 346 | (or status "unknown"))))))))) 347 | "Build status mode line string.") 348 | ;;;###autoload (put 'build-status-mode-line-string 'risky-local-variable t) 349 | 350 | (defun build-status--activate-mode () 351 | (let ((root (nth 2 (build-status--project (buffer-file-name))))) 352 | (not (null (assoc root build-status--project-status-alist))))) 353 | 354 | (defun build-status--toggle-mode (enable) 355 | (let* ((project (build-status--project (buffer-file-name))) 356 | (root (nth 2 project))) 357 | 358 | (when (null project) 359 | (error "Not a CI project")) 360 | 361 | (when build-status--timer 362 | (cancel-timer build-status--timer)) 363 | 364 | (if enable 365 | (progn 366 | (add-to-list 'global-mode-string 'build-status-mode-line-string t) 367 | (add-to-list 'build-status--project-status-alist (cons root nil))) 368 | 369 | (setq build-status--project-status-alist 370 | (delete (assoc root build-status--project-status-alist) 371 | build-status--project-status-alist))) 372 | 373 | ;; Only remove from the mode line if there are no more projects 374 | (if (null build-status--project-status-alist) 375 | (delq 'build-status-mode-line-string global-mode-string) 376 | (build-status--update-status)))) 377 | 378 | (defun build-status-open () 379 | "Open the CI service's web page for current project's branch." 380 | (interactive) 381 | (let ((project (build-status--project (buffer-file-name)))) 382 | (when project 383 | (browse-url (if (eq 'circle-ci (car project)) 384 | (build-status--circle-ci-url project) 385 | (build-status--travis-ci-url project)))))) 386 | 387 | ;;;###autoload 388 | (define-minor-mode build-status-mode 389 | "Monitor the build status of the buffer's project." 390 | :global t 391 | :variable ((build-status--activate-mode) . build-status--toggle-mode)) 392 | 393 | (provide 'build-status) 394 | ;;; build-status.el ends here 395 | -------------------------------------------------------------------------------- /example-failing.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sshaw/build-status/1a1d2473aa62f2fdda47d8bfeb9fe352d2579b48/example-failing.png -------------------------------------------------------------------------------- /example-passing.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sshaw/build-status/1a1d2473aa62f2fdda47d8bfeb9fe352d2579b48/example-passing.png -------------------------------------------------------------------------------- /example-running.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sshaw/build-status/1a1d2473aa62f2fdda47d8bfeb9fe352d2579b48/example-running.png --------------------------------------------------------------------------------