366 lines
11 KiB
EmacsLisp
366 lines
11 KiB
EmacsLisp
|
;;; private/grfn/org-clubhouse.el
|
||
|
|
|
||
|
|
(require 'dash)
|
||
|
|
(require 'dash-functional)
|
||
|
|
(require 's)
|
||
|
|
(require 'org)
|
||
|
|
(require 'org-element)
|
||
|
|
(require 'cl)
|
||
|
|
|
||
|
|
;;;
|
||
|
|
;;; Configuration
|
||
|
|
;;;
|
||
|
|
|
||
|
|
(defvar org-clubhouse-auth-token nil
|
||
|
|
"Authorization token for the Clubhouse API")
|
||
|
|
|
||
|
|
(defvar org-clubhouse-team-name nil
|
||
|
|
"Team name to use in links to Clubhouse
|
||
|
|
ie https://app.clubhouse.io/<TEAM_NAME>/stories")
|
||
|
|
|
||
|
|
(defvar org-clubhouse-project-ids nil
|
||
|
|
"Specific list of project IDs to synchronize with clubhouse.
|
||
|
|
If unset all projects will be synchronized")
|
||
|
|
|
||
|
|
(defvar org-clubhouse-workflow-name "Default")
|
||
|
|
|
||
|
|
(defvar org-clubhouse-state-alist
|
||
|
|
'(("LATER" . "Unscheduled")
|
||
|
|
("[ ]" . "Ready for Development")
|
||
|
|
("TODO" . "Ready for Development")
|
||
|
|
("OPEN" . "Ready for Development")
|
||
|
|
("ACTIVE" . "In Development")
|
||
|
|
("PR" . "Review")
|
||
|
|
("DONE" . "Merged")
|
||
|
|
("[X]" . "Merged")
|
||
|
|
("CLOSED" . "Merged")))
|
||
|
|
|
||
|
|
;;;
|
||
|
|
;;; Utilities
|
||
|
|
;;;
|
||
|
|
|
||
|
|
(defun ->list (vec) (append vec nil))
|
||
|
|
|
||
|
|
(defun reject-archived (item-list)
|
||
|
|
(-filter (lambda (item) (equal :json-false (alist-get 'archived item))) item-list))
|
||
|
|
|
||
|
|
(defun alist->plist (key-map alist)
|
||
|
|
(->> key-map
|
||
|
|
(-map (lambda (key-pair)
|
||
|
|
(let ((alist-key (car key-pair))
|
||
|
|
(plist-key (cdr key-pair)))
|
||
|
|
(list plist-key (alist-get alist-key alist)))))
|
||
|
|
(-flatten-n 1)))
|
||
|
|
|
||
|
|
(defun alist-get-equal (key alist)
|
||
|
|
"Like `alist-get', but uses `equal' instead of `eq' for comparing keys"
|
||
|
|
(->> alist
|
||
|
|
(-find (lambda (pair) (equal key (car pair))))
|
||
|
|
(cdr)))
|
||
|
|
|
||
|
|
;;;
|
||
|
|
;;; Org-element interaction
|
||
|
|
;;;
|
||
|
|
|
||
|
|
;; (defun org-element-find-headline ()
|
||
|
|
;; (let ((current-elt (org-element-at-point)))
|
||
|
|
;; (if (equal 'headline (car current-elt))
|
||
|
|
;; current-elt
|
||
|
|
;; (let* ((elt-attrs (cadr current-elt))
|
||
|
|
;; (parent (plist-get elt-attrs :post-affiliated)))
|
||
|
|
;; (goto-char parent)
|
||
|
|
;; (org-element-find-headline)))))
|
||
|
|
|
||
|
|
(defun org-element-find-headline ()
|
||
|
|
(let ((current-elt (org-element-at-point)))
|
||
|
|
(when (equal 'headline (car current-elt))
|
||
|
|
(cadr current-elt))))
|
||
|
|
|
||
|
|
(defun org-element-extract-clubhouse-id (elt)
|
||
|
|
(when-let ((clubhouse-id-link (plist-get elt :CLUBHOUSE-ID)))
|
||
|
|
(string-match
|
||
|
|
(rx "[[" (one-or-more anything) "]"
|
||
|
|
"[" (group (one-or-more digit)) "]]")
|
||
|
|
clubhouse-id-link)
|
||
|
|
(string-to-int (match-string 1 clubhouse-id-link))))
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
(defun org-element-clubhouse-id ()
|
||
|
|
(org-element-extract-clubhouse-id
|
||
|
|
(org-element-find-headline)))
|
||
|
|
|
||
|
|
;;;
|
||
|
|
;;; API integration
|
||
|
|
;;;
|
||
|
|
|
||
|
|
(defvar org-clubhouse-base-url* "https://api.clubhouse.io/api/v2")
|
||
|
|
|
||
|
|
(defun org-clubhouse-auth-url (url)
|
||
|
|
(concat url
|
||
|
|
"?"
|
||
|
|
(url-build-query-string
|
||
|
|
`(("token" ,org-clubhouse-auth-token)))))
|
||
|
|
|
||
|
|
(defun org-clubhouse-baseify-url (url)
|
||
|
|
(if (s-starts-with? org-clubhouse-base-url* url) url
|
||
|
|
(concat org-clubhouse-base-url*
|
||
|
|
(if (s-starts-with? "/" url) url
|
||
|
|
(concat "/" url)))))
|
||
|
|
|
||
|
|
(defun org-clubhouse-request (method url &optional data)
|
||
|
|
(message "%s %s %s" method url (prin1-to-string data))
|
||
|
|
(let* ((url-request-method method)
|
||
|
|
(url-request-extra-headers
|
||
|
|
'(("Content-Type" . "application/json")))
|
||
|
|
(url-request-data data)
|
||
|
|
(buf))
|
||
|
|
|
||
|
|
(setq url (-> url
|
||
|
|
org-clubhouse-baseify-url
|
||
|
|
org-clubhouse-auth-url))
|
||
|
|
|
||
|
|
(setq buf (url-retrieve-synchronously url))
|
||
|
|
|
||
|
|
(with-current-buffer buf
|
||
|
|
(goto-char url-http-end-of-headers)
|
||
|
|
(prog1 (json-read) (kill-buffer)))))
|
||
|
|
|
||
|
|
(cl-defun to-id-name-pairs
|
||
|
|
(seq &optional (id-attr 'id) (name-attr 'name))
|
||
|
|
(->> seq
|
||
|
|
->list
|
||
|
|
(-map (lambda (resource)
|
||
|
|
(cons (alist-get id-attr resource)
|
||
|
|
(alist-get name-attr resource))))))
|
||
|
|
|
||
|
|
(cl-defun org-clubhouse-fetch-as-id-name-pairs
|
||
|
|
(resource &optional
|
||
|
|
(id-attr 'id)
|
||
|
|
(name-attr 'name))
|
||
|
|
"Returns the given resource from clubhouse as (id . name) pairs"
|
||
|
|
(let ((resp-json (org-clubhouse-request "GET" resource)))
|
||
|
|
(-> resp-json
|
||
|
|
->list
|
||
|
|
reject-archived
|
||
|
|
(to-id-name-pairs id-attr name-attr))))
|
||
|
|
|
||
|
|
(defun org-clubhouse-link-to-story (story-id)
|
||
|
|
(format "https://app.clubhouse.io/%s/story/%d"
|
||
|
|
org-clubhouse-team-name
|
||
|
|
story-id))
|
||
|
|
|
||
|
|
(defun org-clubhouse-link-to-epic (epic-id)
|
||
|
|
(format "https://app.clubhouse.io/%s/epic/%d"
|
||
|
|
org-clubhouse-team-name
|
||
|
|
epic-id))
|
||
|
|
|
||
|
|
(defun org-clubhouse-link-to-project (project-id)
|
||
|
|
(format "https://app.clubhouse.io/%s/project/%d"
|
||
|
|
org-clubhouse-team-name
|
||
|
|
project-id))
|
||
|
|
|
||
|
|
;;;
|
||
|
|
;;; Caching
|
||
|
|
;;;
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
(defvar org-clubhouse-cache-clear-functions ())
|
||
|
|
|
||
|
|
(defmacro defcache (name &optional docstring &rest body)
|
||
|
|
(let* ((doc (when docstring (list docstring)))
|
||
|
|
(cache-var-name (intern (concat (symbol-name name)
|
||
|
|
"-cache")))
|
||
|
|
(clear-cache-function-name
|
||
|
|
(intern (concat "clear-" (symbol-name cache-var-name)))))
|
||
|
|
`(progn
|
||
|
|
(defvar ,cache-var-name :no-cache)
|
||
|
|
(defun ,name ()
|
||
|
|
,@doc
|
||
|
|
(when (equal :no-cache ,cache-var-name)
|
||
|
|
(setq ,cache-var-name (progn ,@body)))
|
||
|
|
,cache-var-name)
|
||
|
|
(defun ,clear-cache-function-name ()
|
||
|
|
(interactive)
|
||
|
|
(setq ,cache-var-name :no-cache))
|
||
|
|
|
||
|
|
(push (quote ,clear-cache-function-name)
|
||
|
|
org-clubhouse-cache-clear-functions))))
|
||
|
|
|
||
|
|
(defun org-clubhouse-clear-cache ()
|
||
|
|
(interactive)
|
||
|
|
(-map #'funcall org-clubhouse-cache-clear-functions))
|
||
|
|
|
||
|
|
;;;
|
||
|
|
;;; API resource functions
|
||
|
|
;;;
|
||
|
|
|
||
|
|
(defcache org-clubhouse-projects
|
||
|
|
"Returns projects as (project-id . name)"
|
||
|
|
(org-clubhouse-fetch-as-id-name-pairs "projects"))
|
||
|
|
|
||
|
|
(defcache org-clubhouse-epics
|
||
|
|
"Returns projects as (project-id . name)"
|
||
|
|
(org-clubhouse-fetch-as-id-name-pairs "epics"))
|
||
|
|
|
||
|
|
(defcache org-clubhouse-workflow-states
|
||
|
|
"Returns worflow states as (name . id) pairs"
|
||
|
|
(let* ((resp-json (org-clubhouse-request "GET" "workflows"))
|
||
|
|
(workflows (->list resp-json))
|
||
|
|
;; just assume it exists, for now
|
||
|
|
(workflow (-find (lambda (workflow)
|
||
|
|
(equal org-clubhouse-workflow-name
|
||
|
|
(alist-get 'name workflow)))
|
||
|
|
workflows))
|
||
|
|
(states (->list (alist-get 'states workflow))))
|
||
|
|
(to-id-name-pairs states
|
||
|
|
'name
|
||
|
|
'id)))
|
||
|
|
|
||
|
|
(defun org-clubhouse-stories-in-project (project-id)
|
||
|
|
"Returns the stories in the given project as org bugs"
|
||
|
|
(let ((resp-json (org-clubhouse-request "GET" (format "/projects/%d/stories" project-id))))
|
||
|
|
(->> resp-json ->list reject-archived
|
||
|
|
(-reject (lambda (story) (equal :json-true (alist-get 'completed story))))
|
||
|
|
(-map (lambda (story)
|
||
|
|
(cons
|
||
|
|
(cons 'status
|
||
|
|
(cond
|
||
|
|
((equal :json-true (alist-get 'started story))
|
||
|
|
'started)
|
||
|
|
((equal :json-true (alist-get 'completed story))
|
||
|
|
'completed)
|
||
|
|
('t
|
||
|
|
'open)))
|
||
|
|
story)))
|
||
|
|
(-map (-partial #'alist->plist
|
||
|
|
'((name . :title)
|
||
|
|
(id . :id)
|
||
|
|
(status . :status)))))))
|
||
|
|
|
||
|
|
;;;
|
||
|
|
;;; Story creation
|
||
|
|
;;;
|
||
|
|
|
||
|
|
(cl-defun org-clubhouse-create-story-internal
|
||
|
|
(title &key project-id epic-id)
|
||
|
|
(assert (and (stringp title)
|
||
|
|
(integerp project-id)
|
||
|
|
(or (null epic-id) (integerp epic-id))))
|
||
|
|
(org-clubhouse-request
|
||
|
|
"POST"
|
||
|
|
"stories"
|
||
|
|
(json-encode
|
||
|
|
`((name . ,title)
|
||
|
|
(project_id . ,project-id)
|
||
|
|
(epic_id . ,epic-id)))))
|
||
|
|
|
||
|
|
(defun org-clubhouse-prompt-for-project (cb)
|
||
|
|
(ivy-read
|
||
|
|
"Select a project: "
|
||
|
|
(-map #'cdr (org-clubhouse-projects))
|
||
|
|
:require-match t
|
||
|
|
:history 'org-clubhouse-project-history
|
||
|
|
:action (lambda (selected)
|
||
|
|
(let ((project-id
|
||
|
|
(->> (org-clubhouse-projects)
|
||
|
|
(-find (lambda (proj)
|
||
|
|
(string-equal (cdr proj) selected)))
|
||
|
|
car)))
|
||
|
|
(message "%d" project-id)
|
||
|
|
(funcall cb project-id)))))
|
||
|
|
|
||
|
|
(defun org-clubhouse-prompt-for-epic (cb)
|
||
|
|
(ivy-read
|
||
|
|
"Select an epic: "
|
||
|
|
(-map #'cdr (org-clubhouse-epics))
|
||
|
|
:history 'org-clubhouse-epic-history
|
||
|
|
:action (lambda (selected)
|
||
|
|
(let ((epic-id
|
||
|
|
(->> (org-clubhouse-epics)
|
||
|
|
(-find (lambda (proj)
|
||
|
|
(string-equal (cdr proj) selected)))
|
||
|
|
car)))
|
||
|
|
(message "%d" epic-id)
|
||
|
|
(funcall cb epic-id)))))
|
||
|
|
|
||
|
|
(defun org-clubhouse-populate-created-story (story)
|
||
|
|
(let ((elt (org-element-find-headline))
|
||
|
|
(story-id (alist-get 'id story))
|
||
|
|
(epic-id (alist-get 'epic_id story))
|
||
|
|
(project-id (alist-get 'project_id story)))
|
||
|
|
|
||
|
|
(org-set-property "clubhouse-id"
|
||
|
|
(org-make-link-string
|
||
|
|
(org-clubhouse-link-to-story story-id)
|
||
|
|
(number-to-string story-id)))
|
||
|
|
|
||
|
|
(org-set-property "clubhouse-epic"
|
||
|
|
(org-make-link-string
|
||
|
|
(org-clubhouse-link-to-epic epic-id)
|
||
|
|
(alist-get epic-id (org-clubhouse-epics))))
|
||
|
|
|
||
|
|
(org-set-property "clubhouse-project"
|
||
|
|
(org-make-link-string
|
||
|
|
(org-clubhouse-link-to-project project-id)
|
||
|
|
(alist-get project-id (org-clubhouse-projects))))
|
||
|
|
|
||
|
|
(org-todo "TODO")))
|
||
|
|
|
||
|
|
(defun org-clubhouse-create-story ()
|
||
|
|
(interactive)
|
||
|
|
;; (message (org-element-find-headline))
|
||
|
|
(when-let ((elt (org-element-find-headline))
|
||
|
|
(title (plist-get elt :title)))
|
||
|
|
(if (plist-get elt :CLUBHOUSE-ID)
|
||
|
|
(message "This headline is already a clubhouse story!")
|
||
|
|
(org-clubhouse-prompt-for-project
|
||
|
|
(lambda (project-id)
|
||
|
|
(when project-id
|
||
|
|
(org-clubhouse-prompt-for-epic
|
||
|
|
(lambda (epic-id)
|
||
|
|
(let* ((story (org-clubhouse-create-story-internal
|
||
|
|
title
|
||
|
|
:project-id project-id
|
||
|
|
:epic-id epic-id)))
|
||
|
|
(org-clubhouse-populate-created-story story))))))))))
|
||
|
|
|
||
|
|
;;;
|
||
|
|
;;; Story updates
|
||
|
|
;;;
|
||
|
|
|
||
|
|
(cl-defun org-clubhouse-update-story-internal
|
||
|
|
(story-id &rest attrs)
|
||
|
|
(assert (and (integerp story-id)
|
||
|
|
(listp attrs)))
|
||
|
|
(org-clubhouse-request
|
||
|
|
"PUT"
|
||
|
|
(format "stories/%d" story-id)
|
||
|
|
(json-encode attrs)))
|
||
|
|
|
||
|
|
(defun org-clubhouse-update-status ()
|
||
|
|
(when-let (clubhouse-id (org-element-clubhouse-id))
|
||
|
|
(let* ((elt (org-element-find-headline))
|
||
|
|
(todo-keyword (-> elt (plist-get :todo-keyword) (substring-no-properties))))
|
||
|
|
(message todo-keyword)
|
||
|
|
(when-let ((clubhouse-workflow-state
|
||
|
|
(alist-get-equal todo-keyword org-clubhouse-state-alist))
|
||
|
|
(workflow-state-id
|
||
|
|
(alist-get-equal clubhouse-workflow-state (org-clubhouse-workflow-states))))
|
||
|
|
(org-clubhouse-update-story-internal
|
||
|
|
clubhouse-id
|
||
|
|
:workflow_state_id workflow-state-id)
|
||
|
|
(message "Successfully updated clubhouse status to \"%s\""
|
||
|
|
clubhouse-workflow-state)))))
|
||
|
|
|
||
|
|
(define-minor-mode org-clubhouse-mode
|
||
|
|
:init-value nil
|
||
|
|
:group 'org
|
||
|
|
:lighter "Org-Clubhouse"
|
||
|
|
:keymap '()
|
||
|
|
(add-hook 'org-after-todo-state-change-hook
|
||
|
|
'org-clubhouse-update-status
|
||
|
|
nil
|
||
|
|
t))
|