os.el 32 KB

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