os-bb.el 8.6 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260
  1. ;;; os-bb.el --- Bitbucket 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, bitbucket, 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 bitbucket repo with an org-mode buffer. Read
  22. ;; Org-sync documentation for more information about it.
  23. ;; This backend only supports basic synchronization for now.
  24. ;; Components, versions and milestones are ignored.
  25. ;;; Code:
  26. (eval-when-compile (require 'cl))
  27. (require 'os)
  28. (require 'url)
  29. (require 'json)
  30. (defvar url-http-end-of-headers)
  31. (defvar url-http-response-status)
  32. (defvar os-bb-backend
  33. '((base-url . os-bb-base-url)
  34. (fetch-buglist . os-bb-fetch-buglist)
  35. (send-buglist . os-bb-send-buglist))
  36. "Bitbucket backend.")
  37. (defvar os-bb-auth nil
  38. "Bitbucket login (\"user\" . \"pwd\")")
  39. (defun os-bb-request (method url &optional data)
  40. "Send HTTP request at URL using METHOD with DATA.
  41. AUTH is a cons (\"user\" . \"pwd\"). Return the server
  42. decoded response in JSON."
  43. (message "%s %s %s" method url (prin1-to-string data))
  44. (let* ((url-request-method method)
  45. (url-request-data data)
  46. (auth os-bb-auth)
  47. (buf)
  48. (url-request-extra-headers
  49. (unless data
  50. '(("Content-Type" . "application/x-www-form-urlencoded")))))
  51. (if (consp auth)
  52. ;; dynamically bind auth related vars
  53. (let* ((str (concat (car auth) ":" (cdr auth)))
  54. (encoded (base64-encode-string str))
  55. (login `(("api.bitbucket.org:443" ("Bitbucket API" . ,encoded))))
  56. (url-basic-auth-storage 'login))
  57. (setq buf (url-retrieve-synchronously url)))
  58. ;; nothing more to bind
  59. (setq buf (url-retrieve-synchronously url)))
  60. (with-current-buffer buf
  61. (goto-char url-http-end-of-headers)
  62. (prog1
  63. (cons url-http-response-status (ignore-errors (json-read)))
  64. (kill-buffer)))))
  65. ;; override
  66. (defun os-bb-base-url (url)
  67. "Return base URL."
  68. (cond
  69. ;; web ui url
  70. ((string-match "^\\(?:https?://\\)?\\(?:www\\.\\)?bitbucket.org/\\([^/]+\\)/\\([^/]+\\)/?$" url)
  71. (concat "https://api.bitbucket.org/1.0/repositories/"
  72. (match-string 1 url) "/" (match-string 2 url)))
  73. ;; api url
  74. ((string-match "api.bitbucket.org/1.0/repositories" url)
  75. url)))
  76. ;; From https://confluence.atlassian.com/display/BITBUCKET/Issues
  77. ;; title: The title of the new issue.
  78. ;; content: The content of the new issue.
  79. ;; component: The component associated with the issue.
  80. ;; milestone: The milestone associated with the issue.
  81. ;; version: The version associated with the issue.
  82. ;; responsible: The username of the person responsible for the issue.
  83. ;; priority: The priority of the issue. Valid priorities are:
  84. ;; - trivial
  85. ;; - minor
  86. ;; - major
  87. ;; - critical
  88. ;; - blocker
  89. ;; status: The status of the issue. Valid statuses are:
  90. ;; - new
  91. ;; - open
  92. ;; - resolved
  93. ;; - on hold
  94. ;; - invalid
  95. ;; - duplicate
  96. ;; - wontfix
  97. ;; kind: The kind of issue. Valid kinds are:
  98. ;; - bug
  99. ;; - enhancement
  100. ;; - proposal
  101. ;; - task
  102. (defconst os-bb-priority-list
  103. '("trivial" "minor" "major" "critical" "blocker")
  104. "List of valid priority for a bitbucket issue.")
  105. (defconst os-bb-status-list
  106. '("new" "open" "resolved" "on hold" "invalid" "duplicate" "wontfix")
  107. "List of valid status for a bitbucket issue.")
  108. (defconst os-bb-kind-list
  109. '("bug" "enhancement" "proposal" "task")
  110. "List of valid kind for a bitbucket issue.")
  111. (defun os-bb-bug-to-form (bug)
  112. "Return BUG as an form alist."
  113. (let* ((priority (os-get-prop :priority bug))
  114. (title (os-get-prop :title bug))
  115. (desc (os-get-prop :desc bug))
  116. (assignee (os-get-prop :assignee bug))
  117. (status (if (eq (os-get-prop :status bug) 'open) "open" "resolved"))
  118. (kind (os-get-prop :kind bug)))
  119. (if (and priority (not (member priority os-bb-priority-list)))
  120. (error "Invalid priority \"%s\" at bug \"%s\"." priority title))
  121. (if (and kind (not (member kind os-bb-kind-list)))
  122. (error "Invalid kind \"%s\" at bug \"%s\"." kind title))
  123. (remove-if (lambda (x)
  124. (null (cdr x)))
  125. `(("title" . ,title)
  126. ("status" . ,status)
  127. ("content" . ,desc)
  128. ("responsible" . ,assignee)
  129. ("priority" . ,priority)
  130. ("kind" . ,kind)))))
  131. (defun os-bb-post-encode (args)
  132. "Return form alist ARGS as a url-encoded string."
  133. (mapconcat (lambda (arg)
  134. (concat (url-hexify-string (car arg))
  135. "="
  136. (url-hexify-string (cdr arg))))
  137. args "&"))
  138. (defun os-bb-repo-name (url)
  139. "Return repo name at URL."
  140. (when (string-match "api\\.bitbucket.org/1\\.0/repositories/\\([^/]+\\)/\\([^/]+\\)" url)
  141. (match-string 2 url)))
  142. (defun os-bb-repo-user (url)
  143. "Return repo username at URL."
  144. (when (string-match "api\\.bitbucket.org/1\\.0/repositories/\\([^/]+\\)/\\([^/]+\\)" url)
  145. (match-string 1 url)))
  146. ;; override
  147. (defun os-bb-fetch-buglist (last-update)
  148. "Return the buglist at os-base-url."
  149. (let* ((url (concat os-base-url "/issues"))
  150. (res (os-bb-request "GET" url))
  151. (code (car res))
  152. (json (cdr res))
  153. (title (concat "Bugs of " (os-bb-repo-name url))))
  154. `(:title ,title
  155. :url ,os-base-url
  156. :bugs ,(mapcar 'os-bb-json-to-bug (cdr (assoc 'issues json))))))
  157. (defun os-bb-json-to-bug (json)
  158. "Return JSON as a bug."
  159. (flet ((va (key alist) (cdr (assoc key alist)))
  160. (v (key) (va key json)))
  161. (let* ((id (v 'local_id))
  162. (metadata (v 'metadata))
  163. (kind (va 'kind metadata))
  164. (version (va 'version metadata))
  165. (component (va 'component metadata))
  166. (milestone (va 'milestone metadata))
  167. (author (va 'username (v 'reported_by)))
  168. (assignee (va 'username (v 'responsible)))
  169. (txtstatus (v 'status))
  170. (status (if (or (string= txtstatus "open")
  171. (string= txtstatus "new"))
  172. 'open
  173. 'closed))
  174. (priority (v 'priority))
  175. (title (v 'title))
  176. (desc (v 'content))
  177. (ctime (os-parse-date (v 'utc_created_on)))
  178. (mtime (os-parse-date (v 'utc_last_updated))))
  179. `(:id ,id
  180. :priority ,priority
  181. :assignee ,assignee
  182. :status ,status
  183. :title ,title
  184. :desc ,desc
  185. :date-creation ,ctime
  186. :date-modification ,mtime
  187. :kind ,kind
  188. :version ,version
  189. :component ,component
  190. :milestone ,milestone))))
  191. ;; override
  192. (defun os-bb-send-buglist (buglist)
  193. "Send a BUGLIST on the bugtracker and return new bugs."
  194. (let* ((new-url (concat os-base-url "/issues"))
  195. (new-bugs))
  196. (dolist (b (os-get-prop :bugs buglist))
  197. (let* ((id (os-get-prop :id b))
  198. (data (os-bb-post-encode (os-bb-bug-to-form b)))
  199. (modif-url (format "%s/%d/" new-url (or id 0)))
  200. res)
  201. (cond
  202. ;; new bug
  203. ((null id)
  204. (setq res (os-bb-request "POST" new-url data))
  205. (when (/= (car res) 200)
  206. (error "Can't create new bug \"%s\"" (os-get-prop :title b)))
  207. (push (os-bb-json-to-bug (cdr res)) new-bugs))
  208. ;; delete bug
  209. ((os-get-prop :delete b)
  210. (setq res (os-bb-request "DELETE" modif-url))
  211. (when (not (member (car res) '(404 204)))
  212. (error "Can't delete bug #%d" id)))
  213. ;; update bug
  214. (t
  215. (setq res (os-bb-request "PUT" modif-url data))
  216. (when (/= (car res) 200)
  217. (error "Can't update bug #%id" id))
  218. (push (os-bb-json-to-bug (cdr res)) new-bugs)))))
  219. `(:bugs ,new-bugs)))
  220. ;;; os-bb.el ends here