bitpipe.el

;;; bitpipe.el --- Trigger and monitor Bitbucket Pipelines from Emacs -*- lexical-binding: t -*-

;; Author: Ngoc
;; Version: 0.1.0
;; Package-Requires: ((emacs "27.1"))
;; Keywords: tools, processes
;; SPDX-License-Identifier: GPL-3.0-or-later

;;; Code:

(require 'url)
(require 'json)
(require 'project)
(require 'cl-lib)
(require 'seq)

;;; --- Configuration ---

(defgroup bitpipe nil
  "Trigger and monitor Bitbucket Pipelines."
  :group 'tools
  :prefix "bitpipe-")

(defcustom bitpipe-workspace nil
  "Bitbucket workspace slug."
  :type 'string :group 'bitpipe)

(defcustom bitpipe-repo nil
  "Bitbucket repository slug. If nil, inferred from current git remote."
  :type 'string :group 'bitpipe)

(defcustom bitpipe-email nil
  "Atlassian account email for API token auth."
  :type 'string :group 'bitpipe)

(defcustom bitpipe-api-token nil
  "Bitbucket API token."
  :type 'string :group 'bitpipe)

(defcustom bitpipe-poll-interval 7
  "Seconds between pipeline status polls."
  :type 'integer :group 'bitpipe)

(defcustom bitpipe-use-ivy nil
  "When non-nil, use `ivy-read' for completion instead of `completing-read'."
  :type 'boolean :group 'bitpipe)

;;; --- Mode line ---

(defvar bitpipe--active '()
  "List of plists for pipelines being monitored.
Each plist has: :workspace :repo :email :token :uuid :build-number :branch :pipeline :web-url")

(defvar bitpipe--spinner-frames [".   " "..  " "... " "...."])
(defvar bitpipe--spinner-idx 0)
(defvar bitpipe--poll-timer nil)
(defvar bitpipe--spinner-timer nil)

(defun bitpipe--mode-line-segment ()
  (when bitpipe--active
    (let* ((frame (aref bitpipe--spinner-frames bitpipe--spinner-idx))
           (builds (mapconcat (lambda (p) (format "#%d" (plist-get p :build-number)))
                              bitpipe--active " ")))
      (propertize (format " [BB%s %s]" frame builds)
                  'face 'bitpipe-in-progress
                  'help-echo (mapconcat
                              (lambda (p)
                                (format "#%d  %s  %s"
                                        (plist-get p :build-number)
                                        (plist-get p :branch)
                                        (or (plist-get p :pipeline) "default")))
                              bitpipe--active "\n")))))

(unless (member '(:eval (bitpipe--mode-line-segment)) global-mode-string)
  (add-to-list 'global-mode-string '(:eval (bitpipe--mode-line-segment)) t))

;;; --- Helpers ---

(defun bitpipe--read (prompt candidates &optional preselect require-match)
  "Read a selection from CANDIDATES with PROMPT.
Uses `ivy-read' when `bitpipe-use-ivy' is non-nil and ivy is available."
  (if (and bitpipe-use-ivy (fboundp 'ivy-read))
      (ivy-read prompt candidates
                :preselect preselect
                :require-match require-match
                :caller 'bitpipe-run)
    (completing-read prompt candidates nil require-match nil nil preselect)))

(defun bitpipe--infer-repo-slug ()
  (when-let ((proj (project-current)))
    (let* ((default-directory (project-root proj))
           (remote (string-trim
                    (shell-command-to-string
                     "git remote get-url origin 2>/dev/null"))))
      (when (string-match "[:/]\\([^/]+\\)\\.git$" remote)
        (match-string 1 remote)))))

(defun bitpipe--strip-remote-prefix (branches)
  "Strip remote prefix (e.g. `origin/') from BRANCHES and deduplicate."
  (delete-dups
   (mapcar (lambda (b)
             (replace-regexp-in-string "\\`[^/]+/" "" b))
           branches)))

(defun bitpipe--get-branches ()
  (bitpipe--strip-remote-prefix
   (if (fboundp 'magit-list-branch-names)
       (magit-list-branch-names)
     (when-let ((proj (project-current)))
       (let ((default-directory (project-root proj)))
         (split-string
          (shell-command-to-string
           "git branch -a --format='%(refname:short)'")
          "\n" t "[ \t\r\n]"))))))

(defun bitpipe--current-branch ()
  (if (fboundp 'magit-get-current-branch)
      (magit-get-current-branch)
    (string-trim
     (shell-command-to-string "git rev-parse --abbrev-ref HEAD 2>/dev/null"))))

(defun bitpipe--parse-custom-pipelines ()
  (when-let* ((proj (project-current))
              (yml (expand-file-name "bitbucket-pipelines.yml" (project-root proj)))
              (_ (file-exists-p yml)))
    (with-temp-buffer
      (insert-file-contents yml)
      (goto-char (point-min))
      (let (pipelines in-custom)
        (while (not (eobp))
          (let ((line (buffer-substring-no-properties
                       (line-beginning-position) (line-end-position))))
            (cond
             ((string-match-p "^  custom:" line) (setq in-custom t))
             ((and in-custom (string-match "^    \\([a-zA-Z0-9_-]+\\):" line))
              (push (match-string 1 line) pipelines))
             ((and in-custom (string-match-p "^  [a-zA-Z]" line))
              (setq in-custom nil))))
          (forward-line 1))
        (nreverse pipelines)))))

(defun bitpipe--auth-header (email token)
  (concat "Basic "
          (base64-encode-string
           (encode-coding-string (concat email ":" token) 'utf-8) t)))

;;; --- API calls ---

(defun bitpipe--trigger-pipeline (workspace repo email token branch pipeline-name)
  "Synchronously trigger a pipeline. Returns parsed JSON alist."
  (let* ((url (format "https://api.bitbucket.org/2.0/repositories/%s/%s/pipelines/"
                      workspace repo))
         (target `(("ref_type" . "branch")
                   ("type"     . "pipeline_ref_target")
                   ("ref_name" . ,branch)
                   ,@(when pipeline-name
                       `(("selector" . (("type"    . "custom")
                                        ("pattern" . ,pipeline-name)))))))
         (url-request-method "POST")
         (url-request-extra-headers
          `(("Content-Type"  . "application/json")
            ("Authorization" . ,(bitpipe--auth-header email token))))
         (url-request-data (encode-coding-string (json-encode `(("target" . ,target))) 'utf-8)))
    (with-current-buffer (url-retrieve-synchronously url t t 30)
      (goto-char (point-min))
      (re-search-forward "HTTP/[0-9.]+ \\([0-9]+\\)")
      (let ((status (string-to-number (match-string 1))))
        (re-search-forward "^\r?$")
        (let ((resp (json-read)))
          (unless (= status 201)
            (let* ((error-obj (alist-get 'error resp))
                   (msg (or (alist-get 'message error-obj) (format "HTTP %d" status))))
              (user-error "Bitbucket API error %d: %s" status msg)))
          resp)))))

(defun bitpipe--poll-status-async (pipeline)
  "Async GET pipeline status for PIPELINE plist, handle completion."
  (let* ((workspace (plist-get pipeline :workspace))
         (repo      (plist-get pipeline :repo))
         (email     (plist-get pipeline :email))
         (token     (plist-get pipeline :token))
         (uuid      (plist-get pipeline :uuid))
         (url (format "https://api.bitbucket.org/2.0/repositories/%s/%s/pipelines/%s"
                      workspace repo uuid))
         (url-request-method "GET")
         (url-request-extra-headers
          `(("Authorization" . ,(bitpipe--auth-header email token)))))
    (url-retrieve
     url
     (lambda (_status)
       (goto-char (point-min))
       (when (re-search-forward "^\r?$" nil t)
         (condition-case err
             (let* ((resp       (json-read))
                    (state-obj  (alist-get 'state resp))
                    (state-name (alist-get 'name state-obj))
                    (result     (alist-get 'name (alist-get 'result state-obj))))
               (bitpipe--handle-status pipeline state-name result))
           (error (message "bitpipe poll error: %s" (error-message-string err))))))
     nil t t)))

(defun bitpipe--handle-status (pipeline state result)
  "Update mode line; on terminal state, notify and stop tracking."
  (let ((build  (plist-get pipeline :build-number))
        (branch (plist-get pipeline :branch))
        (name   (or (plist-get pipeline :pipeline) "default"))
        (url    (plist-get pipeline :web-url)))
    (if (not (member state '("COMPLETED" "FAILED" "STOPPED" "ERROR")))
        (force-mode-line-update t)
      (setq bitpipe--active
            (cl-remove-if (lambda (p) (equal (plist-get p :uuid)
                                             (plist-get pipeline :uuid)))
                          bitpipe--active))
      (force-mode-line-update t)
      (when (null bitpipe--active)
        (bitpipe--stop-timer))
      (let* ((success (equal result "SUCCESSFUL"))
             (icon    (if success "✅" "❌"))
             (title   (format "%s BB #%d %s" icon build result))
             (msg     (format "%s  [%s]  %s" name branch url)))
        (if (fboundp 'alert)
            (alert msg
                   :title title
                   :severity (if success 'normal 'high)
                   :category 'bitpipe)
          (message "%s %s" title msg))
        (when (not success)
          (browse-url url))))))

;;; --- Timer ---

(defun bitpipe--spinner-tick ()
  "Advance spinner frame and update mode line."
  (setq bitpipe--spinner-idx
        (mod (1+ bitpipe--spinner-idx)
             (length bitpipe--spinner-frames)))
  (force-mode-line-update t))

(defun bitpipe--start-timer ()
  (unless (and bitpipe--poll-timer (timerp bitpipe--poll-timer))
    (setq bitpipe--poll-timer
          (run-with-timer bitpipe-poll-interval
                          bitpipe-poll-interval
                          #'bitpipe--tick)))
  (unless (and bitpipe--spinner-timer (timerp bitpipe--spinner-timer))
    (setq bitpipe--spinner-timer
          (run-with-timer 0.4 0.4 #'bitpipe--spinner-tick))))

(defun bitpipe--stop-timer ()
  (when (timerp bitpipe--poll-timer)
    (cancel-timer bitpipe--poll-timer)
    (setq bitpipe--poll-timer nil))
  (when (timerp bitpipe--spinner-timer)
    (cancel-timer bitpipe--spinner-timer)
    (setq bitpipe--spinner-timer nil)))

(defun bitpipe--tick ()
  "Poll all active pipelines."
  (dolist (pipeline bitpipe--active)
    (bitpipe--poll-status-async pipeline)))

;;; --- Commands ---

;;;###autoload
(defun bitpipe-run ()
  "Trigger a Bitbucket pipeline interactively and monitor it."
  (interactive)
  (let* ((workspace (or bitpipe-workspace (read-string "Workspace: ")))
         (repo      (or bitpipe-repo
                        (bitpipe--infer-repo-slug)
                        (read-string "Repo slug: ")))
         (email     (or bitpipe-email (read-string "Atlassian account email: ")))
         (token     (or bitpipe-api-token (read-passwd "API token: ")))
         (branches  (bitpipe--get-branches))
         (branch    (bitpipe--read "Branch: " branches (bitpipe--current-branch)))
         (choices   (cons "[default branch pipeline]"
                          (bitpipe--parse-custom-pipelines)))
         (choice    (bitpipe--read "Pipeline: " choices nil t))
         (pipeline-name (unless (equal choice "[default branch pipeline]") choice)))
    (message "Triggering %s pipeline on %s..." (or pipeline-name "default") branch)
    (condition-case err
        (let* ((resp         (bitpipe--trigger-pipeline
                              workspace repo email token branch pipeline-name))
               (build-number (truncate (alist-get 'build_number resp)))
               (uuid         (alist-get 'uuid resp))
               (web-url      (format "https://bitbucket.org/%s/%s/pipelines/results/%d"
                                     workspace repo build-number))
               (pipeline     (list :workspace workspace
                                   :repo      repo
                                   :email     email
                                   :token     token
                                   :uuid      uuid
                                   :build-number build-number
                                   :branch    branch
                                   :pipeline  pipeline-name
                                   :web-url   web-url)))
          (push pipeline bitpipe--active)
          (bitpipe--start-timer)
          (message "Pipeline #%d started → %s" build-number web-url)
          (browse-url web-url))
      (error (user-error "Bitbucket API error: %s" (error-message-string err))))))

;;; --- Log mode ---

(defface bitpipe-success
  '((t :inherit success))
  "Face for successful pipelines."
  :group 'bitpipe)

(defface bitpipe-in-progress
  '((t :inherit success))
  "Face for in-progress pipelines."
  :group 'bitpipe)

(defface bitpipe-failed
  '((t :inherit error))
  "Face for failed pipelines."
  :group 'bitpipe)

(defface bitpipe-detail
  '((t :inherit shadow))
  "Face for commit message detail lines."
  :group 'bitpipe)

(defface bitpipe-header
  '((t :weight bold))
  "Face for log table header."
  :group 'bitpipe)

(defvar-local bitpipe-log--workspace nil)
(defvar-local bitpipe-log--repo nil)
(defvar-local bitpipe-log--email nil)
(defvar-local bitpipe-log--token nil)
(defvar-local bitpipe-log--project-dir nil)
(defvar-local bitpipe-log--entries nil)

(defvar bitpipe-log-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map (kbd "RET") #'bitpipe-log-browse)
    (define-key map (kbd "g") #'bitpipe-log-refresh)
    map))

(define-derived-mode bitpipe-log-mode tabulated-list-mode "Bitpipe-Log"
  "Major mode for viewing Bitbucket pipeline runs."
  (hl-line-mode 1))

(defun bitpipe-log-browse ()
  "Open the pipeline at point in the browser."
  (interactive)
  (when-let ((url (tabulated-list-get-id)))
    (browse-url url)))

(defun bitpipe-log-refresh ()
  "Refresh the pipeline log using stored buffer-local credentials."
  (interactive)
  (let ((workspace bitpipe-log--workspace)
        (repo bitpipe-log--repo)
        (email bitpipe-log--email)
        (token bitpipe-log--token)
        (project-dir bitpipe-log--project-dir))
    (if (and workspace repo email token)
        (bitpipe--log-fetch workspace repo email token project-dir
                            (current-buffer))
      (bitpipe-log))))

(defun bitpipe--format-time (iso-string)
  "Format timestamp as relative if within 30 min, otherwise absolute with timezone."
  (if (or (null iso-string) (string-empty-p iso-string))
      ""
    (let* ((then (date-to-time iso-string))
           (elapsed (float-time (time-subtract nil then)))
           (mins (floor (/ elapsed 60))))
      (cond
       ((< mins 1) "just now")
       ((< mins 30) (format "%d min ago" mins))
       (t (format-time-string "%Y-%m-%d %H:%M:%S %Z" then))))))

(defun bitpipe--fetch-commit-messages (hashes project-dir callback)
  "Fetch commit messages for HASHES async, call CALLBACK with hash→message alist."
  (let ((valid (cl-remove-if-not
                (lambda (h) (and h (not (string-empty-p h))))
                hashes)))
    (if (or (null valid) (null project-dir))
        (funcall callback nil)
      (let* ((default-directory project-dir)
             (buf (generate-new-buffer " *bitpipe-git*"))
             (args (append (list "--no-pager" "log" "--no-walk" "--format=%H %s")
                           valid)))
        (make-process
         :name "bitpipe-git-log"
         :buffer buf
         :command (cons "git" args)
         :connection-type 'pipe
         :sentinel
         (lambda (proc _event)
           (when (eq (process-status proc) 'exit)
             (let (result)
               (with-current-buffer (process-buffer proc)
                 (goto-char (point-min))
                 (while (not (eobp))
                   (let ((line (buffer-substring-no-properties
                                (line-beginning-position) (line-end-position))))
                     (when (>= (length line) 41)
                       (let ((full-hash (substring line 0 40))
                            (msg (substring line 41)))
                         (push (cons full-hash msg) result)
                         (when (> (length full-hash) 8)
                           (push (cons (substring full-hash 0 8) msg) result)))))
                   (forward-line 1)))
               (kill-buffer (process-buffer proc))
               (funcall callback result)))))))))

(defun bitpipe--fetch-remote-commit-messages (hashes workspace repo email token callback)
  "Fetch commit messages from Bitbucket API for HASHES, call CALLBACK with alist."
  (if (null hashes)
      (funcall callback nil)
    (let ((remaining (length hashes))
          (result nil)
          (auth (bitpipe--auth-header email token)))
      (dolist (hash hashes)
        (let ((url (format "https://api.bitbucket.org/2.0/repositories/%s/%s/commit/%s"
                           workspace repo hash))
              (url-request-extra-headers
               `(("Authorization" . ,auth))))
          (url-retrieve
           url
           (lambda (status hash)
             (unless (plist-get status :error)
               (goto-char (point-min))
               (when (re-search-forward "^\r?$" nil t)
                 (ignore-errors
                   (let* ((json (json-read))
                          (msg (alist-get 'message json)))
                     (when msg
                       (let ((first-line (car (split-string msg "\n" t))))
                         (when first-line
                           (push (cons (if (> (length hash) 8)
                                           (substring hash 0 8)
                                         hash)
                                       first-line)
                                 result))))))))
             (kill-buffer)
             (cl-decf remaining)
             (when (zerop remaining)
               (funcall callback result)))
           (list hash)
           t t))))))

(defun bitpipe--log-face (result state-name)
  (cond ((equal result "SUCCESSFUL") 'bitpipe-success)
        ((equal state-name "IN_PROGRESS") 'bitpipe-in-progress)
        (t 'bitpipe-failed)))

(defun bitpipe--log-parse-entry (p workspace repo)
  "Parse a pipeline API response P into a plist."
  (let* ((num     (alist-get 'build_number p))
         (state   (alist-get 'state p))
         (result  (alist-get 'name (alist-get 'result state)))
         (sname   (alist-get 'name state))
         (target  (alist-get 'target p))
         (branch  (or (alist-get 'ref_name target) "?"))
         (sel     (or (alist-get 'pattern (alist-get 'selector target)) "default"))
         (commit  (alist-get 'commit target))
         (hash    (or (alist-get 'hash commit) ""))
         (short-hash (if (> (length hash) 8) (substring hash 0 8) hash))
         (short-msg  "...")
         (creator (or (alist-get 'display_name (alist-get 'creator p)) "?"))
         (date    (bitpipe--format-time (alist-get 'created_on p))))
    (list :num num :result (or result sname "?") :branch branch
          :pipeline sel :full-hash hash :hash short-hash
          :message short-msg :msg-resolved nil
          :creator creator :date date
          :face (bitpipe--log-face result sname)
          :url (format "https://bitbucket.org/%s/%s/pipelines/results/%d"
                       workspace repo num))))

(defun bitpipe--col-width (entries key formatter min-width)
  "Compute max width for KEY across ENTRIES, with MIN-WIDTH floor."
  (max min-width
       (cl-loop for e in entries
                maximize (length (funcall formatter (plist-get e key))))))

(defun bitpipe--log-render (entries)
  "Render ENTRIES into a `tabulated-list-mode' buffer."
  (let ((w-num (bitpipe--col-width entries :num
                 (lambda (v) (format "#%d" v)) 2))
        (w-status (bitpipe--col-width entries :result #'identity 6))
        (w-branch (bitpipe--col-width entries :branch #'identity 6))
        (w-pipe (bitpipe--col-width entries :pipeline #'identity 8))
        (w-hash (bitpipe--col-width entries :hash #'identity 6))
        (w-creator (bitpipe--col-width entries :creator #'identity 7))
        (w-date (bitpipe--col-width entries :date #'identity 4)))
    (setq tabulated-list-format
          (vector (list "#" (1+ w-num) t :right-align t)
                  (list "Status" (1+ w-status) t)
                  (list "Pipeline" (1+ w-pipe) t)
                  (list "Branch" (1+ w-branch) t)
                  (list "Commit" (1+ w-hash) t)
                  '("Message" 30 nil)
                  (list "Creator" (1+ w-creator) t)
                  (list "Date" (1+ w-date) t))))
  (setq tabulated-list-entries
        (mapcar #'bitpipe--log-entry-to-row entries))
  (tabulated-list-init-header)
  (tabulated-list-print t)
  (bitpipe--apply-header-face))

(defun bitpipe--apply-header-face ()
  "Make the header line bold."
  (face-remap-set-base 'header-line 'bitpipe-header))

(defun bitpipe--log-entry-to-row (entry)
  "Convert ENTRY plist to a `tabulated-list-entries' row."
  (let ((face (plist-get entry :face)))
    (list (plist-get entry :url)
          (vector (propertize (format "#%d" (plist-get entry :num)) 'face face)
                  (propertize (plist-get entry :result) 'face face)
                  (plist-get entry :pipeline)
                  (plist-get entry :branch)
                  (plist-get entry :hash)
                  (plist-get entry :message)
                  (plist-get entry :creator)
                  (plist-get entry :date)))))

(defun bitpipe--log-fetch (workspace repo email token project-dir buf)
  "Fetch pipelines and render into BUF, then async-resolve commit messages."
  (message "Refreshing pipelines...")
  (let* ((url (format "https://api.bitbucket.org/2.0/repositories/%s/%s/pipelines/?sort=-created_on&pagelen=20"
                      workspace repo))
         (url-request-extra-headers
          `(("Authorization" . ,(bitpipe--auth-header email token)))))
    (with-current-buffer (url-retrieve-synchronously url t t 15)
      (goto-char (point-min))
      (re-search-forward "^\r?$")
      (let* ((resp    (json-read))
             (values  (alist-get 'values resp))
             (entries (mapcar (lambda (p) (bitpipe--log-parse-entry p workspace repo))
                              values))
             (hashes  (mapcar (lambda (e) (plist-get e :full-hash)) entries)))
        (with-current-buffer buf
          (unless (eq major-mode 'bitpipe-log-mode)
            (bitpipe-log-mode))
          (setq bitpipe-log--workspace workspace
                bitpipe-log--repo repo
                bitpipe-log--email email
                bitpipe-log--token token
                bitpipe-log--project-dir project-dir
                bitpipe-log--entries entries)
          (bitpipe--log-render entries))
        (message "Pipelines refreshed.")
        (bitpipe--fetch-commit-messages
         hashes project-dir
         (lambda (msg-alist)
           (when (buffer-live-p buf)
             (with-current-buffer buf
               (dolist (e bitpipe-log--entries)
                 (let* ((hash (plist-get e :hash))
                        (msg (alist-get hash msg-alist nil nil #'equal)))
                   (when msg
                     (plist-put e :message msg)
                     (plist-put e :msg-resolved t))))
               (bitpipe--log-render bitpipe-log--entries)
               (let ((missing (cl-remove-if
                               (lambda (e) (plist-get e :msg-resolved))
                               bitpipe-log--entries)))
                 (when missing
                   (bitpipe--fetch-remote-commit-messages
                    (mapcar (lambda (e) (plist-get e :full-hash)) missing)
                    workspace repo email token
                    (lambda (remote-alist)
                      (when (buffer-live-p buf)
                        (with-current-buffer buf
                          (dolist (e bitpipe-log--entries)
                            (unless (plist-get e :msg-resolved)
                              (let ((msg (alist-get (plist-get e :hash)
                                                    remote-alist nil nil #'equal)))
                                (plist-put e :message (or msg ""))
                                (plist-put e :msg-resolved t))))
                          (bitpipe--log-render bitpipe-log--entries)))))))))))))))

;;;###autoload
(defun bitpipe-log ()
  "Show recent pipeline runs."
  (interactive)
  (let* ((workspace (or bitpipe-workspace (read-string "Workspace: ")))
         (repo      (or bitpipe-repo (bitpipe--infer-repo-slug)))
         (email     (or bitpipe-email (read-string "Email: ")))
         (token     (or bitpipe-api-token (read-passwd "Token: ")))
         (project-dir (when-let ((proj (project-current)))
                        (project-root proj)))
         (buf (get-buffer-create "*bitpipe*")))
    (bitpipe--log-fetch workspace repo email token project-dir buf)
    (pop-to-buffer buf)))

(provide 'bitpipe)
;;; bitpipe.el ends here