├── .gitignore
├── README.org
├── TODO.org
├── omd.el
├── os-bb.el
├── os-github.el
├── os-rmine.el
├── os-rtm.el
├── os-util.el
├── os.el
└── test-os.el


/.gitignore:
--------------------------------------------------------------------------------
1 | *.elc
2 | 


--------------------------------------------------------------------------------
/README.org:
--------------------------------------------------------------------------------
  1 | * Introduction
  2 | 
  3 | Org-sync is a tool to synchronize online bugtrackers with org
  4 | documents.
  5 | 
  6 | * Installation
  7 | 
  8 | Put the org-sync directory in your load-path and load the org-sync
  9 | backend you need. You can add this to your .emacs:
 10 | 
 11 | #+begin_src emacs-lisp
 12 | (add-to-list 'load-path "path/to/org-sync")
 13 | (require 'os)
 14 | (require 'os-bb)
 15 | (require 'os-github)
 16 | (require 'os-rmine)
 17 | #+end_src
 18 | 
 19 | Make sure you have =org-element.el= (it's part of recent org-mode). If
 20 | you don't have it you can download a recent version in the org-sync
 21 | directory:
 22 | 
 23 | #+begin_src sh
 24 | wget -O org-element.el 'http://orgmode.org/w/?p=org-mode.git;a=blob_plain;f=lisp/org-element.el;hb=b60445cfd44bf800f0c338cbf9795ceb2767a06d'
 25 | #+end_src
 26 | 
 27 | * Tutorial
 28 | 
 29 | Next, open a new org-mode buffer and run =M-x org-sync-import=.  It prompts
 30 | you for an URL.  You can try my github test repo:
 31 | [[http://github.com/ostesting/test]].  Org-sync should import the issues from the
 32 | repo.
 33 | 
 34 | Now, let's try to add a new issue.  First you have to set a
 35 | user/password to be able to modify the issue remotely.
 36 | 
 37 | Set the variable org-sync-github-auth to like so:
 38 | =(setq org-sync-github-auth '("ostesting" . "thisisostesting42"))=
 39 | 
 40 | Try to add another issue e.g. insert =** OPEN my test issue=.  You can
 41 | type a description under it if you want.
 42 | 
 43 | The next step is simple, just run =M-x org-sync-update=.  It synchronize all
 44 | the buglists in the document.
 45 | 
 46 | * How to write a new backend
 47 | 
 48 | Writing a new backend is easy.  If something is not clear, try to read
 49 | the header in [[file:os.el%5D%5D][os.el]] or one of the existing backend.
 50 | 
 51 | #+begin_src emacs-lisp
 52 | ;; backend symbol/name: demo
 53 | ;; the symbol is used to find and call your backend functions (for now)
 54 | 
 55 | ;; what kind of urls does you backend handle?
 56 | ;; add it to `org-sync-backend-alist' in os.el:
 57 | 
 58 | (defvar org-sync-backend-alist
 59 |   '(("github.com/\\(?:repos/\\)?[^/]+/[^/]+"  . org-sync-github-backend)
 60 |     ("bitbucket.org/[^/]+/[^/]+"              . org-sync-bb-backend)
 61 |     ("demo.com"                               . org-sync-demo-backend)))
 62 | 
 63 | ;; if you have already loaded os.el, you'll have to add it
 64 | ;; manually in that case just eval this in *scratch*
 65 | (add-to-list 'org-sync-backend-alist (cons "demo.com" 'org-sync-demo-backend))
 66 | 
 67 | ;; now, in its own file org-sync-demo.el:
 68 | 
 69 | (require 'os)
 70 | 
 71 | ;; this is the variable used in `org-sync-backend-alist'
 72 | (defvar org-sync-demo-backend
 73 |   '((base-url      . org-sync-demo-base-url)
 74 |     (fetch-buglist . org-sync-demo-fetch-buglist)
 75 |     (send-buglist  . org-sync-demo-send-buglist))
 76 |   "Demo backend.")
 77 | 
 78 | 
 79 | ;; this overrides `org-sync--base-url'
 80 | ;; the argument is the url the user gave.
 81 | ;; it must return a cannonical version of the url that will be
 82 | ;; available to your backend function in the org-sync-base-url variable.
 83 | 
 84 | ;; In the github backend, it returns API base url
 85 | ;; ie. https://api.github/reposa/<user>/<repo>
 86 | 
 87 | (defun org-sync-demo-base-url (url)
 88 |   "Return proper URL."
 89 |   "http://api.demo.com/foo")
 90 | 
 91 | ;; this overrides `org-sync--fetch-buglist'
 92 | ;; you can use the variable `org-sync-base-url'
 93 | (defun org-sync-demo-fetch-buglist (last-update)
 94 |   "Fetch buglist from demo.com (anything that happened after LAST-UPDATE)"
 95 |   ;; a buglist is just a plist
 96 |   `(:title "Stuff at demo.com"
 97 |            :url ,org-sync-base-url
 98 | 
 99 |            ;; add a :since property set to last-update if you return
100 |            ;; only the bugs updated since it.  omit it or set it to
101 |            ;; nil if you ignore last-update and fetch all the bugs of
102 |            ;; the repo.
103 | 
104 |            ;; bugs contains a list of bugs
105 |            ;; a bug is a plist too
106 |            :bugs ((:id 1 :title "Foo" :status open :desc "bar."))))
107 | 
108 | ;; this overrides `org-sync--send-buglist'
109 | (defun org-sync-demo-send-buglist (buglist)
110 |   "Send BUGLIST to demo.com and return updated buglist"
111 |   ;; here you should loop over :bugs in buglist
112 |   (dolist (b (org-sync-get-prop :bugs buglist))
113 |     (cond
114 |       ;; new bug (no id)
115 |       ((null (org-sync-get-prop :id b)
116 |         '(do-stuff)))
117 | 
118 |       ;; delete bug
119 |       ((org-sync-get-prop :delete b)
120 |         '(do-stuff))
121 | 
122 |       ;; else, modified bug
123 |       (t
124 |         '(do-stuff))))
125 | 
126 |   ;; return any bug that has changed (modification date, new bugs,
127 |   ;; etc).  they will overwrite/be added in the buglist in os.el
128 | 
129 |   ;; we return the same thing for the demo.
130 |   ;; :bugs is the only property used from this function in os.el
131 |   `(:bugs ((:id 1 :title "Foo" :status open :desc "bar."))))
132 | #+end_src
133 | 
134 | That's it.  A bug has to have at least an id, title and status
135 | properties.  Other recognized but optionnal properties are
136 | =:date-deadline=, =:date-creation=, =:date-modification=, =:desc=.
137 | Any other properties are automatically added in the =PROPERTIES= block
138 | of the bug via =prin1-to-string= and are =read= back by org-sync.  All
139 | the dates are regular emacs time object.  For more details you can
140 | look at the github backend in [[file:os-github.el][os-github.el]].
141 | 
142 | * More information
143 | 
144 | You can find more in the [[file:os.el][os.el]] commentary headers.
145 | 


--------------------------------------------------------------------------------
/TODO.org:
--------------------------------------------------------------------------------
 1 | * Documentation
 2 | 
 3 | ** DONE user documentation
 4 | ** DONE update how to write backends
 5 | ** DONE update introduction to code
 6 | 
 7 | * Org-sync
 8 | 
 9 | ** TODO better error checking
10 | ** TODO convert markup to org-mode and reciprocally
11 | Also, find out how to handle charsets, line-ending, etc.
12 | 
13 | ** DONE use usual deadline timestamp from org-mode
14 | No backend uses it but importing from/exporting to org-element works.
15 | 
16 | ** TODO fix date representation
17 | ** TODO better auth system
18 | Some ideas:
19 | - a single variable maps repo urls to user accounts.
20 | - each backend use its own variable, more flexible.
21 | - keep the bugtracker URL of the current document as a property
22 | - support authinfo/authinfo.gpg
23 | 
24 | ** DONE cache parse/fetch result
25 | org-sync-cache-alist maps urls to buglists and each buglists has a
26 | =:date-cache= property.
27 | 
28 | ** DONE replace overridable macro by something simpler
29 | The right value of a pair in org-sync-backend-alist is now the symbol of a
30 | variable defined in each backend. This variable is an alist that maps
31 | verb symbol (base-url, fetch-buglist, send-buglist for now) to
32 | function symbol.
33 | 
34 | * Backends
35 | Write backends for some free software.
36 | 
37 | ** Redmine
38 | *** TODO basic syncing
39 | 
40 | ** Bugzilla
41 | *** TODO basic syncing
42 | 
43 | ** Github
44 | *** DONE basic syncing
45 | *** DONE tags
46 | *** TODO milestone
47 | 
48 | ** Bitbucket
49 | *** DONE basic syncing
50 | *** TODO component
51 | *** TODO version
52 | *** TODO milestone
53 | *** TODO test DELETE
54 | 


--------------------------------------------------------------------------------
/omd.el:
--------------------------------------------------------------------------------
  1 | ;; omd.el --- org-merge-driver document generator
  2 | 
  3 | (defconst omd-bullet-type '("+" "-" "num"))
  4 | 
  5 | (defun omd-rand (min max)
  6 |   "Return random integer in [MIN;MAX[."
  7 |   (if (< max min)
  8 |       (rotatef min max))
  9 |   (let ((d (- max min)))
 10 |     (+ min (random d))))
 11 | 
 12 | (defun omd-random-word (&optional length)
 13 |   "Return random word."
 14 |   (unless length
 15 |     (setq length (omd-rand 2 7)))
 16 | 
 17 |   (let (chars)
 18 |     (apply 'string
 19 |            (dotimes (i length chars)
 20 |              (push (omd-rand 97 123) chars)))))
 21 | 
 22 | (defun omd-random-text (&optional lines length prefix)
 23 |   "Return random text.
 24 | The text has LINES lines and each line is approximately LENGTH
 25 | characters."
 26 |   (unless prefix
 27 |     (setq prefix ""))
 28 |   (unless length
 29 |     (setq length 70))
 30 |   (unless lines
 31 |     (setq lines 1))
 32 | 
 33 |   (let (text)
 34 |     (dotimes (n lines text)
 35 |       (if (/= n 0)
 36 |           (setq text (concat text "\n" prefix)))
 37 | 
 38 |       (let (line)
 39 |         (while (< (length line) length)
 40 |           (let ((w (omd-random-word)))
 41 |             (setq line (if line (concat line " " w) w))))
 42 |         (setq text (concat text line))))))
 43 | 
 44 | 
 45 | (defun omd-random-paragraph (&optional text)
 46 |   (unless text
 47 |     (setq text (omd-random-text (omd-rand 2 5))))
 48 |   `(paragraph nil ,text))
 49 | 
 50 | (defun omd-random-headline (&rest contents)
 51 |   (let ((title (omd-random-text 1 20)))
 52 |   `(headline (:title ,title) ,@contents)))
 53 | 
 54 | (defun omd-pick-random-element (list)
 55 |   (let ((len (length list)))
 56 |     (nth (omd-rand 0 len) list)))
 57 | 
 58 | (defun omd-random-list (&optional nitems bullet)
 59 |   (unless nitems
 60 |     (setq nitems (omd-rand 2 5)))
 61 |   (unless bullet
 62 |     (setq bullet (omd-pick-random-element omd-bullet-type)))
 63 | 
 64 |   (let* (items)
 65 |     (dotimes (i nitems)
 66 |       (push (omd-random-text (omd-rand 2 5) 30) items))
 67 | 
 68 |     `(list (:bullet ,bullet) ,@items)))
 69 | 
 70 | 
 71 | (defun omd-set-contents (elem contents)
 72 |   (setf (nthcdr 2 elem) contents))
 73 | 
 74 | (defun omd-get-contents (elem)
 75 |   (nthcdr 2 elem))
 76 | 
 77 | (defun omd-add-contents (elem &rest contents)
 78 |   (setcdr (last elem) contents))
 79 | 
 80 | (defun omd-get-prop (prop elem)
 81 |   (plist-get (nth 1 elem) prop))
 82 | 
 83 | (defun omd-set-prop (prop val elem)
 84 |   (setcar (cdr elem) (plist-put (nth 1 elem) prop val)))
 85 | 
 86 | (defalias 'omd-copy 'copy-tree)
 87 | 
 88 | (defun omd-new-doc (&rest contents)
 89 |   `(doc () ,@contents))
 90 | 
 91 | (defun omd-to-string (elem &optional level)
 92 |   (unless level
 93 |     (setq level 1))
 94 |   (let* ((type (nth 0 elem))
 95 |          (prop (nth 1 elem))
 96 |          (cont (nthcdr 2 elem)))
 97 | 
 98 |     (cond
 99 |      ((eq 'doc type)
100 |       (mapconcat 'omd-to-string cont ""))
101 | 
102 |      ((eq 'headline type)
103 |       (apply 'concat
104 |              (make-string level ?*)
105 |              " "
106 |              (omd-get-prop :title elem)
107 |              "\n"
108 |              (mapcar (lambda (e)
109 |                        (omd-to-string e (1+ level)))
110 |                      cont)))
111 | 
112 |      ((eq 'list type)
113 |       (let ((n 0)
114 |             (bullet (omd-get-prop :bullet elem)))
115 |         (apply 'concat
116 |               (mapcar (lambda (item)
117 |                         (incf n)
118 |                         (let* ((prefix (if (string= "num" bullet)
119 |                                            (format "%d. " n)
120 |                                          (concat bullet " ")))
121 |                                (space (make-string (length prefix) ?\ ))
122 |                                (replace (concat "\n" space "\\1")))
123 |                           (concat
124 |                            prefix
125 |                            (replace-regexp-in-string "\n\\(.\\)" replace item)
126 |                            "\n")))
127 |                       cont))))
128 | 
129 |       ((eq 'paragraph type)
130 |        (apply 'concat cont)))))
131 | 
132 | (defun omd-write-to-file (elem file)
133 |   (with-temp-file file
134 |     (insert (omd-to-string string))))
135 | 
136 | (defun omd-random-insert (elem list)
137 |   "Insert ELEM in LIST at a random position."
138 |   (let* ((pos (omd-rand 0 (length list))))
139 |     (if (= pos 0)
140 |         (cons elem list)
141 |       (let ((cell (nthcdr (1- pos) list)))
142 |         (setcdr cell
143 |                 (cons elem (cdr cell))))
144 |       list)))
145 | 
146 | (defun omd-mutate-elem-list (elem &optional nb)
147 |   "Append NB items at random positions in every list of ELEM."
148 |   (unless nb
149 |     (setq nb 1))
150 |   (let* ((type (nth 0 elem))
151 |          (cont (nthcdr 2 elem)))
152 |     (cond
153 |      ((eq 'list type)
154 |       (omd-set-contents
155 |        elem
156 |        (dotimes (i nb cont)
157 |          (setq cont
158 |                (omd-random-insert (omd-random-text (omd-rand 1 3) 30)
159 |                                   cont)))))
160 | 
161 |      ((member type '(headline doc))
162 |       (dolist (e cont)
163 |         (omd-mutate-doc-list e nb)))))
164 |   elem)
165 | 
166 | 
167 | (defun omd-shuffle-elem (elem &optional recurse)
168 |   "Shuffle the order of the contents of ELEM."
169 |   (when (listp elem)
170 |     (let ((cont
171 |            (map 'list 'identity
172 |                 (shuffle-vector
173 |                  (map 'vector 'identity (omd-get-contents elem))))))
174 |       (omd-set-contents elem cont)
175 |       (when recurse
176 |         (dolist (e cont)
177 |           (omd-shuffle-elem e)))
178 |       elem)))
179 | 
180 | (defun omd-test ()
181 |   ;; original doc is 2 headlines with a list
182 |   (let* ((doc-orig (omd-new-doc
183 |                     (omd-random-headline
184 |                      (omd-random-list))
185 |                     (omd-random-headline)))
186 | 
187 |          (doc-a (omd-copy doc-orig))
188 |          (doc-b (omd-copy doc-orig)))
189 | 
190 |     ;; doc A adds 2 items to the list
191 |     (omd-add-contents
192 |      (car (omd-get-contents (car (omd-get-contents doc-a))))
193 |      "new item 1"
194 |      "new item 2")
195 | 
196 |     ;; doc B adds a new subheadline with a list
197 |     (omd-add-contents
198 |      (second (omd-get-contents doc-b))
199 |      (omd-random-headline
200 |       (omd-random-list)))
201 | 
202 |     (with-current-buffer (get-buffer-create "omd test")
203 |       (erase-buffer)
204 |       (insert
205 |        (omd-to-string doc-orig)
206 |        "\n\n"
207 |        (omd-to-string doc-a)
208 |        "\n\n"
209 |        (omd-to-string doc-b)))))
210 | 


--------------------------------------------------------------------------------
/os-bb.el:
--------------------------------------------------------------------------------
  1 | ;;; os-bb.el --- Bitbucket backend for Org-sync.
  2 | 
  3 | ;; Copyright (C) 2012  Aurelien Aptel
  4 | ;;
  5 | ;; Author: Aurelien Aptel <aurelien dot aptel at gmail dot com>
  6 | ;; Keywords: org, bitbucket, synchronization
  7 | ;; Homepage: http://orgmode.org/worg/org-contrib/gsoc2012/student-projects/org-sync
  8 | ;;
  9 | ;; This program is free software; you can redistribute it and/or modify
 10 | ;; it under the terms of the GNU General Public License as published by
 11 | ;; the Free Software Foundation, either version 3 of the License, or
 12 | ;; (at your option) any later version.
 13 | 
 14 | ;; This program is distributed in the hope that it will be useful,
 15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 17 | ;; GNU General Public License for more details.
 18 | 
 19 | ;; This file is not part of GNU Emacs.
 20 | 
 21 | ;; You should have received a copy of the GNU General Public License
 22 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 23 | 
 24 | ;;; Commentary:
 25 | 
 26 | ;; This package implements a backend for Org-sync to synchnonize
 27 | ;; issues from a bitbucket repo with an org-mode buffer.  Read
 28 | ;; Org-sync documentation for more information about it.
 29 | 
 30 | ;; This backend only supports basic synchronization for now.
 31 | ;; Components, versions and milestones are ignored.
 32 | 
 33 | ;;; Code:
 34 | 
 35 | (eval-when-compile (require 'cl))
 36 | (require 'os)
 37 | (require 'url)
 38 | (require 'json)
 39 | 
 40 | (defvar url-http-end-of-headers)
 41 | (defvar url-http-response-status)
 42 | 
 43 | (defvar org-sync-bb-backend
 44 |   '((base-url      . org-sync-bb-base-url)
 45 |     (fetch-buglist . org-sync-bb-fetch-buglist)
 46 |     (send-buglist  . org-sync-bb-send-buglist))
 47 |   "Bitbucket backend.")
 48 | 
 49 | (defvar org-sync-bb-auth nil
 50 |   "Bitbucket login (\"user\" . \"pwd\")")
 51 | 
 52 | (defun org-sync-bb-request (method url &optional data)
 53 |   "Send HTTP request at URL using METHOD with DATA.
 54 | AUTH is a cons (\"user\" . \"pwd\").  Return the server
 55 | decoded response in JSON."
 56 |   (message "%s %s %s" method url (prin1-to-string data))
 57 |   (let* ((url-request-method method)
 58 |          (url-request-data data)
 59 |          (auth org-sync-bb-auth)
 60 |          (buf)
 61 |          (url-request-extra-headers
 62 |           (unless data
 63 |             '(("Content-Type" . "application/x-www-form-urlencoded")))))
 64 | 
 65 |     (if (consp auth)
 66 |         ;; dynamically bind auth related vars
 67 |         (let* ((str (concat (car auth) ":" (cdr auth)))
 68 |                (encoded (base64-encode-string str))
 69 |                (login `(("api.bitbucket.org:443" ("Bitbucket API" . ,encoded))))
 70 |                (url-basic-auth-storage 'login))
 71 |           (setq buf (url-retrieve-synchronously url)))
 72 |       ;; nothing more to bind
 73 |       (setq buf (url-retrieve-synchronously url)))
 74 |     (org-sync-util-read-json-from-response-buffer buf)))
 75 | 
 76 | ;; override
 77 | (defun org-sync-bb-base-url (url)
 78 |   "Return base URL."
 79 |   (cond
 80 |    ;; web ui url
 81 |   ((string-match "^\\(?:https?://\\)?\\(?:www\\.\\)?bitbucket.org/\\([^/]+\\)/\\([^/]+\\)/?$" url)
 82 |    (concat "https://api.bitbucket.org/1.0/repositories/"
 83 |            (match-string 1 url) "/" (match-string 2 url)))
 84 | 
 85 |   ;; api url
 86 |   ((string-match "api.bitbucket.org/1.0/repositories" url)
 87 |    url)))
 88 | 
 89 | 
 90 | ;; From https://confluence.atlassian.com/display/BITBUCKET/Issues
 91 | 
 92 | ;;     title: The title of the new issue.
 93 | ;;     content: The content of the new issue.
 94 | ;;     component: The component associated with the issue.
 95 | ;;     milestone: The milestone associated with the issue.
 96 | ;;     version: The version associated with the issue.
 97 | ;;     responsible: The username of the person responsible for the issue.
 98 | 
 99 | ;;     priority: The priority of the issue.  Valid priorities are:
100 | ;;     - trivial
101 | ;;     - minor
102 | ;;     - major
103 | ;;     - critical
104 | ;;     - blocker
105 | 
106 | ;;     status: The status of the issue.  Valid statuses are:
107 | ;;     - new
108 | ;;     - open
109 | ;;     - resolved
110 | ;;     - on hold
111 | ;;     - invalid
112 | ;;     - duplicate
113 | ;;     - wontfix
114 | 
115 | ;;     kind: The kind of issue.  Valid kinds are:
116 | ;;     - bug
117 | ;;     - enhancement
118 | ;;     - proposal
119 | ;;     - task
120 | 
121 | (defconst org-sync-bb-priority-list
122 |   '("trivial" "minor" "major" "critical" "blocker")
123 |   "List of valid priority for a bitbucket issue.")
124 | 
125 | (defconst org-sync-bb-status-list
126 |   '("new" "open" "resolved" "on hold" "invalid" "duplicate" "wontfix")
127 |   "List of valid status for a bitbucket issue.")
128 | 
129 | (defconst org-sync-bb-kind-list
130 |   '("bug" "enhancement" "proposal" "task")
131 |   "List of valid kind for a bitbucket issue.")
132 | 
133 | (defun org-sync-bb-bug-to-form (bug)
134 |   "Return BUG as an form alist."
135 |   (let* ((priority (org-sync-get-prop :priority bug))
136 |          (title (org-sync-get-prop :title bug))
137 |          (desc (org-sync-get-prop :desc bug))
138 |          (assignee (org-sync-get-prop :assignee bug))
139 |          (status (if (eq (org-sync-get-prop :status bug) 'open) "open" "resolved"))
140 |          (kind (org-sync-get-prop :kind bug)))
141 | 
142 |     (if (and priority (not (member priority org-sync-bb-priority-list)))
143 |       (error "Invalid priority \"%s\" at bug \"%s\"." priority title))
144 | 
145 |     (if (and kind (not (member kind org-sync-bb-kind-list)))
146 |       (error "Invalid kind \"%s\" at bug \"%s\"." kind title))
147 | 
148 |     (remove-if (lambda (x)
149 |                  (null (cdr x)))
150 |                `(("title"       . ,title)
151 |                  ("status"      . ,status)
152 |                  ("content"     . ,desc)
153 |                  ("responsible" . ,assignee)
154 |                  ("priority"    . ,priority)
155 |                  ("kind"        . ,kind)))))
156 | 
157 | (defun org-sync-bb-post-encode (args)
158 |   "Return form alist ARGS as a url-encoded string."
159 |   (mapconcat (lambda (arg)
160 |                (concat (url-hexify-string (car arg))
161 |                        "="
162 |                        (url-hexify-string (cdr arg))))
163 |              args "&"))
164 | 
165 | (defun org-sync-bb-repo-name (url)
166 |   "Return repo name at URL."
167 |   (when (string-match "api\\.bitbucket.org/1\\.0/repositories/\\([^/]+\\)/\\([^/]+\\)" url)
168 |     (match-string 2 url)))
169 | 
170 | (defun org-sync-bb-repo-user (url)
171 |   "Return repo username at URL."
172 |   (when (string-match "api\\.bitbucket.org/1\\.0/repositories/\\([^/]+\\)/\\([^/]+\\)" url)
173 |     (match-string 1 url)))
174 | 
175 | ;; override
176 | (defun org-sync-bb-fetch-buglist (last-update)
177 |   "Return the buglist at `org-sync-base-url'."
178 |   (let* ((url (concat org-sync-base-url "/issues"))
179 |          (res (org-sync-bb-request "GET" url))
180 |          (code (car res))
181 |          (json (cdr res))
182 |          (title (concat "Bugs of " (org-sync-bb-repo-name url))))
183 | 
184 |     `(:title ,title
185 |              :url ,org-sync-base-url
186 |              :bugs ,(mapcar 'org-sync-bb-json-to-bug (cdr (assoc 'issues json))))))
187 | 
188 | 
189 | (defun org-sync-bb-json-to-bug (json)
190 |   "Return JSON as a bug."
191 |   (flet ((va (key alist) (cdr (assoc key alist)))
192 |          (v (key) (va key json)))
193 |     (let* ((id (v 'local_id))
194 |            (metadata (v 'metadata))
195 |            (kind (va 'kind metadata))
196 |            (version (va 'version metadata))
197 |            (component (va 'component metadata))
198 |            (milestone (va 'milestone metadata))
199 |            (author (va 'username (v 'reported_by)))
200 |            (assignee (va 'username (v 'responsible)))
201 |            (txtstatus (v 'status))
202 |            (status (if (or (string= txtstatus "open")
203 |                            (string= txtstatus "new"))
204 |                        'open
205 |                      'closed))
206 |            (priority (v 'priority))
207 |            (title (v 'title))
208 |            (desc (v 'content))
209 |            (ctime (org-sync-parse-date (v 'utc_created_on)))
210 |            (mtime (org-sync-parse-date (v 'utc_last_updated))))
211 | 
212 |       `(:id ,id
213 |             :priority ,priority
214 |             :assignee ,assignee
215 |             :status ,status
216 |             :title ,title
217 |             :desc ,desc
218 |             :date-creation ,ctime
219 |             :date-modification ,mtime
220 |             :kind ,kind
221 |             :version ,version
222 |             :component ,component
223 |             :milestone ,milestone))))
224 | 
225 | ;; override
226 | (defun org-sync-bb-send-buglist (buglist)
227 |   "Send a BUGLIST on the bugtracker and return new bugs."
228 |   (let* ((new-url (concat org-sync-base-url "/issues"))
229 |          (new-bugs))
230 |     (dolist (b (org-sync-get-prop :bugs buglist))
231 |       (let* ((id (org-sync-get-prop :id b))
232 |              (data (org-sync-bb-post-encode (org-sync-bb-bug-to-form b)))
233 |              (modif-url (format "%s/%d/" new-url (or id 0)))
234 |              res)
235 |         (cond
236 |          ;; new bug
237 |          ((null id)
238 |           (setq res (org-sync-bb-request "POST" new-url data))
239 |           (when (/= (car res) 200)
240 |             (error "Can't create new bug \"%s\"" (org-sync-get-prop :title b)))
241 |           (push (org-sync-bb-json-to-bug (cdr res)) new-bugs))
242 | 
243 |          ;; delete bug
244 |          ((org-sync-get-prop :delete b)
245 |           (setq res (org-sync-bb-request "DELETE" modif-url))
246 |           (when (not (member (car res) '(404 204)))
247 |             (error "Can't delete bug #%d" id)))
248 | 
249 |          ;; update bug
250 |          (t
251 |           (setq res (org-sync-bb-request "PUT" modif-url data))
252 |           (when (/= (car res) 200)
253 |             (error "Can't update bug #%id" id))
254 |           (push (org-sync-bb-json-to-bug (cdr res)) new-bugs)))))
255 |     `(:bugs ,new-bugs)))
256 | 
257 | (provide 'os-bb)
258 | ;;; os-bb.el ends here
259 | 


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


--------------------------------------------------------------------------------
/os-rmine.el:
--------------------------------------------------------------------------------
  1 | ;;; os-rmine.el --- Redmine backend for Org-sync.
  2 | 
  3 | ;; Copyright (C) 2012  Aurelien Aptel
  4 | ;;
  5 | ;; Author: Aurelien Aptel <aurelien dot aptel at gmail dot com>
  6 | ;; Keywords: org, redmine, synchronization
  7 | ;; Homepage: http://orgmode.org/worg/org-contrib/gsoc2012/student-projects/org-sync
  8 | ;;
  9 | ;; This program is free software; you can redistribute it and/or modify
 10 | ;; it under the terms of the GNU General Public License as published by
 11 | ;; the Free Software Foundation, either version 3 of the License, or
 12 | ;; (at your option) any later version.
 13 | 
 14 | ;; This program is distributed in the hope that it will be useful,
 15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 17 | ;; GNU General Public License for more details.
 18 | 
 19 | ;; This file is not part of GNU Emacs.
 20 | 
 21 | ;; You should have received a copy of the GNU General Public License
 22 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 23 | 
 24 | ;;; Commentary:
 25 | 
 26 | ;; This package implements a backend for Org-sync to synchnonize
 27 | ;; issues from a redmine repo with an org-mode buffer.  Read Org-sync
 28 | ;; documentation for more information about it.
 29 | 
 30 | ;;; Code:
 31 | 
 32 | (eval-when-compile (require 'cl))
 33 | (require 'os)
 34 | (require 'os-util)
 35 | (require 'url)
 36 | (require 'json)
 37 | 
 38 | (defvar url-http-end-of-headers)
 39 | (defvar url-http-response-status)
 40 | 
 41 | (defvar org-sync-rmine-backend
 42 |   '((base-url      . org-sync-rmine-base-url)
 43 |     (fetch-buglist . org-sync-rmine-fetch-buglist)
 44 |     (send-buglist  . org-sync-rmine-send-buglist))
 45 |   "Redmine backend.")
 46 | 
 47 | (defvar org-sync-rmine-auth nil
 48 |   "Redmine login (\"user\" . \"pwd\")")
 49 | 
 50 | (defvar org-sync-rmine-project-id nil
 51 |   "Project id of current buglist.")
 52 | 
 53 | (defconst org-sync-rmine-date-regex
 54 |   (rx
 55 |    (seq
 56 |     (group (repeat 4 digit)) "/"
 57 |     (group (repeat 2 digit)) "/"
 58 |     (group (repeat 2 digit))
 59 |     " "
 60 |     (group
 61 |      (repeat 2 digit) ":"
 62 |      (repeat 2 digit) ":"
 63 |      (repeat 2 digit))
 64 |     " "
 65 |     (group (or "+" "-")
 66 |            (repeat 2 digit)
 67 |            (repeat 2 digit))))
 68 |   "Regex to parse date returned by redmine.")
 69 | 
 70 | (defun org-sync-rmine-fetch-meta ()
 71 |   "Set `org-sync-rmine-project-id' for now."
 72 |   (let* ((res (org-sync-rmine-request "GET" (concat org-sync-base-url ".json")))
 73 |          (code (car res))
 74 |          (json (cdr res)))
 75 |     (when (/= code 200)
 76 |       (error "Can't fetch data from %s, wrong url?" org-sync-base-url))
 77 |     (setq org-sync-rmine-project-id (cdr (assoc 'id (cdr (assoc 'project json)))))))
 78 | 
 79 | (defun org-sync-rmine-parse-date (date)
 80 |   "Return time object of DATE."
 81 |   (when (string-match org-sync-rmine-date-regex date)
 82 |     (org-sync-parse-date (concat (match-string 1 date) "-"
 83 |                            (match-string 2 date) "-"
 84 |                            (match-string 3 date) "T"
 85 |                            (match-string 4 date)
 86 |                            (match-string 5 date)))))
 87 | 
 88 | (defun org-sync-rmine-request (method url &optional data)
 89 |   "Send HTTP request at URL using METHOD with DATA.
 90 | AUTH is a cons (\"user\" . \"pwd\").  Return the server
 91 | decoded response in JSON."
 92 |   (let* ((url-request-method method)
 93 |          (url-request-data data)
 94 |          (url-request-extra-headers
 95 |           (when data
 96 |             '(("Content-Type" . "application/json"))))
 97 |          (auth org-sync-rmine-auth)
 98 |          (buf))
 99 | 
100 |     (when (stringp auth)
101 |       (setq url (org-sync-url-param url `(("key" . ,auth)))))
102 | 
103 |     (message "%s %s %s" method url (prin1-to-string data))
104 |     (org-sync-util-read-json-from-url url)))
105 | 
106 | ;; override
107 | (defun org-sync-rmine-base-url (url)
108 |   "Return base URL."
109 |   ;; if no url type, try http
110 |   (when (not (string-match "^https?://" url))
111 |     (setq url (concat "http://" url)))
112 | 
113 |   (let ((purl (url-generic-parse-url url)))
114 |     (when (string-match "^.*/projects/\\([^/]+\\)" (url-filename purl))
115 |       (concat (url-type purl) "://"
116 |               (url-host purl)
117 |               (match-string 0 (url-filename purl))))))
118 | 
119 | (defun org-sync-rmine-repo-name (url)
120 |   "Return repo name at URL."
121 |   (when (string-match "projects/\\([^/]+\\)" url)
122 |     (match-string 1 url)))
123 | 
124 | (defun org-sync-rmine-json-to-bug (json)
125 |   "Return JSON as a bug."
126 |   (flet ((va (key alist) (cdr (assoc key alist)))
127 |          (v (key) (va key json)))
128 |     (let* ((id (v 'id))
129 |            (author (va 'name (v 'author)))
130 |            (txtstatus (va 'name (v 'status)))
131 |            (status (if (or (string= txtstatus "Open")
132 |                            (string= txtstatus "New"))
133 |                        'open
134 |                      'closed))
135 |            (priority (va 'name (v 'priority)))
136 |            (title (v 'subject))
137 |            (desc (v 'description))
138 |            (ctime (org-sync-rmine-parse-date (v 'created_on)))
139 |            (mtime (org-sync-rmine-parse-date (v 'updated_on))))
140 | 
141 |       `(:id ,id
142 |             :priority ,priority
143 |             :status ,status
144 |             :title ,title
145 |             :desc ,desc
146 |             :date-creation ,ctime
147 |             :date-modification ,mtime))))
148 | 
149 | (defun org-sync-rmine-fetch-buglist (last-update)
150 |   "Return the buglist at `org-sync-base-url'."
151 |   (let* ((url (concat org-sync-base-url "/issues.json"))
152 |          (res (org-sync-rmine-request "GET" url))
153 |          (code (car res))
154 |          (json (cdr res))
155 |          (title (concat "Bugs of " (org-sync-rmine-repo-name url))))
156 | 
157 |     `(:title ,title
158 |              :url ,org-sync-base-url
159 |              :bugs ,(mapcar 'org-sync-rmine-json-to-bug (cdr (assoc 'issues json))))))
160 | 
161 | (defun org-sync-rmine-bug-to-json (bug)
162 |   (json-encode
163 |    `((issue .
164 |             ((subject     . ,(org-sync-get-prop :title bug))
165 |              (description . ,(org-sync-get-prop :desc bug)))))))
166 | 
167 | 
168 | ;; (defun org-sync-rmine-code-success-p (code)
169 | ;;   "Return non-nil if HTTP CODE is a success code."
170 | ;;   (and (<= 200 code) (< code 300)))
171 | 
172 | (defun org-sync-rmine-send-buglist (buglist)
173 |     "Send a BUGLIST on the bugtracker and return new bugs."
174 |     (let* ((new-url (concat org-sync-base-url "/issues.json"))
175 |            (root-url (replace-regexp-in-string "/projects/.+"
176 |                                                "" org-sync-base-url))
177 |            new-bugs)
178 | 
179 |       (org-sync-rmine-fetch-meta)
180 | 
181 |       (dolist (b (org-sync-get-prop :bugs buglist))
182 |         (let* ((id (org-sync-get-prop :id b))
183 |                (data (org-sync-rmine-bug-to-json b))
184 |                (modif-url (format "%s/issues/%d.json" root-url (or id 0)))
185 |                res)
186 |           (cond
187 |            ;; new bug
188 |            ((null id)
189 |             (setq res (org-sync-rmine-request "POST" new-url data))
190 |             (when (/= (car res) 201)
191 |               (error "Can't create new bug \"%s\"" (org-sync-get-prop :title b)))
192 |             (push (org-sync-rmine-json-to-bug
193 |                    (cdr (assoc 'issue (cdr res))))
194 |                   new-bugs))
195 | 
196 |            ;; delete bug
197 |            ((org-sync-get-prop :delete b)
198 |             (setq res (org-sync-rmine-request "DELETE" modif-url))
199 |             (when (not (member (car res) '(404 204)))
200 |               (error "Can't delete bug #%d" id)))
201 | 
202 |            ;; update bug
203 |            (t
204 |             (setq res (org-sync-rmine-request "PUT" modif-url data))
205 |             (when (/= (car res) 200)
206 |               (error "Can't update bug #%d" id))
207 | 
208 |             ;; fetch the new version since redmine doesn't send it
209 |             (setq res (org-sync-rmine-request "GET" modif-url))
210 |             (when (/= (car res) 200)
211 |               (error "Can't update bug #%d" id))
212 | 
213 |             (push (org-sync-rmine-json-to-bug
214 |                    (cdr (assoc 'issue (cdr res))))
215 |                   new-bugs)))))
216 |       `(:bugs ,new-bugs)))
217 | 
218 | (provide 'os-rmine)
219 | ;;; os-rmine.el ends here
220 | 


--------------------------------------------------------------------------------
/os-rtm.el:
--------------------------------------------------------------------------------
  1 | ;;; os-rtm.el --- Remember The Milk backend for org-sync.
  2 | 
  3 | ;; Copyright (C) 2012  Aurelien Aptel
  4 | ;;
  5 | ;; Author: Aurelien Aptel <aurelien dot aptel at gmail dot com>
  6 | ;; Keywords: org, rtm, synchronization
  7 | ;; Homepage: http://orgmode.org/worg/org-contrib/gsoc2012/student-projects/org-sync
  8 | ;;
  9 | ;; This program is free software; you can redistribute it and/or modify
 10 | ;; it under the terms of the GNU General Public License as published by
 11 | ;; the Free Software Foundation, either version 3 of the License, or
 12 | ;; (at your option) any later version.
 13 | 
 14 | ;; This program is distributed in the hope that it will be useful,
 15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 17 | ;; GNU General Public License for more details.
 18 | 
 19 | ;; This file is not part of GNU Emacs.
 20 | 
 21 | ;; You should have received a copy of the GNU General Public License
 22 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 23 | 
 24 | ;;; Commentary:
 25 | 
 26 | ;; This package implements a backend for Org-sync to synchnonize
 27 | ;; issues from a remember the milk repo with an org-mode buffer.  Read
 28 | ;; Org-sync documentation for more information about it.
 29 | 
 30 | ;;; Code:
 31 | 
 32 | (eval-when-compile (require 'cl))
 33 | (require 'os)
 34 | (require 'os-util)
 35 | (require 'json)
 36 | (require 'url)
 37 | 
 38 | (defvar org-sync-rtm-api-key "e9b28a9ac67f1bffc3dab1bd94dab722")
 39 | (defvar org-sync-rtm-shared-secret "caef7e509a8dcd82")
 40 | (defvar org-sync-rtm-token nil)
 41 | 
 42 | (defvar url-http-end-of-headers)
 43 | (defvar url-http-response-status)
 44 | 
 45 | (defun org-sync-rtm-call (method &rest args)
 46 |   "Call API METHOD and return result."
 47 |   (let* ((param `(("method" . ,method)
 48 |                   ,@args)))
 49 |     (org-sync-rtm-request "GET" "http://api.rememberthemilk.com/services/rest/" param nil 'sign)))
 50 | 
 51 | (defvar org-sync-rtm-backend
 52 |   '((base-url      . org-sync-rtm-base-url)
 53 |     (fetch-buglist . org-sync-rtm-fetch-buglist)
 54 |     (send-buglist  . org-sync-rtm-send-buglist))
 55 |   "Bitbucket backend.")
 56 | 
 57 | (defun org-sync-rtm-base-url (url)
 58 |   "Return base URL. Not used with RTM."
 59 |   url)
 60 | 
 61 | (defun org-sync-rtm-filter-tasks (response)
 62 |   "Return all the real task from RTM rtm.tasks.getList RESPONSE."
 63 |   (let (final)
 64 |     (mapc (lambda (e)
 65 |             (when (assoc 'taskseries e)
 66 |               (mapc (lambda (task-series)
 67 |                       (push task-series final))
 68 |                     (org-sync-getalist e 'taskseries))))
 69 |           (org-sync-getalist (cdr response) 'rsp 'tasks 'list))
 70 |     final))
 71 | 
 72 | (defun org-sync-rtm-fetch-buglist (last-update)
 73 |   (unless org-sync-rtm-token
 74 |     (org-sync-rtm-auth))
 75 |   (let ((bl
 76 |          (mapcar 'org-sync-rtm-task-to-bug
 77 |                  (org-sync-rtm-filter-tasks (org-sync-rtm-call "rtm.tasks.getList")))))
 78 |     `(:title "Tasks"
 79 |              :url ,org-sync-base-url
 80 |              :bugs ,bl)))
 81 | 
 82 | (defun org-sync-rtm-task-to-bug (task)
 83 |   "Return TASK as a bug."
 84 |   (flet ((v (&rest key) (apply 'org-sync-getalist task key)))
 85 |     (let* ((id (string-to-number (v 'id)))
 86 |            (title (v 'name))
 87 |            (status (if (string= (v 'task 'completed) "")
 88 |                        'open
 89 |                      'closed))
 90 |            (priority (v 'task 'priority))
 91 |            (ctime (org-sync-parse-date (v 'created)))
 92 |            (mtime (org-sync-parse-date (v 'modified)))
 93 |            (dtime (org-sync-parse-date (v 'task 'due))))
 94 |       `(:id ,id
 95 |             :title ,title
 96 |             :status ,status
 97 |             :priority ,priority
 98 |             :date-creation ,ctime
 99 |             :date-modification ,mtime
100 |             :date-deadline ,dtime))))
101 | 
102 | 
103 | (defun org-sync-rtm-request (method url &optional param data sign)
104 |   "Send HTTP request at URL using METHOD with DATA."
105 | 
106 |   (unless  (string-match "/auth/" url)
107 |     (push (cons "format" "json") param))
108 | 
109 |   (when org-sync-rtm-token
110 |     (push (cons "auth_token" org-sync-rtm-token) param))
111 | 
112 |   (push `("api_key" . ,org-sync-rtm-api-key) param)
113 | 
114 |   (when sign
115 |     (push `("api_sig" . ,(org-sync-rtm-sign param)) param))
116 | 
117 |   (setq url (org-sync-url-param url param))
118 | 
119 |   (let* ((url-request-method method)
120 |          (url-request-data data)
121 |          (url-request-extra-headers
122 |           (when data
123 |             '(("Content-Type" . "application/x-www-form-urlencoded"))))
124 |          buf)
125 | 
126 |     (message "%s %s %s" method url (prin1-to-string data))
127 |     (org-sync-util-read-json-from-url url)))
128 | 
129 | (defun org-sync-rtm-auth ()
130 |   "Return the URL to grant access to the user account."
131 |   ;; http://www.rememberthemilk.com/services/auth/?api_key=abc123&perms=delete
132 | 
133 |   (let* ((res (org-sync-rtm-call "rtm.auth.getFrob"))
134 |          (frob (cdr (assoc 'frob (cdadr res))))
135 |          (param `(("api_key" . ,org-sync-rtm-api-key)
136 |                   ("perms"   . "delete")
137 |                   ("frob"    . ,frob)))
138 |          url)
139 | 
140 |     ;; add signature
141 |     (push `("api_sig" . ,(org-sync-rtm-sign param)) param)
142 |     (setq url (org-sync-url-param "http://www.rememberthemilk.com/services/auth/" param))
143 |     (browse-url url)
144 |     (when (yes-or-no-p "Application accepted? ")
145 |       (setq
146 |        org-sync-rtm-token
147 |        (org-sync-getalist
148 |         (cdr (org-sync-rtm-call "rtm.auth.getToken" `("frob" . ,frob)))
149 |         'rsp 'auth 'token)))))
150 | 
151 | (defun org-sync-rtm-sign (param-alist)
152 |   "Return the signature for the PARAM-ALIST request."
153 |   (let ((param (copy-tree param-alist))
154 |         sign)
155 | 
156 |     ;; sort by key
157 |     (setq param (sort param (lambda (a b)
158 |                             (string< (car a) (car b)))))
159 | 
160 |     ;; sign = md5(shared_secret . k1 . v1 . k2 . v2...)
161 |     (md5
162 |      (message
163 |       (concat
164 |        org-sync-rtm-shared-secret
165 |        ;; concat key&value
166 |        (mapconcat (lambda (x)
167 |                     (concat (car x) (cdr x)))
168 |                   param ""))
169 | 
170 |       nil nil 'utf-8))))
171 | 
172 | (provide 'os-rtm)
173 | ;;; os-rtm.el ends here
174 | 


--------------------------------------------------------------------------------
/os-util.el:
--------------------------------------------------------------------------------
 1 | ;;; os-utils.el --- Utility functions for org-sync.
 2 | 
 3 | ;; Copyright (C) 2013  Albert Krewinkel
 4 | ;;
 5 | ;; Author: Albert Krewinkel <tarleb+org-sync@moltkeplatz.de>
 6 | ;; Keywords: org, synchronization, json
 7 | ;; Homepage: http://orgmode.org/worg/org-contrib/gsoc2012/student-projects/org-sync
 8 | ;;
 9 | ;; This program is free software; you can redistribute it and/or modify
10 | ;; it under the terms of the GNU General Public License as published by
11 | ;; the Free Software Foundation, either version 3 of the License, or
12 | ;; (at your option) any later version.
13 | 
14 | ;; This program is distributed in the hope that it will be useful,
15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
17 | ;; GNU General Public License for more details.
18 | 
19 | ;; This file is not part of GNU Emacs.
20 | 
21 | ;; You should have received a copy of the GNU General Public License
22 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
23 | 
24 | ;;; Commentary:
25 | 
26 | ;; This package provides utility functions for org-sync.
27 | 
28 | ;;; Code:
29 | 
30 | (eval-when-compile (require 'cl))
31 | (require 'url)
32 | (require 'json)
33 | 
34 | (defvar org-sync-util-default-encoding 'utf-8
35 |   "Default encoding expected in server responses.")
36 | 
37 | (defvar org-sync-util-debug nil
38 |   "If non-nil, show debug messages.")
39 | 
40 | (defun org-sync-util-get-coding-system (encoding)
41 |   "Find the coding system specified by `encoding' or nil if none is found.
42 | This method accepts either a string or a symbol, the case of
43 | which is ignored."
44 |   (let ((coding-system (cl-assoc encoding coding-system-alist :test 'equalp)))
45 |     (if coding-system
46 |         (intern (car coding-system))
47 |       nil)))
48 | 
49 | (defun org-sync-util-get-response-encoding (&optional bound)
50 |   "Get encoding charset from a http response header."
51 |   (save-excursion
52 |     (goto-char (point-min))
53 |     (let ((noerror t)
54 |           (content-type-regex
55 |            "^Content-Type: application/json;? *\\(charset=\\(.*\\)\\b\\)?$"))
56 |       (when (<= 0 (search-forward-regexp content-type-regex bound noerror))
57 |         (org-sync-util-get-coding-system (match-string 2))))))
58 | 
59 | (defun org-sync-util-ensure-correct-encoding (end-of-headers)
60 |   "Make sure that the data returned by a server is interpreted in
61 |   the right encoding."
62 |   (let* ((resp-encoding (org-sync-util-get-response-encoding end-of-headers))
63 |          (new-encoding (or resp-encoding
64 |                            org-sync-util-default-encoding))
65 |          (old-encoding buffer-file-coding-system))
66 |     (unless (coding-system-equal new-encoding old-encoding)
67 |       (recode-region end-of-headers (point-max) new-encoding old-encoding))))
68 | 
69 | (defun org-sync-util-read-json-from-response-buffer (buffer &optional keep-buffer)
70 |   "Get JSON data from `buffer', then kill the buffer unless
71 | `keep-buffer' is non-nil."
72 |   (with-current-buffer buffer
73 |     (toggle-enable-multibyte-characters 1)
74 |     (org-sync-util-ensure-correct-encoding url-http-end-of-headers)
75 |     (goto-char url-http-end-of-headers)
76 |     (when org-sync-util-debug
77 |       (message "%s" (buffer-substring (point) (point-max))))
78 |     (prog1
79 |         (cons url-http-response-status (ignore-errors (json-read)))
80 |       (unless keep-buffer
81 |         (kill-buffer)))))
82 | 
83 | (defun org-sync-util-read-json-from-url (url)
84 |   "Get JSON data from url"
85 |   (setq buffer (url-retrieve-synchronously url))
86 |   (org-sync-util-read-json-from-response-buffer buffer))
87 | 
88 | (provide 'os-util)
89 | ;; os-util.el ends here
90 | 


--------------------------------------------------------------------------------
/os.el:
--------------------------------------------------------------------------------
  1 | ;;; os.el --- Synchronize Org documents with external services
  2 | 
  3 | ;; Copyright (C) 2012  Aurelien Aptel
  4 | ;;
  5 | ;; Author: Aurelien Aptel <aurelien dot aptel at gmail dot com>
  6 | ;; Keywords: org, synchronization
  7 | ;; Homepage: http://orgmode.org/worg/org-contrib/gsoc2012/student-projects/org-sync
  8 | ;;
  9 | ;; This program is free software; you can redistribute it and/or modify
 10 | ;; it under the terms of the GNU General Public License as published by
 11 | ;; the Free Software Foundation, either version 3 of the License, or
 12 | ;; (at your option) any later version.
 13 | 
 14 | ;; This program is distributed in the hope that it will be useful,
 15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 17 | ;; GNU General Public License for more details.
 18 | 
 19 | ;; This file is not part of GNU Emacs.
 20 | 
 21 | ;; You should have received a copy of the GNU General Public License
 22 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 23 | 
 24 | ;;; Commentary:
 25 | 
 26 | ;; This package implements an extension to org-mode that synchnonizes
 27 | ;; org document with external services.  It provides an interface that
 28 | ;; can be implemented in backends.  The current focus is on
 29 | ;; bugtrackers services.
 30 | 
 31 | ;; The entry points are `org-sync-import', `org-sync' and `os'.  The first
 32 | ;; one prompts for a URL to import, the second one pulls, merges and
 33 | ;; pushes every buglists in the current buffer and the third one
 34 | ;; combines the others in one function: if nothing in the buffer can
 35 | ;; be synchronized, ask for an URL to import.
 36 | 
 37 | ;; The usual workflow is first to import your buglist with
 38 | ;; `org-sync-import', modify it or add a bug and run `org-sync'.
 39 | 
 40 | ;; A buglist is a top-level headline which has a :url: in its
 41 | ;; PROPERTIES block.  This headline is composed of a list of
 42 | ;; subheadlines which corresponds to bugs.  The requirement for a bug
 43 | ;; is to have a state, a title and an id.  If you add a new bug, it
 44 | ;; wont have an id but it will get one once you sync.  If you omit the
 45 | ;; status, OPEN is chose.
 46 | 
 47 | ;; The status is an org TODO state.  It can be either OPEN or CLOSED.
 48 | ;; The title is just the title of the headline.  The id is a number in
 49 | ;; the PROPERTIES block of the headline.
 50 | 
 51 | ;; Org DEADLINE timestamp are also handled and can be inserted in a
 52 | ;; bug headline which can then be used by the backend if it supports
 53 | ;; it.
 54 | 
 55 | ;; Paragraphs under bug-headlines are considered as their description.
 56 | ;; Additionnal data used by the backend are in the PROPERTIES block of
 57 | ;; the bug.
 58 | 
 59 | ;; To add a bug, just insert a new headline under the buglist you want
 60 | ;; to modify e.g.:
 61 | ;;     ** OPEN my new bug
 62 | ;; Then simply call `org-sync'.
 63 | 
 64 | ;;; Code:
 65 | 
 66 | ;; The data structures used to represent bugs and buglists are simple
 67 | ;; plists.  It is what backend have to handle, process or return.
 68 | 
 69 | ;; Buglist example:
 70 | 
 71 | ;; '(:title "My buglist"
 72 | ;;   :url "http://github.com/repos/octocat/Hello-World"
 73 | ;;   :bugs (BUGS...))
 74 | 
 75 | ;; Bug example:
 76 | 
 77 | ;; '(:id 3
 78 | ;;   :status 'open or 'closed
 79 | ;;   :sync 'conflict-local or 'conflict-remote
 80 | ;;   :title "foo"
 81 | ;;   :desc "blah"
 82 | ;;   :priority "major"
 83 | ;;   :tags ("a" "b" "c")
 84 | ;;   :author "Aurélien"
 85 | ;;   :assignee "Foo"
 86 | ;;   :milestone "foo"
 87 | 
 88 | ;;   ;; dates are regular emacs time object
 89 | ;;   :date-deadline ...
 90 | ;;   :date-creation ...
 91 | ;;   :date-modification ...
 92 | 
 93 | ;;   ;; backend-specific properties
 94 | ;;   ;; ...
 95 | ;;   )
 96 | 
 97 | ;; Some accesors are available for both structure.  See `org-sync-set-prop',
 98 | ;; and `org-sync-get-prop'.
 99 | 
100 | 
101 | ;; When importing an URL, Org-sync matches the URL against the
102 | ;; variable `org-sync-backend-alist' which maps regexps to backend symbols.
103 | ;; The backend symbol is then used to call the backend functions.
104 | ;; When these functions are called, the variable `org-sync-backend' and
105 | ;; `org-sync-base-url' are dynamically bound to respectively the backend
106 | ;; symbol and the cannonical URL for the thing you are synching with.
107 | 
108 | ;; The symbol part in a `org-sync-backend-alist' pair must be a variable
109 | ;; defined in the backend.  It is an alist that maps verb to function
110 | ;; symbol.  Each backend must implement at least 3 verbs:
111 | 
112 | ;; * base-url (param: URL)
113 | 
114 | ;; Given the user URL, returns the cannonical URL to represent it.
115 | ;; This URL will be available dynamically to all of your backend
116 | ;; function through the `org-sync-base-url' variable.
117 | 
118 | ;; * fetch-buglist (param: LAST-FETCH-TIME)
119 | 
120 | ;; Fetch the buglist at `org-sync-base-url'.  If LAST-FETCH-TIME is non-nil,
121 | ;; and you only fetched things modified since it, you are expected to
122 | ;; set the property :since to it in the buglist you return.  You can
123 | ;; add whatever properties you want in a bug.  The lisp printer is
124 | ;; used to persist them in the buffer.
125 | 
126 | ;; * send-buglist (param: BUGLIST)
127 | 
128 | ;; Send BUGLIST to the repo at `org-sync-base-url' and return the new bugs
129 | ;; created that way. A bug without an id in BUGLIST is a new bug, the
130 | ;; rest are modified bug.
131 | 
132 | 
133 | ;; When synchronizing, Org-sync parses the current buffer using
134 | ;; org-element and convert any found buglist headline to a buglist
135 | ;; data structure.  See `org-sync-headline-to-buglist',
136 | ;; `org-sync-headline-to-bug'.
137 | 
138 | ;; When writing buglists back to the document, Org-sync converts them
139 | ;; to elements -- the data structure used by org-element -- which are
140 | ;; then interpreted by `org-element-interpret-data'.  The resulting
141 | ;; string is then inserted in the buffer.  See `org-sync-buglist-to-element'
142 | ;; and `org-sync-bug-to-element'.
143 | 
144 | (eval-when-compile (require 'cl))
145 | (require 'org)
146 | (require 'org-element)
147 | 
148 | (defvar org-sync-backend nil
149 |   "Org-sync current backend.")
150 | 
151 | (defvar org-sync-base-url nil
152 |   "Org-sync current base url.")
153 | 
154 | (defvar org-sync-backend-alist
155 |   '(("github.com/\\(?:repos/\\)?[^/]+/[^/]+" . org-sync-github-backend)
156 |     ("bitbucket.org/[^/]+/[^/]+"             . org-sync-bb-backend)
157 |     ("/projects/[^/]+"                       . org-sync-rmine-backend)
158 |     ("rememberthemilk.com"                   . org-sync-rtm-backend))
159 |   "Alist of url patterns vs corresponding org-sync backend.")
160 | 
161 | (defvar org-sync-cache-file (concat user-emacs-directory "org-sync-cache")
162 |   "Path to Org-sync cache file.")
163 | 
164 | (defvar org-sync-cache-alist nil
165 |   "Org-sync cache for buglists.
166 | Maps URLs to buglist cache.")
167 | 
168 | (defvar org-sync-conflict-buffer "*Org-sync conflict*"
169 |   "Name of the conflict buffer")
170 | 
171 | (defvar org-sync-props nil
172 |   "List of property to sync or nil to sync everything.")
173 | 
174 | (defun org-sync-action-fun (action)
175 |   "Return current backend ACTION function or nil."
176 |   (unless (or (null action) (null org-sync-backend))
177 |     (let ((fsym (assoc-default action (eval org-sync-backend))))
178 |       (when (fboundp fsym)
179 |         fsym))))
180 | 
181 | (defun org-sync-get-backend (url)
182 |   "Return backend symbol matching URL from `org-sync-backend-alist'."
183 |   (assoc-default url org-sync-backend-alist 'string-match))
184 | 
185 | (defmacro org-sync-with-backend (backend &rest body)
186 |   "Eval BODY with org-sync-backend set to corresponding BACKEND.
187 | 
188 | If BACKEND evals to a string it is passed to org-sync-get-backend, the
189 | resulting symbol is dynamically assigned to org-sync-backend.  The url
190 | is passed to org-sync--base-url and dynamically assigned to
191 | org-sync-base-url.
192 | 
193 | Else BACKEND should be a backend symbol.  It is
194 | assigned to org-sync-backend."
195 |   (declare (indent 1) (debug t))
196 |   (let ((res (gensym))
197 |         (url (gensym)))
198 | 
199 |     `(let* ((,res ,backend)
200 |             (,url))
201 |        (when (stringp ,res)
202 |          (setq ,url ,res)
203 |          (setq ,res (org-sync-get-backend ,url)))
204 |        (unless (symbolp ,res)
205 |          (error "Backend %s does not evaluate to a symbol."
206 |                 (prin1-to-string ',backend)))
207 |        (let* ((org-sync-backend ,res)
208 |               (org-sync-base-url (org-sync--base-url ,url)))
209 |          ,@body))))
210 | 
211 | (defun org-sync-set-cache (url buglist)
212 |   "Update URL to BUGLIST in `org-sync-cache-alist'."
213 |   (let ((cell (assoc url org-sync-cache-alist)))
214 |     (if cell
215 |         (setcdr cell buglist)
216 |       (push (cons url buglist) org-sync-cache-alist))))
217 | 
218 | (defun org-sync-get-cache (url)
219 |   "Return the buglist at URL in cache or nil."
220 |     (cdr (assoc url org-sync-cache-alist)))
221 | 
222 | (defun org-sync-write-cache ()
223 |   "Write Org-sync cache to `org-sync-cache-file'."
224 |   (with-temp-file org-sync-cache-file
225 |     (prin1 `(setq org-sync-cache-alist ',org-sync-cache-alist) (current-buffer))))
226 | 
227 | (defun org-sync-load-cache ()
228 |   "Load Org-sync cache from `org-sync-cache-file'."
229 |   (load org-sync-cache-file 'noerror nil))
230 | 
231 | (defun org-sync-plist-to-alist (plist)
232 |   "Return PLIST as an association list."
233 |   (let* (alist cell q (p plist))
234 |     (while p
235 |       (setq cell (cons (car p) (cadr p)))
236 |       (if alist
237 |           (progn
238 |             (setcdr q (cons cell nil))
239 |             (setq q (cdr q)))
240 |         (setq alist (cons cell nil))
241 |         (setq q alist))
242 |       (setq p (cddr p)))
243 |     alist))
244 | 
245 | (defun org-sync-propertize (sym)
246 |   "Return sym as a property i.e. prefixed with :."
247 |   (intern (concat ":" (if (symbolp sym)
248 |                           (symbol-name sym)
249 |                         sym))))
250 | 
251 | (defun org-sync-get-prop (key b)
252 |   "Return value of the property KEY in buglist or bug B."
253 |   (plist-get b key))
254 | 
255 | (defun org-sync-set-prop (key val b)
256 |   "Set KEY to VAL in buglist or bug B."
257 |   (plist-put b key val))
258 | 
259 | (defun org-sync-append! (elem list)
260 |   "Add ELEM at the end of LIST by side effect if it isn't present.
261 | 
262 | Return ELEM if it was added, nil otherwise."
263 |   (catch :exit
264 |     (let ((p list))
265 |       (while (cdr p)
266 |         (when (equal (car p) elem)
267 |           (throw :exit nil))
268 |         (setq p (cdr p)))
269 |       (setcdr p (cons elem nil))
270 |       elem)))
271 | 
272 | (defun org-sync--send-buglist (buglist)
273 |   "Send a BUGLIST on the bugtracker."
274 |   (let ((f (org-sync-action-fun 'send-buglist)))
275 |         (if f
276 |             (funcall f buglist)
277 |           (error "No send backend available."))))
278 | 
279 | (defun org-sync--fetch-buglist (last-update)
280 |   "Return the buglist at url REPO."
281 |   (let ((f (org-sync-action-fun 'fetch-buglist)))
282 |         (if f
283 |             (funcall f last-update)
284 |           (error "No fetch backend available."))))
285 | 
286 | 
287 | (defun org-sync--base-url (url)
288 |   "Return the base url of URL."
289 |   (let ((f (org-sync-action-fun 'base-url)))
290 |         (if f
291 |             (funcall f url)
292 |           (error "No base-url backend available."))))
293 | 
294 | 
295 | (defun org-sync-url-param (url param)
296 |   "Return URL with PARAM alist appended."
297 |   (let* ((split (split-string url "\\?" t))
298 |          (base (car split))
299 |          (rest (cadr split))
300 |          (final))
301 | 
302 |     ;; read all param
303 |     (when rest
304 |       (mapc
305 |        (lambda (s)
306 |          (let* ((split (split-string s "=" t))
307 |                 (var (car split))
308 |                 (val (cadr split))
309 |                 (cell (assoc var final)))
310 |            (if cell
311 |                (setcdr cell val)
312 |              (push (cons var val) final))))
313 |        (split-string rest "&" t)))
314 | 
315 |     ;; add params from arg
316 |     (mapc (lambda (p)
317 |             (let* ((var (car p))
318 |                    (val (cdr p))
319 |                    (cell (assoc var final)))
320 |               (if cell
321 |                   (setcdr cell val)
322 |                 (push p final))))
323 |           param)
324 | 
325 |     ;; output new url
326 |     (concat
327 |      base
328 |      "?"
329 |      (mapconcat (lambda (p)
330 |                   (concat
331 |                    (url-hexify-string (car p))
332 |                    "="
333 |                    (url-hexify-string (cdr p))))
334 |                 final "&"))))
335 | 
336 | ;; OPEN bugs sorted by mod time then CLOSED bugs sorted by mod time
337 | (defun org-sync-bug-sort (a b)
338 |   "Return non-nil if bug A should appear before bug B."
339 |   (flet ((time-less-safe (a b)
340 |                          (if (and a b)
341 |                              (time-less-p a b)
342 |                            (or a b))))
343 |     (let* ((ao (eq 'open (org-sync-get-prop :status a)))
344 |            (bc (not (eq 'open (org-sync-get-prop :status b))))
345 |            (am (time-less-safe
346 |                 (org-sync-get-prop :date-modification b)
347 |                 (org-sync-get-prop :date-modification a))))
348 |       (or
349 |        (and ao am)
350 |        (and bc am)
351 |        (and ao bc)))))
352 | 
353 | (defun org-sync-buglist-to-element (bl)
354 |   "Return buglist BL as an element."
355 |   (let* ((skip '(:title :bugs :date-cache))
356 |          (sorted (sort (org-sync-get-prop :bugs bl) 'org-sync-bug-sort))
357 |          (elist (delq nil (mapcar 'org-sync-bug-to-element sorted)))
358 |          (title (org-sync-get-prop :title bl))
359 |          (url (org-sync-get-prop :url bl))
360 |          (props (sort (mapcar
361 |                        ;; stringify prop name
362 |                        (lambda (x)
363 |                          (cons (substring (symbol-name (car x)) 1) (cdr x)))
364 |                        ;; remove skipped prop
365 |                        (remove-if (lambda (x)
366 |                                     (memq (car x) skip))
367 |                                   (org-sync-plist-to-alist bl)))
368 |                       ;; sort prop by key
369 |                       (lambda (a b)
370 |                         (string< (car a) (car b))))))
371 | 
372 |     (org-sync-set-prop :bugs sorted bl)
373 |     `(headline
374 |       (:level 1 :title (,title))
375 |       (section
376 |        nil
377 |        ,(org-sync-alist-to-property-drawer props))
378 |       ,@elist)))
379 | 
380 | (defun org-sync-filter-list (list minus)
381 |   "Return a copy of LIST without elements in MINUS."
382 |   (let ((final (copy-seq list)))
383 |     (mapc (lambda (x)
384 |             (delq x final)) minus)
385 |     final))
386 | 
387 | (defun org-sync-bug-to-element (b)
388 |   "Return bug B as a TODO element if it is visible or nil."
389 |   ;; not in PROPERTIES block
390 |   (let* ((skip '(:title :status :desc :old-bug
391 |                         :date-deadline :date-creation :date-modification))
392 |          (title (org-sync-get-prop :title b))
393 |          (dtime (org-sync-get-prop :date-deadline b))
394 |          (ctime (org-sync-get-prop :date-creation b))
395 |          (mtime (org-sync-get-prop :date-modification b))
396 |          (prop-alist (loop for (a b) on b by #'cddr
397 |                            if (and b (not (memq a skip)))
398 |                            collect (cons (substring (symbol-name a) 1)
399 |                                          (prin1-to-string b)))))
400 |     (unless (org-sync-get-prop :delete b)
401 |       ;; add date-xxx props manually in a human readable way.
402 |       (push (cons
403 |              "date-creation"
404 |              (org-sync-time-to-string ctime)) prop-alist)
405 |       (push (cons
406 |              "date-modification"
407 |              (org-sync-time-to-string mtime)) prop-alist)
408 | 
409 |       ;; sort PROPERTIES by property name
410 |       (setq prop-alist (sort prop-alist
411 |                              (lambda (a b)
412 |                                (string< (car b) (car a)))))
413 | 
414 |       `(headline
415 |         (:title ,(concat
416 |                   title
417 |                   (when dtime
418 |                     (concat
419 |                      " DEADLINE: "
420 |                      (format-time-string (org-time-stamp-format) dtime))))
421 |                 :level 2
422 |                 :todo-type todo
423 |                 :todo-keyword ,(upcase (symbol-name (org-sync-get-prop :status b))))
424 |         (section
425 |          nil
426 |          ,(org-sync-alist-to-property-drawer prop-alist)
427 |          (fixed-width (:value ,(org-sync-get-prop :desc b))))))))
428 | 
429 | (defun org-sync-headline-url (elem)
430 |   "Returns the url of the buglist in headline ELEM."
431 |   (cdr (assoc "url"
432 |               (org-sync-property-drawer-to-alist
433 |                (car (org-element-contents
434 |                      (car (org-element-contents elem))))))))
435 | 
436 | (defun org-sync-buglist-headline-p (elem)
437 |   "Return t if ELEM is a buglist headline."
438 |   (and
439 |    (eq (org-element-type elem) 'headline)
440 |    (stringp (org-sync-headline-url elem))))
441 | 
442 | (defun org-sync-property-drawer-to-alist (drawer)
443 |   "Return the alist of all key value pairs"
444 |   (org-element-map drawer
445 |                    'node-property
446 |                    (lambda (x) (cons (org-element-property :key x)
447 |                                 (org-element-property :value x)))))
448 | 
449 | (defun org-sync-alist-to-property-drawer (alist)
450 |   "Return the property drawer corresponding to an alist of key
451 |   value pairs"
452 |   `(property-drawer nil
453 |                     ,(mapcar
454 |                       (lambda (x) `(node-property (:key ,(car x) :value ,(cdr x))))
455 |                       alist)))
456 | 
457 | (defun org-sync-headline-to-buglist (h)
458 |   "Return headline H as a buglist."
459 |   (let* ((skip '(:url))
460 |          (alist (org-sync-property-drawer-to-alist
461 |                  (car (org-element-contents
462 |                        (car (org-element-contents h))))))
463 |          (title (car (org-element-property :title h)))
464 |          (url (cdr (assoc "url" alist)))
465 |          (bugs (mapcar
466 |                 'org-sync-headline-to-bug
467 |                 (nthcdr 1 (org-element-contents h))))
468 |          (bl `(:title ,title
469 |                       :url ,url
470 |                       :bugs ,bugs)))
471 | 
472 |     ;; add all other properties
473 |     (mapc (lambda (x)
474 |             (let ((k (org-sync-propertize (car x)))
475 |                   (v (cdr x)))
476 |               (unless (memq k skip)
477 |                 (org-sync-set-prop k v bl))))
478 |           alist)
479 | 
480 |     bl))
481 | 
482 | (defun org-sync-headline-to-bug (h)
483 |   "Return headline H as a bug."
484 |   (let* ((todo-keyword (org-element-property :todo-keyword h))
485 |          ;; properties to skip when looking at the PROPERTIES block
486 |          (skip '(:status :title :desc :date-deadline :date-creation :date-modification))
487 |          (status (intern (downcase (or todo-keyword "open"))))
488 |          (dtime (org-sync-parse-date (org-element-property :deadline h)))
489 |          (title (car (org-element-property :title h)))
490 |          (section (org-element-contents (car (org-element-contents h))))
491 |          (headline-alist (org-sync-property-drawer-to-alist
492 |                           (car
493 |                            (org-element-contents
494 |                             (car (org-element-contents h))))))
495 |          (ctime (org-sync-parse-date (cdr (assoc "date-creation" headline-alist))))
496 |          (mtime (org-sync-parse-date (cdr (assoc "date-modification" headline-alist))))
497 |          desc
498 |          bug)
499 | 
500 |     (dolist (e section)
501 |       (let ((type (org-element-type e))
502 |             (content (org-element-contents e)))
503 |         (cond
504 |          ;; interpret quote block as actual text
505 |          ((eq type 'fixed-width)
506 |           (setq desc (concat desc (org-element-property :value e))))
507 | 
508 |          ;; ignore these
509 |          ((or (eq type 'property-drawer)
510 |               (eq type 'planning)
511 |               (and (eq type 'paragraph)
512 |                    (string-match "^ *DEADLINE: " (car content))))
513 |           nil)
514 | 
515 |          ;; else, interpret via org-element
516 |          (t
517 |           (setq desc (concat desc (org-element-interpret-data e)))))))
518 | 
519 |     ;; deadlines can be either on the same line as the headline or
520 |     ;; on the next one.  org-element doesn't parse it the same way
521 |     ;; when on the same line, remove DEADLINE tag from title
522 |     ;; else ignore DEADLINE tag in paragraph
523 |     (when dtime
524 |       (setq title (replace-regexp-in-string " DEADLINE: " "" title)))
525 | 
526 |     (setq bug (list
527 |                :status status
528 |                :title title
529 |                :desc desc
530 |                :date-deadline dtime
531 |                :date-creation ctime
532 |                :date-modification mtime))
533 | 
534 |     ;; add all properties
535 |     (mapc (lambda (x)
536 |             (let ((k (org-sync-propertize (car x)))
537 |                   (v (when (and (cdr x) (not (equal (cdr x) "")))
538 |                        (read (cdr x)))))
539 |               (unless (memq k skip)
540 |                 (setq bug (cons k (cons v bug)))))) headline-alist)
541 |     bug))
542 | 
543 | (defun org-sync-find-buglists (elem)
544 |   "Return every buglist headlines in ELEM."
545 |   (let ((type (org-element-type elem))
546 |         (contents (org-element-contents elem)))
547 |     (cond
548 |      ;; if it's a buglist, return it
549 |      ((org-sync-buglist-headline-p elem)
550 |       elem)
551 |      ;; else if it contains elements, look recursively in it
552 |      ((or (eq type 'org-data) (memq type org-element-greater-elements))
553 |       (let (buglist)
554 |         (mapc (lambda (e)
555 |                 (let ((h (org-sync-find-buglists e)))
556 |                   (when h
557 |                     (setq buglist (cons h buglist)))))
558 |               contents)
559 |         buglist))
560 |      ;; terminal case
561 |      (t
562 |       nil))))
563 | 
564 | (defun org-sync-add-keyword (tree key val)
565 |   "Add KEY:VAL as a header in TREE by side-effects and return TREE.
566 | If KEY is already equal to VAL, no change is made."
567 |   (catch :exit
568 |     (let* ((section (first (org-element-contents tree))))
569 |       (when (and (eq 'org-data (org-element-type tree))
570 |                  (eq 'section  (org-element-type section)))
571 | 
572 |         (dolist (e (org-element-contents section))
573 |           (let* ((type (org-element-type e))
574 |                  (ekey (org-element-property :key e))
575 |                  (eval (org-element-property :value e)))
576 | 
577 |             (when (and (eq 'keyword type)
578 |                        (string= ekey key)
579 |                        (string= eval val))
580 |               (throw :exit nil))))
581 | 
582 |         (setf (nthcdr 2 section)
583 |               (cons
584 |                `(keyword (:key ,key :value ,val))
585 |                (org-element-contents section))))))
586 |   tree)
587 | 
588 | (defun org-sync-org-reparse ()
589 |   "Reparse current buffer."
590 |   ;; from org-ctrl-c-ctrl-c, thanks to vsync in #org-mode
591 |   (let ((org-inhibit-startup-visibility-stuff t)
592 |         (org-startup-align-all-tables nil))
593 |     (when (boundp 'org-table-coordinate-overlays)
594 |       (mapc 'delete-overlay org-table-coordinate-overlays)
595 |       (setq org-table-coordinate-overlays nil))
596 |     (org-save-outline-visibility 'use-markers (org-mode-restart))))
597 | 
598 | (defun org-sync-import (url)
599 |   "Fetch and insert at point bugs from URL."
600 |   (interactive "sURL: ")
601 |   (org-sync-with-backend url
602 |    (let* ((buglist (org-sync--fetch-buglist nil))
603 |           (elem (org-sync-buglist-to-element buglist))
604 |           (bug-keyword '(sequence "OPEN" "|" "CLOSED")))
605 | 
606 |      ;; we add the buglist to the cache
607 |      (org-sync-set-prop :date-cache (current-time) buglist)
608 |      (org-sync-set-cache org-sync-base-url buglist)
609 | 
610 |      (save-excursion
611 |        (insert (org-element-interpret-data
612 |                 `(org-data nil ,elem)))
613 | 
614 |        (unless (member bug-keyword org-todo-keywords)
615 |          (goto-char (point-min))
616 |          (insert "#+TODO: OPEN | CLOSED\n")
617 |          (add-to-list 'org-todo-keywords bug-keyword)
618 | 
619 |          ;; the buffer has to be reparsed in order to have the new
620 |          ;; keyword taken into account
621 |          (org-sync-org-reparse)))))
622 |   (message "Import complete."))
623 | 
624 | (defun org-sync-get-bug-id (buglist id)
625 |   "Return bug ID from BUGLIST."
626 |   (when id
627 |       (catch :exit
628 |         (mapc (lambda (x)
629 |                 (let ((current-id (org-sync-get-prop :id x)))
630 |                   (when (and (numberp current-id) (= current-id id))
631 |                     (throw :exit x))))
632 |               (org-sync-get-prop :bugs buglist))
633 |         nil)))
634 | 
635 | (defun org-sync-buglist-dups (buglist)
636 |   "Return non-nil if BUGLIST contains bugs with the same id.
637 | The value returned is a list of duplicated ids."
638 |   (let ((hash (make-hash-table))
639 |         (dups))
640 |     (mapc (lambda (x)
641 |             (let ((id (org-sync-get-prop :id x)))
642 |               (puthash id (1+ (gethash id hash 0)) hash)))
643 |           (org-sync-get-prop :bugs buglist))
644 |     (maphash (lambda (id nb)
645 |                (when (> nb 1)
646 |                  (push id dups))) hash)
647 |     dups))
648 | 
649 | (defun org-sync-time-max (&rest timelist)
650 |   "Return the largest time in TIMELIST."
651 |   (reduce (lambda (a b)
652 |             (if (and a b)
653 |                 (if (time-less-p a b) b a))
654 |             (or a b))
655 |           timelist))
656 | 
657 | (defun org-sync-buglist-last-update (buglist)
658 |   "Return the most recent creation/modi date in BUGLIST."
659 |   (apply 'org-sync-time-max (loop for x in (org-sync-get-prop :bugs buglist)
660 |                             collect (org-sync-get-prop :date-creation x) and
661 |                             collect (org-sync-get-prop :date-modification x))))
662 | 
663 | (defun org-sync-set-equal (a b)
664 |   "Return t if list A and B have the same elements, no matter the order."
665 |   (catch :exit
666 |     (mapc (lambda (e)
667 |             (unless (member e b)
668 |               (throw :exit nil)))
669 |           a)
670 |     (mapc (lambda (e)
671 |             (unless (member e a)
672 |               (throw :exit nil)))
673 |           b)
674 |     t))
675 | 
676 | (defun org-sync-parse-date (date)
677 |   "Parse and return DATE as a time or nil."
678 |   (when (and (stringp date) (not (string= date "")))
679 |     (date-to-time date)))
680 | 
681 | (defun org-sync-time-to-string (time)
682 |   "Return TIME as a full ISO 8601 date string."
683 |   (format-time-string "%Y-%m-%dT%T%z" time))
684 | 
685 | (defun org-sync-bug-diff (a b)
686 |   "Return an alist of properties that differs in A and B or nil if A = B.
687 | The form of the alist is ((:property . (valueA valueB)...)"
688 |   (let ((diff)
689 |         (props-list
690 |          (append
691 |           (loop for (akey aval) on a by #'cddr collect akey)
692 |           (loop for (bkey bval) on b by #'cddr collect bkey))))
693 |     (delete-dups props-list)
694 |     (dolist (key props-list diff)
695 |       (let ((va (org-sync-get-prop key a))
696 |             (vb (org-sync-get-prop key b)))
697 |         (unless (equal va vb)
698 |           (setq diff (cons `(,key . (,va ,vb)) diff)))))))
699 | 
700 | (defun org-sync-bug-prop-equalp (prop a b)
701 |   "Return t if bug A PROP = bug B PROP, nil otherwise."
702 |   (equal (org-sync-get-prop prop a) (org-sync-get-prop prop b)))
703 | 
704 | (defun org-sync-buglist-diff (a b)
705 |   "Return a diff buglist which turns buglist A to B when applied.
706 | This function makes the assumption that A ⊂ B."
707 |   (let (diff)
708 |     (dolist (bbug (org-sync-get-prop :bugs b))
709 |       (let ((abug (org-sync-get-bug-id a (org-sync-get-prop :id bbug))))
710 |         (when (or (null abug) (org-sync-bug-diff abug bbug))
711 |           (push bbug diff))))
712 |     `(:bugs ,diff)))
713 | 
714 | (defun org-sync-merge-diff (local remote)
715 |   "Return the merge of LOCAL diff and REMOTE diff.
716 | The merge is the union of the diff.  Conflicting bugs are tagged
717 | with :sync conflict-local or conflict-remote."
718 |   (let ((added (make-hash-table))
719 |         merge)
720 |     ;; add all local bugs
721 |     (dolist (lbug (org-sync-get-prop :bugs local))
722 |       (let* ((id (org-sync-get-prop :id lbug))
723 |              (rbug (org-sync-get-bug-id remote id))
724 |             rnew lnew)
725 | 
726 |         ;; if there's a remote bug with the same id, we have a
727 |         ;; conflict
728 | 
729 |         ;; if the local bug has a sync prop, it was merged by the
730 |         ;; user, so we keep the local one (which might be the
731 |         ;; remote from a previous sync)
732 |         (if (and rbug (null (org-sync-get-prop :sync lbug)) (org-sync-bug-diff lbug rbug))
733 |             (progn
734 |               (setq lnew (copy-tree lbug))
735 |               (org-sync-set-prop :sync 'conflict-local lnew)
736 |               (setq rnew (copy-tree rbug))
737 |               (org-sync-set-prop :sync 'conflict-remote rnew)
738 |               (push rnew merge)
739 |               (push lnew merge))
740 |           (progn
741 |             (push lbug merge)))
742 | 
743 |         ;; mark it
744 |         (puthash id t added)))
745 | 
746 |     ;; add new remote bug which are the unmarked bugs in remote
747 |     (dolist (rbug (org-sync-get-prop :bugs remote))
748 |       (unless (gethash (org-sync-get-prop :id rbug) added)
749 |         (push rbug merge)))
750 | 
751 |     `(:bugs ,merge)))
752 | 
753 | (defun org-sync-update-buglist (base diff)
754 |   "Apply buglist DIFF to buglist BASE and return the result.
755 | This is done according to `org-sync-props'."
756 |   (let ((added (make-hash-table))
757 |         new)
758 |     (dolist (bug (org-sync-get-prop :bugs base))
759 |       (let* ((id (org-sync-get-prop :id bug))
760 |              (diff-bug (org-sync-get-bug-id diff id))
761 |              new-bug)
762 | 
763 |         (if (and org-sync-props diff-bug)
764 |             (progn
765 |               (setq new-bug bug)
766 |               (mapc (lambda (p)
767 |                       (org-sync-set-prop p (org-sync-get-prop p diff-bug) new-bug))
768 |                     org-sync-props))
769 |           (setq new-bug (or diff-bug bug)))
770 | 
771 |         (push new-bug new)
772 |         (puthash id t added)))
773 | 
774 |     (dolist (bug (org-sync-get-prop :bugs diff))
775 |       (let ((id (org-sync-get-prop :id bug)))
776 |         (when (or (null id) (null (gethash id added)))
777 |           (push bug new))))
778 | 
779 |     (let ((new-buglist (copy-list base)))
780 |       (org-sync-set-prop :bugs new new-buglist)
781 |       new-buglist)))
782 | 
783 | (defun org-sync-remove-unidentified-bug (buglist)
784 |   "Remove bugs without id from BUGLIST."
785 |   (let ((new-bugs))
786 |     (dolist (b (org-sync-get-prop :bugs buglist))
787 |       (when (org-sync-get-prop :id b)
788 |         (push b new-bugs)))
789 |     (org-sync-set-prop :bugs new-bugs buglist)
790 |     buglist))
791 | 
792 | (defun org-sync-replace-headline-by-buglist (headline buglist)
793 |   "Replace HEADLINE by BUGLIST by side effects."
794 |   (let ((new-headline (org-sync-buglist-to-element buglist)))
795 |     (setf (car headline) (car new-headline)
796 |           (cdr headline) (cdr new-headline))))
797 | 
798 | (defun org-sync-show-conflict (buglist url)
799 |   "Show conflict in BUGLIST at URL in conflict window."
800 |   (let ((buf (get-buffer-create org-sync-conflict-buffer)))
801 |     (with-help-window buf
802 |       (with-current-buffer buf
803 |         (erase-buffer)
804 |         (org-mode)
805 |         (insert "There were some conflicts while merging.  Here
806 | are the problematic items.  Look at the :sync property to know
807 | their origin. Copy what you want to keep in your org buffer and
808 | sync again.\n\n")
809 |         (dolist (b (org-sync-get-prop :bugs buglist))
810 |           (when (and b (org-sync-get-prop :sync b))
811 |             (insert (org-element-interpret-data (org-sync-bug-to-element b))
812 |                     "\n")))))))
813 | 
814 | (defun org-sync-getalist (obj &rest keys)
815 |   "Apply assoc in nested alist OBJ with KEYS."
816 |   (let ((p obj))
817 |     (dolist (k keys p)
818 |       (setq p (cdr (assoc k p))))))
819 | 
820 | (defun org-sync-filter-bug (bug)
821 |   "Filter BUG according to `org-sync-props'."
822 |   (if org-sync-props
823 |       (let ((new-bug `(:id ,(org-sync-get-prop :id bug))))
824 |         (mapc (lambda (x)
825 |                 (org-sync-set-prop x (org-sync-get-prop x bug) new-bug))
826 |               org-sync-props)
827 |         new-bug)
828 |     bug))
829 | 
830 | (defun org-sync-filter-diff (diff)
831 |   "Filter DIFF according to `org-sync-props'."
832 |   (when org-sync-props
833 |     (let (final)
834 |       (dolist (b (org-sync-get-prop :bugs diff))
835 |         (let ((id (org-sync-get-prop :id b)))
836 |           ;; drop new bugs
837 |           (when id
838 |             (push (org-sync-filter-bug b) final))))
839 |       (org-sync-set-prop :bugs final diff)))
840 |   diff)
841 | 
842 | (defun org-sync-update ()
843 |   "Update buglists in current buffer."
844 |   (interactive)
845 |   (ignore-errors (kill-buffer org-sync-conflict-buffer))
846 | 
847 |   ;; parse the buffer and find the buglist-looking headlines
848 |   (let* ((local-doc (org-element-parse-buffer))
849 |          (local-headlines (org-sync-find-buglists local-doc)))
850 | 
851 |     ;; for each of these headlines, convert it to buglist
852 |     (dolist (headline local-headlines)
853 |       (let* ((local (org-sync-headline-to-buglist headline))
854 |              (url (org-sync-get-prop :url local)))
855 | 
856 |         ;; if it has several bug with the same id, stop
857 |         (when (org-sync-buglist-dups local)
858 |           (error
859 |            "Buglist \"%s\" contains unmerged bugs."
860 |            (org-sync-get-prop :title local)))
861 | 
862 |         ;; local          cache          remote
863 |         ;;    \          /    \          /
864 |         ;;    parse    load   load     fetch
865 |         ;;      \      /        \      /
866 |         ;;     local-diff       remote-diff
867 |         ;;             \        /
868 |         ;;              \      /
869 |         ;;             merged-diff --------send-------->
870 |         ;;                                              (...)
871 |         ;;               local   <--recv-updated-diff---
872 |         ;;                 v
873 |         ;;              merged
874 |         ;;                 v
875 |         ;;        new cache/local/remote
876 | 
877 |         ;; handle buglist with the approriate backend
878 |         (org-sync-with-backend url
879 |           (let* ((cache (org-sync-get-cache org-sync-base-url))
880 |                  (last-fetch (org-sync-get-prop :date-cache cache))
881 |                  (local-diff (org-sync-buglist-diff cache local))
882 |                  remote remote-diff merged merged-diff)
883 | 
884 |             ;; fetch remote buglist
885 |             (if last-fetch
886 |                 ;; make a partial fetch and apply it to cache if the backend
887 |                 ;; supports it
888 |                 (let* ((partial-fetch (org-sync--fetch-buglist last-fetch)))
889 |                   (if (org-sync-get-prop :since partial-fetch)
890 |                       (setq remote (org-sync-update-buglist cache partial-fetch))
891 |                     (setq remote partial-fetch)))
892 |               (setq remote (org-sync--fetch-buglist nil)))
893 |             ;; at this point remote is the full remote buglist
894 | 
895 |             (setq remote-diff (org-sync-buglist-diff cache remote))
896 |             (setq merged-diff (org-sync-merge-diff local-diff remote-diff))
897 | 
898 |             ;; filter according to org-sync-props
899 |             (org-sync-filter-diff merged-diff)
900 | 
901 |             (setq merged (org-sync-update-buglist local merged-diff))
902 | 
903 |             ;; if merged-diff has duplicate bugs, there's a conflict
904 |             (let ((dups (org-sync-buglist-dups merged-diff)))
905 |               (if dups
906 |                   (progn
907 |                     (message "Synchronization failed, manual merge needed.")
908 |                     (org-sync-show-conflict merged-diff org-sync-base-url))
909 | 
910 |                 ;; else update buffer and cache
911 |                 (setq merged
912 |                       (org-sync-remove-unidentified-bug
913 |                        (org-sync-update-buglist merged (org-sync--send-buglist merged-diff))))
914 |                 (org-sync-set-prop :date-cache (current-time) merged)
915 |                 (org-sync-set-cache org-sync-base-url merged)
916 |                 (message "Synchronization complete.")))
917 | 
918 |             ;; replace headlines in local-doc
919 |             (org-sync-replace-headline-by-buglist headline merged)))))
920 | 
921 |     (org-sync-add-keyword local-doc "TODO" "OPEN | CLOSED")
922 | 
923 |     ;; since we replace the whole buffer, save-excusion doesn't work so
924 |     ;; we manually (re)store the point
925 |     (let ((oldpoint (point)))
926 |       (delete-region (point-min) (point-max))
927 |       (goto-char (point-min))
928 |       (insert (org-element-interpret-data local-doc))
929 |       (goto-char oldpoint))))
930 | 
931 | (defun org-sync ()
932 |   "Synchronize current buffer or import an external document.
933 | 
934 | If no Org-sync elements are present in the buffer, ask for a URL
935 | to import otherwise synchronize the buffer."
936 |   (interactive)
937 |   (let* ((local-doc (org-element-parse-buffer)))
938 |     (if (org-sync-find-buglists local-doc)
939 |         (org-sync)
940 |       (call-interactively 'org-sync-import))))
941 | 
942 | (provide 'os)
943 | ;;; os.el ends here
944 | 


--------------------------------------------------------------------------------
/test-os.el:
--------------------------------------------------------------------------------
  1 | ;;; test-os.el ---
  2 | 
  3 | ;; Copyright (C) 2013 Grégoire Jadi
  4 | 
  5 | ;; Author: Grégoire Jadi <gregoire.jadi@gmail.com>
  6 | 
  7 | ;; This program is free software: you can redistribute it and/or
  8 | ;; modify it under the terms of the GNU General Public License as
  9 | ;; published by the Free Software Foundation, either version 3 of
 10 | ;; the License, or (at your option) any later version.
 11 | 
 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 | 
 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 | 
 20 | ;;; Commentary:
 21 | 
 22 | ;;; Code:
 23 | 
 24 | (require 'ert)
 25 | (require 'os)
 26 | 
 27 | (ert-deftest org-sync-headline-url ()
 28 |   (with-temp-buffer
 29 |     (insert "
 30 | :PROPERTIES:
 31 | :url: http://foo.bar
 32 | :END:")
 33 |     (org-mode)
 34 |     (should
 35 |      (equal (org-sync-headline-url
 36 |              (org-element-contents
 37 |               (org-element-parse-buffer)))
 38 |             "http://foo.bar")))
 39 | 
 40 |   (with-temp-buffer
 41 |     (insert "
 42 | * Test
 43 | :PROPERTIES:
 44 | :url: http://foo.bar
 45 | :END:")
 46 |     (org-mode)
 47 |     (should
 48 |      (equal (org-sync-headline-url
 49 |              (org-element-contents
 50 |               (org-element-parse-buffer)))
 51 |             "http://foo.bar")))
 52 | 
 53 |   (with-temp-buffer
 54 |     (insert "
 55 | :PROPERTIES:
 56 | :dummy: baz
 57 | :url: http://foo.bar
 58 | :fizz: bar
 59 | :END:")
 60 |     (org-mode)
 61 |     (should
 62 |      (equal (org-sync-headline-url
 63 |              (org-element-contents
 64 |               (org-element-parse-buffer)))
 65 |             "http://foo.bar")))
 66 |   
 67 |   (with-temp-buffer
 68 |     (insert "
 69 | :PROPERTIES:
 70 | :fizz: bar
 71 | :END:")
 72 |     (org-mode)
 73 |     (should
 74 |      (equal (org-sync-headline-url
 75 |              (org-element-contents
 76 |               (org-element-parse-buffer)))
 77 |             nil))))
 78 | 
 79 | (ert-deftest org-sync-buglist-headline-p ()
 80 |   (with-temp-buffer
 81 |     (insert "
 82 | * Test
 83 | :PROPERTIES:
 84 | :url: http://foo.bar
 85 | :END:")
 86 |     (org-mode)
 87 |     (should
 88 |      (equal (org-sync-buglist-headline-p
 89 |              (first
 90 |               (org-element-contents
 91 |                (org-element-parse-buffer))))
 92 |             t)))
 93 | 
 94 |   (with-temp-buffer
 95 |     (insert "
 96 | * Test
 97 | :PROPERTIES:
 98 | :fizz: bar
 99 | :END:")
100 |     (org-mode)
101 |     (should
102 |      (equal (org-sync-buglist-headline-p
103 |              (first
104 |               (org-element-contents
105 |                (org-element-parse-buffer))))
106 |             nil)))
107 | 
108 |   (with-temp-buffer
109 |     (insert "
110 | :PROPERTIES:
111 | :url: foo
112 | :END:")
113 |     (org-mode)
114 |     (should
115 |      (equal (org-sync-buglist-headline-p
116 |              (first
117 |               (org-element-contents
118 |                (org-element-parse-buffer))))
119 |             nil))))
120 | 
121 | (provide 'test-os)
122 | 
123 | ;;; test-os.el ends here
124 | 


--------------------------------------------------------------------------------