path: root/emacs/.emacs.d/vendor/org-clubhouse.el

;;; 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))