pipmon.el (27028B)
1 ;;; pipmon.el -*- lexical-binding: t -*- 2 3 ;; Copyright (C) 2025 kralik 4 5 ;; This program is free software: you can redistribute it and/or modify 6 ;; it under the terms of the GNU General Public License as published by 7 ;; the Free Software Foundation, either version 3 of the License, or 8 ;; (at your option) any later version. 9 10 ;; This program is distributed in the hope that it will be useful, 11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 ;; GNU General Public License for more details. 14 15 ;; You should have received a copy of the GNU General Public License 16 ;; along with this program. If not, see <https://www.gnu.org/licenses/>. 17 18 (require 'cl-lib) 19 (require 'url) 20 (require 'url-vars) 21 (require 'url-http) 22 (require 'json) 23 (require 'dash) 24 25 (defvar pipmon-watched-directory "~/.pipmon" 26 "Directory where pipmon will store its database.") 27 28 (defvar pipmon-watched () 29 "List of pipelines currently being watched.") 30 31 (defvar pipmon-searched () 32 "List of pipeline returned from the most recent search.") 33 34 (defvar pipmon-status-success '("success") 35 "Status of a pipeline that qualify as success.") 36 37 (defvar pipmon-status-failure '("canceled") 38 "Status of a pipeline that qualify as failure.") 39 40 (defvar pipmon-refresh-interval 5 41 "Number of seconds between calls to check the status of a pipeline.") 42 43 (defvar pipmon-gitlab-api "https://gitlab.com/api/v4") 44 45 (defvar pipmon-multiform-boundary "AaB03x") 46 47 (defvar pipmon-projects ()) 48 49 (defvar pipmon-screen 'watched) 50 51 (defvar pipmon-pipeline-headers '(("" . 4) ("project-id" . 13) ("pipeline-id" . 14) ("status" . 10) ("note" . 30))) 52 53 (defvar pipmon-job-headers '(("" . 4) ("stage" . 13) ("job-id" . 14) ("name" . 10) ("status" . 10))) 54 55 (cl-defstruct (pipmon-pipeline (:constructor pipmon-pipeline--create)) 56 "Pipeline entry." 57 (project-id 0) 58 (pipeline-id 0) 59 data note status jobs) 60 61 (cl-defstruct (pipmon-job (:constructor pipmon-job--create)) 62 "Job entry." 63 (project-id 0) 64 (pipeline-id 0) 65 (job-id 0) 66 stage name status) 67 68 (cl-defstruct (pipmon-drawer (:constructor pipmon-drawer--create)) 69 label entry keymap slot-keymap slots slots-overlay) 70 71 (defun pipmon-watch-entry () 72 (interactive) 73 (pipmon-with 'pipmon-pipeline 74 (project-id pipeline-id) (selected (pipmon-selected)) 75 (unless (pipmon-scheduled-p selected) 76 (pipmon-add-watch project-id pipeline-id) 77 (pipmon-redraw)))) 78 79 (defun pipmon-delete-entry () 80 (interactive) 81 (--when-let (pipmon-selected) 82 (pipmon--del-watched it) 83 (pipmon--watched-save) 84 (pipmon-redraw))) 85 86 (defun pipmon-resume-entry () 87 (interactive) 88 (when-let (selected (pipmon-selected)) 89 (-let [(idx node seq) (pipmon--find-node pipmon-watched selected #'eq)] 90 (when (eq (pipmon-canceled-p node) 'soft) 91 (setf (pipmon-pipeline-status node) "pending")) 92 (when (pipmon-pending-p node) 93 (-let [prev (elt seq (1- idx))] 94 (when (or (pipmon-complete-p prev) (y-or-n-p "Previous task isn't complete. Continue? ")) 95 (pipmon--trigger-and* (nthcdr idx seq)))))))) 96 97 (defun pipmon-toggle-screen () 98 (interactive) 99 (setq pipmon-screen 100 (cl-case pipmon-screen 101 ('search 'watched) 102 ('watched 'search))) 103 (pipmon-update)) 104 105 (defun pipmon-update () 106 "Update the pipmon buffer listing." 107 (interactive) 108 (cl-case pipmon-screen 109 ('search (pipmon--update-list-search)) 110 ('watched (pipmon--update-list-watched))) 111 (pipmon-redraw)) 112 113 (defun pipmon-annotate-entry (annotation) 114 (interactive (list (read-string "annotation: " nil nil (pipmon-pipeline-note (pipmon-selected))))) 115 (when-let (selected (pipmon-selected)) 116 (pipmon-annotate selected annotation) 117 (pipmon--watched-save) 118 (pipmon-redraw))) 119 120 (defun pipmon-trigger (form) 121 (interactive (list (read-from-minibuffer "Form: " nil nil t))) 122 (if (functionp `,(car form)) 123 (eval `(pipmon-trigger-and ,form)) 124 (eval `(pipmon-trigger-and ,@form)))) 125 126 (defun pipmon-cancel-entry () 127 (interactive) 128 (let ((selected (pipmon-selected))) 129 (if (pipmon-pending-p selected) 130 (progn 131 (setf (pipmon-pipeline-status selected) "canceled") 132 (pipmon--watched-save)) 133 (pipmon-with 'pipmon-pipeline 134 (project-id pipeline-id) selected 135 (pipmon-cancel-pipeline project-id pipeline-id))))) 136 137 (defun pipmon-screen-name () 138 (format "*%s*" (symbol-name pipmon-screen))) 139 140 (defun pipmon-buffer () 141 (get-buffer-create "*pipmon*")) 142 143 (defun pipmon-current-entries () 144 (cl-case pipmon-screen 145 ('watched pipmon-watched) 146 ('search pipmon-searched))) 147 148 (defun pipmon-scheduled-p (pipeline &optional status) 149 (and (functionp (pipmon-pipeline-data pipeline)) 150 (or (not status) 151 (string= status (pipmon-pipeline-status pipeline))))) 152 153 (defun pipmon-pending-p (pipeline) 154 (pipmon-scheduled-p pipeline "pending")) 155 156 (defun pipmon-canceled-p (pipeline) 157 (pipmon-with 'pipmon-pipeline 158 (pipeline-id) pipeline 159 (when (pipmon-scheduled-p pipeline "canceled") 160 (if (zerop pipeline-id) 161 'soft 162 'hard)))) 163 164 (defun pipmon-complete-p (pipeline) 165 (pipmon-with 'pipmon-pipeline 166 (data) pipeline 167 (-let [status (alist-get 'status data)] 168 (cond 169 ((member status pipmon-status-success) 'success) 170 ((member status pipmon-status-failure) 'failure))))) 171 172 (defun pipmon-goto-line (n) 173 "Like `goto-line' but for non-interactive use." 174 (goto-char (point-min)) 175 (forward-line (1- n))) 176 177 (defmacro pipmon-save-excursion (&rest body) 178 "Like `save-excursion', but by entry/line/column instead of point." 179 (declare (indent defun)) 180 `(let ((line (line-number-at-pos)) 181 (column (current-column))) 182 (unwind-protect 183 (progn ,@body) 184 (pipmon-goto-line line) 185 (move-to-column column)))) 186 187 (defun pipmon-selected () 188 "Return the selected entry" 189 (get-text-property (point) 'entry)) 190 191 (defun pipmon-extra-headers (headers) 192 (setq pipmon--request-headers (append pipmon--request-headers headers))) 193 194 (cl-defun pipmon-request (method resource &optional &key query payload forms callback) 195 (when (and payload forms) 196 (error "Payload and forms are mutually exclusive")) 197 (if forms 198 (push (cons "Content-Type" (concat "multipart/form-data; boundary=" pipmon-multiform-boundary)) pipmon--request-headers) 199 (push (cons "Content-Type" "application/json") pipmon--request-headers)) 200 (let* ((url-request-method method) 201 (url-request-extra-headers pipmon--request-headers) 202 (url-request-data (if forms (pipmon--form-data forms) payload)) 203 (url-show-status nil) 204 (url (concat pipmon-gitlab-api resource 205 (and query (concat "?" (pipmon--url-encode-params query))))) 206 (handler (lambda () 207 (url-http-parse-response) 208 (when (member url-http-response-status '(200 201)) 209 (re-search-forward "\n\n") 210 (pipmon--read-json-payload))))) 211 (if callback 212 (url-retrieve url (lambda (cbargs) 213 (let ((resp (funcall handler))) 214 (funcall callback resp))) 215 nil t) 216 (with-current-buffer (url-retrieve-synchronously url t) 217 (funcall handler))))) 218 219 (cl-defun pipmon-get (resource &optional &key query payload forms callback) 220 (pipmon-request "GET" resource :query query :payload payload :forms forms :callback callback)) 221 222 (cl-defun pipmon-post (resource &optional &key query payload forms) 223 (pipmon-request "POST" resource :query query :payload payload :forms forms)) 224 225 (defun pipmon-delete (resource) 226 (pipmon-request "DELETE" resource)) 227 228 (cl-defun pipmon-get-pipeline (project-id pipeline-id &optional &key callback) 229 (let ((resource (format "/projects/%d/pipelines/%d" project-id pipeline-id))) 230 (if callback 231 (pipmon-get resource :callback (lambda (data) (funcall callback (pipmon--data-to-pipeline data)))) 232 (pipmon--data-to-pipeline (pipmon-get resource))))) 233 234 (defun pipmon-delete-pipeline (project-id pipeline-id) 235 (pipmon-delete (format "/projects/%d/pipelines/%d" project-id pipeline-id))) 236 237 (defun pipmon-list-pipelines (project-id) 238 (mapcar 'pipmon--data-to-pipeline (pipmon-get (format "/projects/%d/pipelines" project-id)))) 239 240 (defun pipmon-cancel-pipeline (project-id pipeline-id) 241 (pipmon-post (format "/projects/%d/pipelines/%d/cancel" project-id pipeline-id))) 242 243 (cl-defun pipmon-trigger-pipeline (project-id token ref &optional &key query forms) 244 (let ((query (append query (list (cons 'ref ref) (cons 'token token))))) 245 (when-let ((data (pipmon-post (format "/projects/%d/trigger/pipeline" project-id) :query query :forms forms))) 246 (pipmon--data-to-pipeline data)))) 247 248 (defun pipmon-get-job (project-id job-id) 249 (let ((resource (format "/projects/%d/jobs/%d" project-id job-id))) 250 (pipmon--data-to-job (pipmon-get resource)))) 251 252 (defun pipmon-list-jobs (pipeline) 253 (pipmon-with 254 'pipmon-pipeline 255 (project-id pipeline-id) pipeline 256 (--> (pipmon-get (format "/projects/%d/pipelines/%d/jobs" project-id pipeline-id)) 257 (mapcar 'pipmon--data-to-job it) 258 (nreverse it)))) 259 260 (defun pipmon-fill-jobs (pipeline) 261 (-let [current (pipmon--find-node1 pipmon-watched pipeline #'pipmon-pipeline=)] 262 (setf (pipmon-pipeline-jobs current) (pipmon-list-jobs current)))) 263 264 (defun pipmon-update-jobs (pipeline) 265 (--map 266 (pipmon-with 267 'pipmon-job 268 (project-id job-id) (job it) 269 (pipmon-get-job project-id job-id)) 270 (pipmon-pipeline-jobs pipeline))) 271 272 (defun add-to-drawer (drawer label elem) 273 (setf (pipmon-drawer-slots drawer) 274 (cons (cons label elem) (pipmon-drawer-slots drawer)))) 275 276 (defun write-container (label keymap elem) 277 (let (overlay overlay-start) 278 (setq overlay-start (point)) 279 (insert label) 280 (setq overlay (make-overlay overlay-start (point))) 281 (overlay-put overlay 'keymap keymap) 282 (overlay-put overlay 'evaporate t) 283 (overlay-put overlay 'elem elem) 284 (overlay-put overlay 'priority 3))) 285 286 (defun write-drawer (drawer invisible) 287 (let (overlay point-start) 288 (setq point-start (point)) 289 (write-container (pipmon-drawer-label drawer) (pipmon-drawer-keymap drawer) drawer) 290 (put-text-property point-start (point) 'entry (pipmon-drawer-entry drawer)) 291 (when-let (slots (nreverse (pipmon-drawer-slots drawer))) 292 (setq point-start (point)) 293 (dolist (slot slots) 294 (insert "\n") 295 (write-container (car slot) (pipmon-drawer-slot-keymap drawer) (cdr slot))) 296 (setq overlay (make-overlay point-start (point))) 297 (overlay-put overlay 'invisible invisible) 298 (overlay-put overlay 'evaporate t) 299 (setf (pipmon-drawer-slots-overlay drawer) overlay)))) 300 301 (defun overlay-elem-at (position pred) 302 (when-let (overlay (car (overlays-at position t))) 303 (-let [elem (overlay-get overlay 'elem)] 304 (and (funcall pred elem) 305 elem)))) 306 307 (defun delete-drawer (position) 308 (when-let (drawer (car (overlays-at position t))) 309 (when-let (slots (drawer-slots-at position)) 310 (delete-region (overlay-start slots) (overlay-end slots))) 311 (delete-region (overlay-start drawer) (overlay-end drawer)))) 312 313 (defun toggle-drawer () 314 (interactive) 315 (when-let (slots (drawer-slots-at (point))) 316 (overlay-put slots 'invisible (not (drawer-invisible-p (point)))))) 317 318 (defun display-log () 319 (interactive) 320 (pipmon-with 321 'pipmon-job 322 (project-id job-id) (job (overlay-elem-at (point) #'pipmon-job-p)) 323 (switch-to-buffer (log-buffer)) 324 (run-log project-id job-id))) 325 326 (defun toggle-pipeline () 327 (interactive) 328 (pipmon-with 329 'pipmon-pipeline 330 (jobs) (pipeline (pipmon-selected)) 331 (unless jobs 332 (pipmon-fill-jobs pipeline) 333 (pipmon--redraw-entry pipeline)) 334 (toggle-drawer))) 335 336 (defvar pipmon-pipeline-keymap 337 (let ((map (make-sparse-keymap))) 338 (define-key map (kbd "<tab>") #'toggle-pipeline) 339 map)) 340 341 (defvar pipmon-job-keymap 342 (let ((map (make-sparse-keymap))) 343 (define-key map (kbd "<return>") #'display-log) 344 map)) 345 346 (defun pipmon-job-log (project-id job-id) 347 (pipmon-get (format "/projects/%d/jobs/%d/trace" project-id job-id))) 348 349 (defvar log-refresh 1) 350 351 (defun run-log (project-id job-id) 352 (when-let (log (pipmon-job-log project-id job-id)) 353 (redraw-log (alist-get 'message log)) 354 (pipmon-with 355 'pipmon-job 356 (status) (job (pipmon-get-job project-id job-id)) 357 (unless (or (member status pipmon-status-success) 358 (member status pipmon-status-failure)) 359 (run-with-timer log-refresh nil #'run-log project-id job-id))))) 360 361 (defun log-buffer () 362 (get-buffer-create "*log*")) 363 364 (defun redraw-log (text) 365 (with-current-buffer (log-buffer) 366 (erase-buffer) 367 (when text 368 (let* ((text (replace-regexp-in-string "section_\\(start\\|end\\):[[:digit:]]+:[[:word:]_]+" "" text)) 369 (text (replace-regexp-in-string "\r" "" text))) 370 (insert text) 371 (ansi-color-apply-on-region (point-min) (point-max)))))) 372 373 (defmacro pipmon-trigger-and (&rest forms) 374 (-let [watch-list `',(--map (pipmon-pipeline--create :data `(lambda () ,it) :status "pending" :note (format "%S" it)) forms)] 375 `(progn 376 (push ,watch-list pipmon-watched) 377 (pipmon-redraw) 378 (pipmon--trigger-and* ,watch-list)))) 379 380 (defun pipmon-annotate (pipeline annotation) 381 (setf (pipmon-pipeline-note pipeline) (unless (string-empty-p annotation) annotation)) 382 pipeline) 383 384 (defun pipmon-add-watch (project-id pipeline-id) 385 (let ((watch (pipmon-pipeline--create :project-id project-id :pipeline-id pipeline-id))) 386 (unless (member watch pipmon-watched) 387 (push watch pipmon-watched) 388 (pipmon--watched-save)) 389 watch)) 390 391 (defmacro pipmon-with (type slots struct &rest body) 392 (let ((struct-var (if (listp struct) (car struct) struct)) 393 (struct-val (if (listp struct) (cadr struct) struct))) 394 `(when-let ((,struct-var ,struct-val)) 395 (pipmon--with-struct-slots ,slots ,type ,struct-var 396 ,@body)))) 397 398 (defun pipmon-redraw () 399 (with-current-buffer (pipmon-buffer) 400 (pipmon-save-excursion 401 (let ((inhibit-read-only t) 402 (standard-output (current-buffer))) 403 (erase-buffer) 404 (insert (pipmon--format-column (pipmon-screen-name) (- (window-width) 10) :right)) 405 (insert "\n") 406 (pipmon--print-header) 407 (insert "\n") 408 (pipmon--foreach-node 409 (pipmon-current-entries) 410 (lambda (idx node seq) 411 (draw-pipeline node) 412 (insert "\n"))))) 413 (when (zerop (buffer-size)) 414 ;; If nothing changed, force a header line update 415 (force-mode-line-update)))) 416 417 (defun pipmon-pipeline= (pipeline-1 pipeline-2) 418 (and (= (pipmon-pipeline-project-id pipeline-1) (pipmon-pipeline-project-id pipeline-2)) 419 (= (pipmon-pipeline-pipeline-id pipeline-1) (pipmon-pipeline-pipeline-id pipeline-2)))) 420 421 (defvar pipmon-mode-map 422 (let ((map (make-sparse-keymap))) 423 (prog1 map 424 (suppress-keymap map) 425 (define-key map "h" #'describe-mode) 426 (define-key map "r" #'pipmon-update) 427 (define-key map "R" #'pipmon-resume-entry) 428 (define-key map "s" #'pipmon-toggle-screen) 429 (define-key map "w" #'pipmon-watch-entry) 430 (define-key map "t" #'pipmon-trigger) 431 (define-key map "d" #'pipmon-delete-entry) 432 (define-key map "a" #'pipmon-annotate-entry) 433 (define-key map "c" #'pipmon-cancel-entry))) 434 "Keymap for pipmon-mode.") 435 436 (defun pipmon-mode () 437 "Major mode for listing Gitlab pipeline entries. 438 \\{pipmon-mode-map}" 439 (interactive) 440 (switch-to-buffer (pipmon-buffer)) 441 (kill-all-local-variables) 442 (use-local-map pipmon-mode-map) 443 (setq major-mode 'pipmon-mode 444 mode-name "pipmon" 445 truncate-lines t 446 buffer-read-only t) 447 (buffer-disable-undo) 448 (hl-line-mode) 449 (and (fboundp 'turn-off-evil-mode) (turn-off-evil-mode)) 450 (pipmon--watched-load) 451 (pipmon--update-list-watched) 452 (pipmon-update) 453 (run-mode-hooks)) 454 455 (defun pipmon () 456 "Enter pipmon" 457 (interactive) 458 (unless (eq major-mode 'pipmon-mode) 459 (pipmon-mode))) 460 461 (defvar pipmon--running ()) 462 (defvar pipmon--request-headers ()) 463 464 (defun pipmon--watched-load () 465 "Load the database index from the filesystem." 466 (let ((index (expand-file-name "index" pipmon-watched-directory)) 467 (enable-local-variables nil)) ; don't set local variables from index! 468 (if (not (file-exists-p index)) 469 (setf pipmon-watched '()) 470 ;; Override the default value for major-mode. There is no 471 ;; preventing find-file-noselect from starting the default major 472 ;; mode while also having it handle buffer conversion. Some 473 ;; major modes crash Emacs when enabled in large buffers (e.g. 474 ;; org-mode). 475 (cl-letf (((default-value 'major-mode) 'fundamental-mode)) 476 (with-current-buffer (find-file-noselect index :nowarn) 477 (goto-char (point-min)) 478 (setf pipmon-watched (read (current-buffer))) 479 (kill-buffer)))))) 480 481 (defun pipmon--watched-save () 482 (mkdir pipmon-watched-directory t) 483 (let ((coding-system-for-write 'utf-8)) 484 (with-temp-file (expand-file-name "index" pipmon-watched-directory) 485 (let ((standard-output (current-buffer)) 486 (print-level nil) 487 (print-length nil) 488 (print-circle nil)) 489 (prin1 pipmon-watched) 490 :success)))) 491 492 (defun pipmon--delete-node (node-pred pred tree) 493 (cond ((and (funcall node-pred tree) (funcall pred tree)) nil) 494 ((and (listp tree) (listp (cdr tree))) 495 (-keep (lambda (x) (pipmon--delete-node node-pred pred x)) tree)) 496 (tree))) 497 498 (defun pipmon--del-watched (pipeline) 499 (setq pipmon-watched (pipmon--delete-node 'pipmon-pipeline-p (lambda (it) (pipmon-pipeline= pipeline it)) pipmon-watched))) 500 501 (defun pipmon--iterate-nodes (nodes fun) 502 (let ((lst nodes) 503 (n 0) 504 (continue t)) 505 (while (and lst continue) 506 (if (listp (car lst)) 507 (let ((lst1 (car lst)) 508 (n1 0)) 509 (while (and lst1 continue) 510 (setq continue (funcall fun n1 (car lst1) (car lst)) 511 lst1 (cdr lst1) 512 n1 (1+ n1)))) 513 (setq continue (funcall fun n (car lst) nodes))) 514 (setq lst (cdr lst) 515 n (1+ n))))) 516 517 (defun pipmon--find-node (nodes node compare-fn) 518 (let ((result)) 519 (pipmon--iterate-nodes 520 nodes 521 (lambda (idx n seq) 522 (when (funcall compare-fn node n) 523 (setq result (list idx n seq)) 524 t))) 525 result)) 526 527 (defun pipmon--find-node1 (nodes node compare-fn) 528 (-let [(_ n _) (pipmon--find-node nodes node compare-fn)] 529 n)) 530 531 (defun pipmon--foreach-node (nodes fun) 532 (pipmon--iterate-nodes 533 nodes 534 (lambda (idx node seq) 535 (funcall fun idx node seq) 536 t))) 537 538 (defun pipmon--update-list-search () 539 (setq pipmon-searched (--mapcat (pipmon-list-pipelines (alist-get 'id (cdr it))) pipmon-projects))) 540 541 (defun pipmon--update-list-watched () 542 (--each (flatten-tree pipmon-watched) 543 (pipmon--update-entry it))) 544 545 (defun pipmon--decode-payload () 546 (and (not (eobp)) 547 (decode-coding-string 548 (buffer-substring-no-properties (point) (point-max)) 549 'utf-8))) 550 551 (defun pipmon--read-json-payload () 552 (let ((raw (pipmon--decode-payload))) 553 (and raw 554 (condition-case nil 555 (let ((json-object-type 'alist) 556 (json-array-type 'list) 557 (json-false nil) 558 (json-null nil)) 559 (json-read-from-string raw)) 560 ((json-parse-error json-readtable-error) 561 `((message 562 . ,(if (looking-at "<!DOCTYPE html>") 563 (if (re-search-forward 564 "<p>\\(?:<strong>\\)?\\([^<]+\\)" nil t) 565 (match-string 1) 566 "error description missing") 567 (string-trim (buffer-substring (point) (point-max))))))))))) 568 569 (defun pipmon--url-encode-params (params) 570 (mapconcat (lambda (param) 571 (pcase-let ((`(,key . ,val) param)) 572 (concat (url-hexify-string (symbol-name key)) "=" 573 (cl-typecase val 574 (integer (number-to-string val)) 575 (boolean (if val "true" "false")) 576 (t (url-hexify-string val)))))) 577 params "&")) 578 579 (defun pipmon--form-data (data) 580 (cl-loop for (key . val) in data 581 collect (format "--%s\r\nContent-Disposition: form-data; name=\"variables[%s]\"\r\n\r\n%s" pipmon-multiform-boundary key val) into forms 582 finally return (format "%s--%s--" (string-join forms "\r\n") pipmon-multiform-boundary))) 583 584 (defun pipmon--data-to-pipeline (data) 585 (let-alist data 586 (pipmon-pipeline--create :project-id .project_id :pipeline-id .id :data data))) 587 588 (defun pipmon--data-to-job (data) 589 (let-alist data 590 (pipmon-job--create :project-id (alist-get 'project_id .pipeline) :pipeline-id (alist-get 'id .pipeline) :job-id .id 591 :stage .stage :name .name :status .status))) 592 593 (defun pipmon--while-pipeline-running (pipeline on-update on-success on-failure) 594 (pipmon-with 'pipmon-pipeline 595 (project-id pipeline-id status) pipeline 596 (unless (memq pipeline-id pipmon--running) 597 (push pipeline-id pipmon--running) 598 (pipmon-get-pipeline 599 project-id pipeline-id 600 :callback (lambda (updated) 601 (funcall on-update updated) 602 (when (pipmon-complete-p updated) 603 (setq pipmon--running (delq pipeline-id pipmon--running))) 604 (cl-case (pipmon-complete-p updated) 605 ('success (funcall on-success updated)) 606 ('failure (funcall on-failure updated)) 607 (t (run-with-timer pipmon-refresh-interval nil 608 #'(lambda () 609 (setq pipmon--running (delq pipeline-id pipmon--running)) 610 (pipmon--while-pipeline-running pipeline on-update on-success on-failure)))))))))) 611 612 (defun pipmon--trigger-and* (pipelines) 613 (pipmon-with 'pipmon-pipeline 614 (note) (pipeline (car pipelines)) 615 (unless (pipmon-canceled-p pipeline) 616 (let ((updated (if (pipmon-scheduled-p pipeline) (funcall (pipmon-pipeline-data pipeline)) pipeline))) 617 (pipmon-annotate (pipmon--find-node1 pipmon-watched pipeline #'eq) note) 618 (pipmon--watched-save) 619 (setcar pipelines updated) 620 (pipmon--update-entry (car pipelines) (lambda (pipeline) (pipmon--trigger-and* (cdr pipelines)))))))) 621 622 (defun at-pipeline-p (pipeline) 623 (and (pipmon-selected) (pipmon-pipeline= (pipmon-selected) pipeline))) 624 625 (defun draw-pipeline (pipeline) 626 (let ((inhibit-read-only t) 627 (standard-output (current-buffer)) 628 (invisible t)) 629 (when (at-pipeline-p pipeline) 630 (setq invisible (drawer-invisible-p (point))) 631 (delete-drawer (point))) 632 (pipmon--write-pipeline (pipmon--create-gutter pipeline) pipeline invisible))) 633 634 (defun drawer-slots-at (position) 635 (when-let (drawer (overlay-elem-at position #'pipmon-drawer-p)) 636 (pipmon-drawer-slots-overlay drawer))) 637 638 (defun drawer-invisible-p (position) 639 (if-let (slots (drawer-slots-at position)) 640 (overlay-get slots 'invisible) 641 t)) 642 643 (defun find-entry (pred task compare-fn) 644 (pipmon-save-excursion 645 (goto-char (point-min)) 646 (let (found) 647 (while (not (or found (eobp))) 648 (when-let (elem (overlay-elem-at (point) pred)) 649 (when (funcall compare-fn elem task) 650 (setq found (point)))) 651 (next-line)) 652 found))) 653 654 (defun pipmon--redraw-entry (entry) 655 (with-current-buffer (pipmon-buffer) 656 (pipmon-save-excursion 657 (goto-char (point-min)) 658 (while (zerop (forward-line)) 659 (when (at-pipeline-p entry) 660 (draw-pipeline entry)))))) 661 662 (defun pipmon--update-entry (pipeline &optional on-success) 663 (pipmon-with 664 'pipmon-pipeline 665 (project-id pipeline-id) pipeline 666 (unless (pipmon-scheduled-p pipeline) 667 (pipmon-redraw) 668 (pipmon--while-pipeline-running 669 pipeline 670 (lambda (pipeline) 671 (let ((node (pipmon--find-node1 pipmon-watched pipeline #'pipmon-pipeline=)) 672 (entry (find-entry #'pipmon-pipeline-p pipeline #'pipmon-pipeline=))) 673 (setf (pipmon-pipeline-data node) (pipmon-pipeline-data pipeline)) 674 (unless (and entry (drawer-invisible-p entry)) 675 (setf (pipmon-pipeline-jobs node) (pipmon-update-jobs node))) 676 (pipmon--redraw-entry node))) 677 (lambda (pipeline) 678 (when on-success (funcall on-success pipeline))) 679 (lambda (pipeline)))))) 680 681 (defun pipmon--format-column (string width &optional align) 682 "Return STRING truncated or padded to WIDTH following ALIGNment. 683 Align should be a keyword :left or :right." 684 (if (<= width 0) 685 "" 686 (format (format "%%%s%d.%ds" (if (eq align :left) "-" "") width width) 687 string))) 688 689 (defun pipmon--print-header () 690 (cl-loop for (name . width) in pipmon-pipeline-headers 691 do (insert (pipmon--format-column name width :right)))) 692 693 (defun pipmon--create-gutter (entry &optional idx seq) 694 (let ((gutter "")) 695 (when (eq pipmon-screen 'search) 696 (setq idx nil 697 seq nil)) 698 (when (not idx) 699 (pipmon-with 'pipmon-pipeline 700 (project-id pipeline-id) entry 701 (when-let (node (pipmon--find-node pipmon-watched entry #'pipmon-pipeline=)) 702 (setq idx (elt node 0) 703 seq (elt node 2))))) 704 (if (eq pipmon-screen 'search) 705 (setq gutter (concat gutter " ")) 706 (if (and seq (not (eq seq pipmon-watched)) 707 (not (zerop idx))) 708 (setq gutter (concat gutter "|")) 709 (setq gutter (concat gutter " ")))) 710 (if (eq pipmon-screen 'search) 711 (if idx 712 (setq gutter (concat gutter "w")) 713 (setq gutter (concat gutter " "))) 714 (setq gutter (concat gutter " "))) 715 gutter)) 716 717 (defun pipmon--format-pipeline (gutter pipeline) 718 (pipmon-with 719 'pipmon-pipeline (project-id pipeline-id data note status) pipeline 720 (let ((widths (--map (cdr it) pipmon-pipeline-headers))) 721 (concat 722 (pipmon--format-column gutter (elt widths 0)) 723 (pipmon--format-column (number-to-string project-id) (elt widths 1) :right) 724 (pipmon--format-column (number-to-string pipeline-id) (elt widths 2) :right) 725 (pipmon--format-column (or status (alist-get 'status data) "") (elt widths 3) :right) 726 (pipmon--format-column (or note "") (elt widths 4) :right))))) 727 728 (defun pipmon--format-job (job print-stage) 729 (pipmon-with 730 'pipmon-job (job-id stage name status) job 731 (let ((widths (--map (cdr it) pipmon-job-headers))) 732 (concat 733 (pipmon--format-column "" (elt widths 0)) 734 (pipmon--format-column name (elt widths 1) :right) 735 (pipmon--format-column (number-to-string job-id) (elt widths 2) :right) 736 (pipmon--format-column status (elt widths 3) :right) 737 (pipmon--format-column (if print-stage stage "") (elt widths 4) :right))))) 738 739 (defun pipmon--write-pipeline (gutter pipeline invisible) 740 (let ((drawer (pipmon-drawer--create 741 :label (pipmon--format-pipeline gutter pipeline) 742 :entry pipeline 743 :keymap pipmon-pipeline-keymap 744 :slot-keymap pipmon-job-keymap)) 745 prev-stage) 746 (dolist (job (pipmon-pipeline-jobs pipeline)) 747 (let ((stage (pipmon-job-stage job))) 748 (add-to-drawer drawer (pipmon--format-job job (not (equal stage prev-stage))) job) 749 (setq prev-stage stage))) 750 (write-drawer drawer invisible))) 751 752 (defmacro pipmon--with-struct-slots (spec-list struct-type struct &rest body) 753 (declare (indent 2) (debug (sexp sexp def-body))) 754 ;; Transform the spec-list into a cl-symbol-macrolet spec-list. 755 (macroexp-let2 nil struct struct 756 `(cl-symbol-macrolet 757 ,(mapcar (lambda (entry) 758 (let ((var (if (listp entry) (car entry) entry)) 759 (slot (if (listp entry) (cadr entry) entry))) 760 (list var `(cl-struct-slot-value ,struct-type ',slot ,struct)))) 761 spec-list) 762 ,@body))) 763 764 (provide 'pipmon)