os-rmine.el 7.2 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221
  1. ;;; os-rmine.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, redmine, 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 redmine repo with an org-mode buffer. Read Org-sync
  22. ;; documentation for more information about it.
  23. ;;; Code:
  24. (eval-when-compile (require 'cl))
  25. (require 'os)
  26. (require 'url)
  27. (require 'json)
  28. (defvar url-http-end-of-headers)
  29. (defvar url-http-response-status)
  30. (defvar os-rmine-backend
  31. '((base-url . os-rmine-base-url)
  32. (fetch-buglist . os-rmine-fetch-buglist)
  33. (send-buglist . os-rmine-send-buglist))
  34. "Redmine backend.")
  35. (defvar os-rmine-auth nil
  36. "Redmine login (\"user\" . \"pwd\")")
  37. (defvar os-rmine-project-id nil
  38. "Project id of current buglist.")
  39. (defconst os-rmine-date-regex
  40. (rx
  41. (seq
  42. (group (repeat 4 digit)) "/"
  43. (group (repeat 2 digit)) "/"
  44. (group (repeat 2 digit))
  45. " "
  46. (group
  47. (repeat 2 digit) ":"
  48. (repeat 2 digit) ":"
  49. (repeat 2 digit))
  50. " "
  51. (group (or "+" "-")
  52. (repeat 2 digit)
  53. (repeat 2 digit))))
  54. "Regex to parse date returned by redmine.")
  55. (defun os-rmine-fetch-meta ()
  56. "Set `os-rmine-project-id' for now."
  57. (let* ((res (os-rmine-request "GET" (concat os-base-url ".json")))
  58. (code (car res))
  59. (json (cdr res)))
  60. (when (/= code 200)
  61. (error "Can't fetch data from %s, wrong url?" os-base-url))
  62. (setq os-rmine-project-id (cdr (assoc 'id (cdr (assoc 'project json)))))))
  63. (defun os-rmine-parse-date (date)
  64. "Return time object of DATE."
  65. (when (string-match os-rmine-date-regex date)
  66. (os-parse-date (concat (match-string 1 date) "-"
  67. (match-string 2 date) "-"
  68. (match-string 3 date) "T"
  69. (match-string 4 date)
  70. (match-string 5 date)))))
  71. (defun os-rmine-request (method url &optional data)
  72. "Send HTTP request at URL using METHOD with DATA.
  73. AUTH is a cons (\"user\" . \"pwd\"). Return the server
  74. decoded response in JSON."
  75. (let* ((url-request-method method)
  76. (url-request-data data)
  77. (url-request-extra-headers
  78. (when data
  79. '(("Content-Type" . "application/json"))))
  80. (auth os-rmine-auth)
  81. (buf))
  82. (when (stringp auth)
  83. (setq url (os-url-param url `(("key" . ,auth)))))
  84. (message "%s %s %s" method url (prin1-to-string data))
  85. (setq buf (url-retrieve-synchronously url))
  86. (with-current-buffer buf
  87. (goto-char url-http-end-of-headers)
  88. (prog1
  89. (cons url-http-response-status (ignore-errors (json-read)))
  90. (kill-buffer)))))
  91. ;; override
  92. (defun os-rmine-base-url (url)
  93. "Return base URL."
  94. ;; if no url type, try http
  95. (when (not (string-match "^https?://" url))
  96. (setq url (concat "http://" url)))
  97. (let ((purl (url-generic-parse-url url)))
  98. (when (string-match "^.*/projects/\\([^/]+\\)" (url-filename purl))
  99. (concat (url-type purl) "://"
  100. (url-host purl)
  101. (match-string 0 (url-filename purl))))))
  102. (defun os-rmine-repo-name (url)
  103. "Return repo name at URL."
  104. (when (string-match "projects/\\([^/]+\\)" url)
  105. (match-string 1 url)))
  106. (defun os-rmine-json-to-bug (json)
  107. "Return JSON as a bug."
  108. (flet ((va (key alist) (cdr (assoc key alist)))
  109. (v (key) (va key json)))
  110. (let* ((id (v 'id))
  111. (author (va 'name (v 'author)))
  112. (txtstatus (va 'name (v 'status)))
  113. (status (if (or (string= txtstatus "Open")
  114. (string= txtstatus "New"))
  115. 'open
  116. 'closed))
  117. (priority (va 'name (v 'priority)))
  118. (title (v 'subject))
  119. (desc (v 'description))
  120. (ctime (os-rmine-parse-date (v 'created_on)))
  121. (mtime (os-rmine-parse-date (v 'updated_on))))
  122. `(:id ,id
  123. :priority ,priority
  124. :status ,status
  125. :title ,title
  126. :desc ,desc
  127. :date-creation ,ctime
  128. :date-modification ,mtime))))
  129. (defun os-rmine-fetch-buglist (last-update)
  130. "Return the buglist at os-base-url."
  131. (let* ((url (concat os-base-url "/issues.json"))
  132. (res (os-rmine-request "GET" url))
  133. (code (car res))
  134. (json (cdr res))
  135. (title (concat "Bugs of " (os-rmine-repo-name url))))
  136. `(:title ,title
  137. :url ,os-base-url
  138. :bugs ,(mapcar 'os-rmine-json-to-bug (cdr (assoc 'issues json))))))
  139. (defun os-rmine-bug-to-json (bug)
  140. (json-encode
  141. `((issue .
  142. ((subject . ,(os-get-prop :title bug))
  143. (description . ,(os-get-prop :desc bug)))))))
  144. ;; (defun os-rmine-code-success-p (code)
  145. ;; "Return non-nil if HTTP CODE is a success code."
  146. ;; (and (<= 200 code) (< code 300)))
  147. (defun os-rmine-send-buglist (buglist)
  148. "Send a BUGLIST on the bugtracker and return new bugs."
  149. (let* ((new-url (concat os-base-url "/issues.json"))
  150. (root-url (replace-regexp-in-string "/projects/.+"
  151. "" os-base-url))
  152. new-bugs)
  153. (os-rmine-fetch-meta)
  154. (dolist (b (os-get-prop :bugs buglist))
  155. (let* ((id (os-get-prop :id b))
  156. (data (os-rmine-bug-to-json b))
  157. (modif-url (format "%s/issues/%d.json" root-url (or id 0)))
  158. res)
  159. (cond
  160. ;; new bug
  161. ((null id)
  162. (setq res (os-rmine-request "POST" new-url data))
  163. (when (/= (car res) 201)
  164. (error "Can't create new bug \"%s\"" (os-get-prop :title b)))
  165. (push (os-rmine-json-to-bug
  166. (cdr (assoc 'issue (cdr res))))
  167. new-bugs))
  168. ;; delete bug
  169. ((os-get-prop :delete b)
  170. (setq res (os-rmine-request "DELETE" modif-url))
  171. (when (not (member (car res) '(404 204)))
  172. (error "Can't delete bug #%d" id)))
  173. ;; update bug
  174. (t
  175. (setq res (os-rmine-request "PUT" modif-url data))
  176. (when (/= (car res) 200)
  177. (error "Can't update bug #%d" id))
  178. ;; fetch the new version since redmine doesn't send it
  179. (setq res (os-rmine-request "GET" modif-url))
  180. (when (/= (car res) 200)
  181. (error "Can't update bug #%d" id))
  182. (push (os-rmine-json-to-bug
  183. (cdr (assoc 'issue (cdr res))))
  184. new-bugs)))))
  185. `(:bugs ,new-bugs)))
  186. ;;; os-rmine.el ends here