os-github.el 9.5 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272
  1. ;;; os-github.el --- Redmine backend for org-sync.
  2. ;; Copyright (C) 2012 Aurelien Aptel
  3. ;;
  4. ;; Author: Aurelien Aptel <aurelien dot aptel at gmail dot com>
  5. ;; Keywords: org, github, synchronization
  6. ;; Homepage: http://orgmode.org/worg/org-contrib/gsoc2012/student-projects/org-sync
  7. ;;
  8. ;; This program is free software; you can redistribute it and/or modify
  9. ;; it under the terms of the GNU General Public License as published by
  10. ;; the Free Software Foundation, either version 3 of the License, or
  11. ;; (at your option) any later version.
  12. ;; This program is distributed in the hope that it will be useful,
  13. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15. ;; GNU General Public License for more details.
  16. ;; This file is not part of GNU Emacs.
  17. ;; You should have received a copy of the GNU General Public License
  18. ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
  19. ;;; Commentary:
  20. ;; This package implements a backend for org-sync to synchnonize
  21. ;; issues from a github tracker with an org-mode buffer. Read
  22. ;; Org-sync documentation for more information about it.
  23. ;; This backend supports basic bug synching along with tag creation.
  24. ;; If you add or change the tags of an issue to something that doesn't
  25. ;; exists, it will be created.
  26. ;;; Code:
  27. (eval-when-compile (require 'cl))
  28. (require 'url)
  29. (require 'os)
  30. (require 'json)
  31. (defvar os-github-backend
  32. '((base-url . os-github-base-url)
  33. (fetch-buglist . os-github-fetch-buglist)
  34. (send-buglist . os-github-send-buglist))
  35. "Github backend.")
  36. (defvar url-http-end-of-headers)
  37. (defvar os-github-auth nil
  38. "Github login (\"user\" . \"pwd\")")
  39. (defun os-github-fetch-labels ()
  40. "Return list of labels at os-base-url."
  41. (let* ((url (concat os-base-url "/labels"))
  42. (json (os-github-fetch-json url)))
  43. (mapcar (lambda (x)
  44. (cdr (assoc 'name x)))
  45. json)))
  46. (defun os-github-random-color ()
  47. "Return a random hex color code 6 characters string without #."
  48. (random t)
  49. (format "%02X%02X%02X" (random 256) (random 256) (random 256)))
  50. (defun os-github-color-p (color)
  51. "Return non-nil if COLOR is a valid color code."
  52. (and (stringp color) (string-match "^[0-9a-fA-F]\\{6\\}$" color)))
  53. (defun os-github-create-label (label &optional color)
  54. "Create new COLOR LABEL at os-base-url and return it.
  55. LABEL must be a string. COLOR must be a 6 characters string
  56. containing a hex color code without the #. Take a random color
  57. when not given."
  58. (let* ((url (concat os-base-url "/labels"))
  59. (json (json-encode `((name . ,label)
  60. (color . ,(if (os-github-color-p color)
  61. color
  62. (os-github-random-color)))))))
  63. (os-github-request "POST" url json)))
  64. (defun os-github-handle-tags (bug existing-tags)
  65. "Create any label in BUG that is not in EXISTING-TAGS.
  66. Append new tags in EXISTING-TAGS by side effects."
  67. (let* ((tags (os-get-prop :tags bug)))
  68. (dolist (tag tags)
  69. (when (os-append! tag existing-tags)
  70. (os-github-create-label tag)))))
  71. (defun os-github-time-to-string (time)
  72. "Return TIME as a full ISO 8601 date string, but without timezone adjustments (which github doesn't support"
  73. (format-time-string "%Y-%m-%dT%TZ" time t))
  74. ;; override
  75. (defun os-github-fetch-buglist (last-update)
  76. "Return the buglist at os-base-url."
  77. (let* ((since (when last-update
  78. (format "&since=%s" (os-github-time-to-string last-update))))
  79. (url (concat os-base-url "/issues?per_page=100" since))
  80. (json (vconcat (os-github-fetch-json url)
  81. (os-github-fetch-json (concat url "&state=closed"))))
  82. (title (concat "Bugs of " (os-github-repo-name url))))
  83. `(:title ,title
  84. :url ,os-base-url
  85. :bugs ,(mapcar 'os-github-json-to-bug json)
  86. :since ,last-update)))
  87. ;; override
  88. (defun os-github-base-url (url)
  89. "Return base url."
  90. (when (string-match "github.com/\\(?:repos/\\)?\\([^/]+\\)/\\([^/]+\\)" url)
  91. (let ((user (match-string 1 url))
  92. (repo (match-string 2 url)))
  93. (concat "https://api.github.com/repos/" user "/" repo ""))))
  94. ;; override
  95. (defun os-github-send-buglist (buglist)
  96. "Send a BUGLIST on the bugtracker and return new bugs."
  97. (let* ((new-url (concat os-base-url "/issues"))
  98. (existing-tags (os-github-fetch-labels))
  99. (newbugs))
  100. (dolist (b (os-get-prop :bugs buglist))
  101. (let* ((sync (os-get-prop :sync b))
  102. (id (os-get-prop :id b))
  103. (data (os-github-bug-to-json b))
  104. (modif-url (format "%s/%d" new-url (or id 0)))
  105. (result
  106. (cond
  107. ;; new bug
  108. ((null id)
  109. (os-github-handle-tags b existing-tags)
  110. (push (os-github-json-to-bug
  111. (os-github-request "POST" new-url data)) newbugs))
  112. ;; update bug
  113. (t
  114. (os-github-handle-tags b existing-tags)
  115. (os-github-request "PATCH" modif-url data))))
  116. (err (cdr (assoc 'message result))))
  117. (when (stringp err)
  118. (error "Github: %s" err))))
  119. `(:bugs ,newbugs)))
  120. (defun os-github-fetch-json (url)
  121. "Return a parsed JSON object of all the pages of URL."
  122. (let* ((ret (os-github-fetch-json-page url))
  123. (data (car ret))
  124. (url (cdr ret))
  125. (json data))
  126. (while url
  127. (setq ret (os-github-fetch-json-page url))
  128. (setq data (car ret))
  129. (setq url (cdr ret))
  130. (setq json (vconcat json data)))
  131. json))
  132. (defun os-github-url-retrieve-synchronously (url)
  133. "Retrieve the specified url using authentication data from
  134. os-github-auth. AUTH is a cons (\"user\" . \"pwd\")."
  135. (let ((auth os-github-auth))
  136. (if (consp auth)
  137. ;; dynamically bind auth related vars
  138. (let* ((str (concat (car auth) ":" (cdr auth)))
  139. (encoded (base64-encode-string str))
  140. (login `(("api.github.com:443" ("Github API" . ,encoded))))
  141. (url-basic-auth-storage 'login))
  142. (url-retrieve-synchronously url))
  143. ;; nothing more to bind
  144. (url-retrieve-synchronously url))))
  145. (defun os-github-fetch-json-page (url)
  146. "Return a cons (JSON object from URL . next page url)."
  147. (let ((download-buffer (os-github-url-retrieve-synchronously url))
  148. page-next
  149. header-end
  150. ret)
  151. (with-current-buffer download-buffer
  152. ;; get HTTP header end position
  153. (goto-char (point-min))
  154. (re-search-forward "^$" nil 'move)
  155. (forward-char)
  156. (setq header-end (point))
  157. ;; get next page url
  158. (goto-char (point-min))
  159. (when (re-search-forward
  160. "<\\(https://api.github.com.+?page=[0-9]+.*?\\)>; rel=\"next\""
  161. header-end t)
  162. (setq page-next (match-string 1)))
  163. (goto-char header-end)
  164. (setq ret (cons (json-read) page-next))
  165. (kill-buffer)
  166. ret)))
  167. (defun os-github-request (method url &optional data)
  168. "Send HTTP request at URL using METHOD with DATA.
  169. Return the server decoded JSON response."
  170. (message "%s %s %s" method url (prin1-to-string data))
  171. (let* ((url-request-method method)
  172. (url-request-data data)
  173. (buf (os-github-url-retrieve-synchronously url)))
  174. (with-current-buffer buf
  175. (goto-char url-http-end-of-headers)
  176. (prog1 (json-read) (kill-buffer)))))
  177. (defun os-github-repo-name (url)
  178. "Return the name of the repo at URL."
  179. (if (string-match "github.com/repos/[^/]+/\\([^/]+\\)" url)
  180. (match-string 1 url)
  181. "<project name>"))
  182. ;; XXX: we need an actual markdown parser here...
  183. (defun os-github-filter-desc (desc)
  184. "Return a filtered description of a GitHub description."
  185. (if desc (progn
  186. (setq desc (replace-regexp-in-string "\r\n" "\n" desc))
  187. (setq desc (replace-regexp-in-string "\\([^ \t\n]\\)[ \t\n]*\\'"
  188. "\\1\n" desc)))))
  189. (defun os-github-json-to-bug (data)
  190. "Return DATA (in json) converted to a bug."
  191. (flet ((va (key alist) (cdr (assoc key alist)))
  192. (v (key) (va key data)))
  193. (let* ((id (v 'number))
  194. (stat (if (string= (v 'state) "open") 'open 'closed))
  195. (title (v 'title))
  196. (desc (os-github-filter-desc (v 'body)))
  197. (author (va 'login (v 'user)))
  198. (assignee (va 'login (v 'assignee)))
  199. (milestone-alist (v 'milestone))
  200. (milestone (va 'title milestone-alist))
  201. (ctime (os-parse-date (v 'created_at)))
  202. (dtime (os-parse-date (va 'due_on milestone-alist)))
  203. (mtime (os-parse-date (v 'updated_at)))
  204. (tags (mapcar (lambda (e)
  205. (va 'name e)) (v 'labels))))
  206. `(:id ,id
  207. :author ,author
  208. :assignee ,assignee
  209. :status ,stat
  210. :title ,title
  211. :desc ,desc
  212. :milestone ,milestone
  213. :tags ,tags
  214. :date-deadline ,dtime
  215. :date-creation ,ctime
  216. :date-modification ,mtime))))
  217. (defun os-github-bug-to-json (bug)
  218. "Return BUG as JSON."
  219. (let ((state (os-get-prop :status bug)))
  220. (unless (member state '(open closed))
  221. (error "Github: unsupported state \"%s\"" (symbol-name state)))
  222. (json-encode
  223. `((title . ,(os-get-prop :title bug))
  224. (body . ,(os-get-prop :desc bug))
  225. (assignee . ,(os-get-prop :assignee bug))
  226. (state . ,(symbol-name (os-get-prop :status bug)))
  227. (labels . [ ,@(os-get-prop :tags bug) ])))))
  228. ;;; os-github.el ends here