Commit 302c7acd521a
Changed files (7)
.emacs.d
lisp
org-sync
.emacs.d/lisp/org-sync/omd.el
@@ -1,209 +0,0 @@
-;; omd.el --- org-merge-driver document generator
-
-(defconst omd-bullet-type '("+" "-" "num"))
-
-(defun omd-rand (min max)
- "Return random integer in [MIN;MAX[."
- (if (< max min)
- (rotatef min max))
- (let ((d (- max min)))
- (+ min (random d))))
-
-(defun omd-random-word (&optional length)
- "Return random word."
- (unless length
- (setq length (omd-rand 2 7)))
-
- (let (chars)
- (apply 'string
- (dotimes (i length chars)
- (push (omd-rand 97 123) chars)))))
-
-(defun omd-random-text (&optional lines length prefix)
- "Return random text.
-The text has LINES lines and each line is approximately LENGTH
-characters."
- (unless prefix
- (setq prefix ""))
- (unless length
- (setq length 70))
- (unless lines
- (setq lines 1))
-
- (let (text)
- (dotimes (n lines text)
- (if (/= n 0)
- (setq text (concat text "\n" prefix)))
-
- (let (line)
- (while (< (length line) length)
- (let ((w (omd-random-word)))
- (setq line (if line (concat line " " w) w))))
- (setq text (concat text line))))))
-
-
-(defun omd-random-paragraph (&optional text)
- (unless text
- (setq text (omd-random-text (omd-rand 2 5))))
- `(paragraph nil ,text))
-
-(defun omd-random-headline (&rest contents)
- (let ((title (omd-random-text 1 20)))
- `(headline (:title ,title) ,@contents)))
-
-(defun omd-pick-random-element (list)
- (let ((len (length list)))
- (nth (omd-rand 0 len) list)))
-
-(defun omd-random-list (&optional nitems bullet)
- (unless nitems
- (setq nitems (omd-rand 2 5)))
- (unless bullet
- (setq bullet (omd-pick-random-element omd-bullet-type)))
-
- (let* (items)
- (dotimes (i nitems)
- (push (omd-random-text (omd-rand 2 5) 30) items))
-
- `(list (:bullet ,bullet) ,@items)))
-
-
-(defun omd-set-contents (elem contents)
- (setf (nthcdr 2 elem) contents))
-
-(defun omd-get-contents (elem)
- (nthcdr 2 elem))
-
-(defun omd-add-contents (elem &rest contents)
- (setcdr (last elem) contents))
-
-(defun omd-get-prop (prop elem)
- (plist-get (nth 1 elem) prop))
-
-(defun omd-set-prop (prop val elem)
- (setcar (cdr elem) (plist-put (nth 1 elem) prop val)))
-
-(defalias 'omd-copy 'copy-tree)
-
-(defun omd-new-doc (&rest contents)
- `(doc () ,@contents))
-
-(defun omd-to-string (elem &optional level)
- (unless level
- (setq level 1))
- (let* ((type (nth 0 elem))
- (prop (nth 1 elem))
- (cont (nthcdr 2 elem)))
-
- (cond
- ((eq 'doc type)
- (mapconcat 'omd-to-string cont ""))
-
- ((eq 'headline type)
- (apply 'concat
- (make-string level ?*)
- " "
- (omd-get-prop :title elem)
- "\n"
- (mapcar (lambda (e)
- (omd-to-string e (1+ level)))
- cont)))
-
- ((eq 'list type)
- (let ((n 0)
- (bullet (omd-get-prop :bullet elem)))
- (apply 'concat
- (mapcar (lambda (item)
- (incf n)
- (let* ((prefix (if (string= "num" bullet)
- (format "%d. " n)
- (concat bullet " ")))
- (space (make-string (length prefix) ?\ ))
- (replace (concat "\n" space "\\1")))
- (concat
- prefix
- (replace-regexp-in-string "\n\\(.\\)" replace item)
- "\n")))
- cont))))
-
- ((eq 'paragraph type)
- (apply 'concat cont)))))
-
-(defun omd-write-to-file (elem file)
- (with-temp-file file
- (insert (omd-to-string string))))
-
-(defun omd-random-insert (elem list)
- "Insert ELEM in LIST at a random position."
- (let* ((pos (omd-rand 0 (length list))))
- (if (= pos 0)
- (cons elem list)
- (let ((cell (nthcdr (1- pos) list)))
- (setcdr cell
- (cons elem (cdr cell))))
- list)))
-
-(defun omd-mutate-elem-list (elem &optional nb)
- "Append NB items at random positions in every list of ELEM."
- (unless nb
- (setq nb 1))
- (let* ((type (nth 0 elem))
- (cont (nthcdr 2 elem)))
- (cond
- ((eq 'list type)
- (omd-set-contents
- elem
- (dotimes (i nb cont)
- (setq cont
- (omd-random-insert (omd-random-text (omd-rand 1 3) 30)
- cont)))))
-
- ((member type '(headline doc))
- (dolist (e cont)
- (omd-mutate-doc-list e nb)))))
- elem)
-
-
-(defun omd-shuffle-elem (elem &optional recurse)
- "Shuffle the order of the contents of ELEM."
- (when (listp elem)
- (let ((cont
- (map 'list 'identity
- (shuffle-vector
- (map 'vector 'identity (omd-get-contents elem))))))
- (omd-set-contents elem cont)
- (when recurse
- (dolist (e cont)
- (omd-shuffle-elem e)))
- elem)))
-
-(defun omd-test ()
- ;; original doc is 2 headlines with a list
- (let* ((doc-orig (omd-new-doc
- (omd-random-headline
- (omd-random-list))
- (omd-random-headline)))
-
- (doc-a (omd-copy doc-orig))
- (doc-b (omd-copy doc-orig)))
-
- ;; doc A adds 2 items to the list
- (omd-add-contents
- (car (omd-get-contents (car (omd-get-contents doc-a))))
- "new item 1"
- "new item 2")
-
- ;; doc B adds a new subheadline with a list
- (omd-add-contents
- (second (omd-get-contents doc-b))
- (omd-random-headline
- (omd-random-list)))
-
- (with-current-buffer (get-buffer-create "omd test")
- (erase-buffer)
- (insert
- (omd-to-string doc-orig)
- "\n\n"
- (omd-to-string doc-a)
- "\n\n"
- (omd-to-string doc-b)))))
.emacs.d/lisp/org-sync/os-bb.el
@@ -1,260 +0,0 @@
-;;; os-bb.el --- Bitbucket backend for org-sync.
-
-;; Copyright (C) 2012 Aurelien Aptel
-;;
-;; Author: Aurelien Aptel <aurelien dot aptel at gmail dot com>
-;; Keywords: org, bitbucket, synchronization
-;; Homepage: http://orgmode.org/worg/org-contrib/gsoc2012/student-projects/org-sync
-;;
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; This file is not part of GNU Emacs.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This package implements a backend for org-sync to synchnonize
-;; issues from a bitbucket repo with an org-mode buffer. Read
-;; Org-sync documentation for more information about it.
-
-;; This backend only supports basic synchronization for now.
-;; Components, versions and milestones are ignored.
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-(require 'os)
-(require 'url)
-(require 'json)
-
-(defvar url-http-end-of-headers)
-(defvar url-http-response-status)
-
-(defvar os-bb-backend
- '((base-url . os-bb-base-url)
- (fetch-buglist . os-bb-fetch-buglist)
- (send-buglist . os-bb-send-buglist))
- "Bitbucket backend.")
-
-(defvar os-bb-auth nil
- "Bitbucket login (\"user\" . \"pwd\")")
-
-(defun os-bb-request (method url &optional data)
- "Send HTTP request at URL using METHOD with DATA.
-AUTH is a cons (\"user\" . \"pwd\"). Return the server
-decoded response in JSON."
- (message "%s %s %s" method url (prin1-to-string data))
- (let* ((url-request-method method)
- (url-request-data data)
- (auth os-bb-auth)
- (buf)
- (url-request-extra-headers
- (unless data
- '(("Content-Type" . "application/x-www-form-urlencoded")))))
-
- (if (consp auth)
- ;; dynamically bind auth related vars
- (let* ((str (concat (car auth) ":" (cdr auth)))
- (encoded (base64-encode-string str))
- (login `(("api.bitbucket.org:443" ("Bitbucket API" . ,encoded))))
- (url-basic-auth-storage 'login))
- (setq buf (url-retrieve-synchronously url)))
- ;; nothing more to bind
- (setq buf (url-retrieve-synchronously url)))
- (with-current-buffer buf
- (goto-char url-http-end-of-headers)
- (prog1
- (cons url-http-response-status (ignore-errors (json-read)))
- (kill-buffer)))))
-
-;; override
-(defun os-bb-base-url (url)
- "Return base URL."
- (cond
- ;; web ui url
- ((string-match "^\\(?:https?://\\)?\\(?:www\\.\\)?bitbucket.org/\\([^/]+\\)/\\([^/]+\\)/?$" url)
- (concat "https://api.bitbucket.org/1.0/repositories/"
- (match-string 1 url) "/" (match-string 2 url)))
-
- ;; api url
- ((string-match "api.bitbucket.org/1.0/repositories" url)
- url)))
-
-
-;; From https://confluence.atlassian.com/display/BITBUCKET/Issues
-
-;; title: The title of the new issue.
-;; content: The content of the new issue.
-;; component: The component associated with the issue.
-;; milestone: The milestone associated with the issue.
-;; version: The version associated with the issue.
-;; responsible: The username of the person responsible for the issue.
-
-;; priority: The priority of the issue. Valid priorities are:
-;; - trivial
-;; - minor
-;; - major
-;; - critical
-;; - blocker
-
-;; status: The status of the issue. Valid statuses are:
-;; - new
-;; - open
-;; - resolved
-;; - on hold
-;; - invalid
-;; - duplicate
-;; - wontfix
-
-;; kind: The kind of issue. Valid kinds are:
-;; - bug
-;; - enhancement
-;; - proposal
-;; - task
-
-(defconst os-bb-priority-list
- '("trivial" "minor" "major" "critical" "blocker")
- "List of valid priority for a bitbucket issue.")
-
-(defconst os-bb-status-list
- '("new" "open" "resolved" "on hold" "invalid" "duplicate" "wontfix")
- "List of valid status for a bitbucket issue.")
-
-(defconst os-bb-kind-list
- '("bug" "enhancement" "proposal" "task")
- "List of valid kind for a bitbucket issue.")
-
-(defun os-bb-bug-to-form (bug)
- "Return BUG as an form alist."
- (let* ((priority (os-get-prop :priority bug))
- (title (os-get-prop :title bug))
- (desc (os-get-prop :desc bug))
- (assignee (os-get-prop :assignee bug))
- (status (if (eq (os-get-prop :status bug) 'open) "open" "resolved"))
- (kind (os-get-prop :kind bug)))
-
- (if (and priority (not (member priority os-bb-priority-list)))
- (error "Invalid priority \"%s\" at bug \"%s\"." priority title))
-
- (if (and kind (not (member kind os-bb-kind-list)))
- (error "Invalid kind \"%s\" at bug \"%s\"." kind title))
-
- (remove-if (lambda (x)
- (null (cdr x)))
- `(("title" . ,title)
- ("status" . ,status)
- ("content" . ,desc)
- ("responsible" . ,assignee)
- ("priority" . ,priority)
- ("kind" . ,kind)))))
-
-(defun os-bb-post-encode (args)
- "Return form alist ARGS as a url-encoded string."
- (mapconcat (lambda (arg)
- (concat (url-hexify-string (car arg))
- "="
- (url-hexify-string (cdr arg))))
- args "&"))
-
-(defun os-bb-repo-name (url)
- "Return repo name at URL."
- (when (string-match "api\\.bitbucket.org/1\\.0/repositories/\\([^/]+\\)/\\([^/]+\\)" url)
- (match-string 2 url)))
-
-(defun os-bb-repo-user (url)
- "Return repo username at URL."
- (when (string-match "api\\.bitbucket.org/1\\.0/repositories/\\([^/]+\\)/\\([^/]+\\)" url)
- (match-string 1 url)))
-
-;; override
-(defun os-bb-fetch-buglist (last-update)
- "Return the buglist at os-base-url."
- (let* ((url (concat os-base-url "/issues"))
- (res (os-bb-request "GET" url))
- (code (car res))
- (json (cdr res))
- (title (concat "Bugs of " (os-bb-repo-name url))))
-
- `(:title ,title
- :url ,os-base-url
- :bugs ,(mapcar 'os-bb-json-to-bug (cdr (assoc 'issues json))))))
-
-
-(defun os-bb-json-to-bug (json)
- "Return JSON as a bug."
- (flet ((va (key alist) (cdr (assoc key alist)))
- (v (key) (va key json)))
- (let* ((id (v 'local_id))
- (metadata (v 'metadata))
- (kind (va 'kind metadata))
- (version (va 'version metadata))
- (component (va 'component metadata))
- (milestone (va 'milestone metadata))
- (author (va 'username (v 'reported_by)))
- (assignee (va 'username (v 'responsible)))
- (txtstatus (v 'status))
- (status (if (or (string= txtstatus "open")
- (string= txtstatus "new"))
- 'open
- 'closed))
- (priority (v 'priority))
- (title (v 'title))
- (desc (v 'content))
- (ctime (os-parse-date (v 'utc_created_on)))
- (mtime (os-parse-date (v 'utc_last_updated))))
-
- `(:id ,id
- :priority ,priority
- :assignee ,assignee
- :status ,status
- :title ,title
- :desc ,desc
- :date-creation ,ctime
- :date-modification ,mtime
- :kind ,kind
- :version ,version
- :component ,component
- :milestone ,milestone))))
-
-;; override
-(defun os-bb-send-buglist (buglist)
- "Send a BUGLIST on the bugtracker and return new bugs."
- (let* ((new-url (concat os-base-url "/issues"))
- (new-bugs))
- (dolist (b (os-get-prop :bugs buglist))
- (let* ((id (os-get-prop :id b))
- (data (os-bb-post-encode (os-bb-bug-to-form b)))
- (modif-url (format "%s/%d/" new-url (or id 0)))
- res)
- (cond
- ;; new bug
- ((null id)
- (setq res (os-bb-request "POST" new-url data))
- (when (/= (car res) 200)
- (error "Can't create new bug \"%s\"" (os-get-prop :title b)))
- (push (os-bb-json-to-bug (cdr res)) new-bugs))
-
- ;; delete bug
- ((os-get-prop :delete b)
- (setq res (os-bb-request "DELETE" modif-url))
- (when (not (member (car res) '(404 204)))
- (error "Can't delete bug #%d" id)))
-
- ;; update bug
- (t
- (setq res (os-bb-request "PUT" modif-url data))
- (when (/= (car res) 200)
- (error "Can't update bug #%id" id))
- (push (os-bb-json-to-bug (cdr res)) new-bugs)))))
- `(:bugs ,new-bugs)))
-;;; os-bb.el ends here
.emacs.d/lisp/org-sync/os-github.el
@@ -1,272 +0,0 @@
-;;; os-github.el --- Redmine backend for org-sync.
-
-;; Copyright (C) 2012 Aurelien Aptel
-;;
-;; Author: Aurelien Aptel <aurelien dot aptel at gmail dot com>
-;; Keywords: org, github, synchronization
-;; Homepage: http://orgmode.org/worg/org-contrib/gsoc2012/student-projects/org-sync
-;;
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; This file is not part of GNU Emacs.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This package implements a backend for org-sync to synchnonize
-;; issues from a github tracker with an org-mode buffer. Read
-;; Org-sync documentation for more information about it.
-
-;; This backend supports basic bug synching along with tag creation.
-;; If you add or change the tags of an issue to something that doesn't
-;; exists, it will be created.
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-(require 'url)
-(require 'os)
-(require 'json)
-
-(defvar os-github-backend
- '((base-url . os-github-base-url)
- (fetch-buglist . os-github-fetch-buglist)
- (send-buglist . os-github-send-buglist))
- "Github backend.")
-
-(defvar url-http-end-of-headers)
-
-(defvar os-github-auth nil
- "Github login (\"user\" . \"pwd\")")
-
-(defun os-github-fetch-labels ()
- "Return list of labels at os-base-url."
- (let* ((url (concat os-base-url "/labels"))
- (json (os-github-fetch-json url)))
- (mapcar (lambda (x)
- (cdr (assoc 'name x)))
- json)))
-
-(defun os-github-random-color ()
- "Return a random hex color code 6 characters string without #."
- (random t)
- (format "%02X%02X%02X" (random 256) (random 256) (random 256)))
-
-(defun os-github-color-p (color)
- "Return non-nil if COLOR is a valid color code."
- (and (stringp color) (string-match "^[0-9a-fA-F]\\{6\\}$" color)))
-
-(defun os-github-create-label (label &optional color)
- "Create new COLOR LABEL at os-base-url and return it.
-
-LABEL must be a string. COLOR must be a 6 characters string
-containing a hex color code without the #. Take a random color
-when not given."
- (let* ((url (concat os-base-url "/labels"))
- (json (json-encode `((name . ,label)
- (color . ,(if (os-github-color-p color)
- color
- (os-github-random-color)))))))
- (os-github-request "POST" url json)))
-
-(defun os-github-handle-tags (bug existing-tags)
- "Create any label in BUG that is not in EXISTING-TAGS.
-
-Append new tags in EXISTING-TAGS by side effects."
- (let* ((tags (os-get-prop :tags bug)))
- (dolist (tag tags)
- (when (os-append! tag existing-tags)
- (os-github-create-label tag)))))
-
-(defun os-github-time-to-string (time)
- "Return TIME as a full ISO 8601 date string, but without timezone adjustments (which github doesn't support"
- (format-time-string "%Y-%m-%dT%TZ" time t))
-
-;; override
-(defun os-github-fetch-buglist (last-update)
- "Return the buglist at os-base-url."
- (let* ((since (when last-update
- (format "&since=%s" (os-github-time-to-string last-update))))
- (url (concat os-base-url "/issues?per_page=100" since))
- (json (vconcat (os-github-fetch-json url)
- (os-github-fetch-json (concat url "&state=closed"))))
- (title (concat "Bugs of " (os-github-repo-name url))))
-
- `(:title ,title
- :url ,os-base-url
- :bugs ,(mapcar 'os-github-json-to-bug json)
- :since ,last-update)))
-
-;; override
-(defun os-github-base-url (url)
- "Return base url."
- (when (string-match "github.com/\\(?:repos/\\)?\\([^/]+\\)/\\([^/]+\\)" url)
- (let ((user (match-string 1 url))
- (repo (match-string 2 url)))
- (concat "https://api.github.com/repos/" user "/" repo ""))))
-
-;; override
-(defun os-github-send-buglist (buglist)
- "Send a BUGLIST on the bugtracker and return new bugs."
- (let* ((new-url (concat os-base-url "/issues"))
- (existing-tags (os-github-fetch-labels))
- (newbugs))
- (dolist (b (os-get-prop :bugs buglist))
- (let* ((sync (os-get-prop :sync b))
- (id (os-get-prop :id b))
- (data (os-github-bug-to-json b))
- (modif-url (format "%s/%d" new-url (or id 0)))
- (result
- (cond
- ;; new bug
- ((null id)
- (os-github-handle-tags b existing-tags)
- (push (os-github-json-to-bug
- (os-github-request "POST" new-url data)) newbugs))
-
- ;; update bug
- (t
- (os-github-handle-tags b existing-tags)
- (os-github-request "PATCH" modif-url data))))
- (err (cdr (assoc 'message result))))
-
- (when (stringp err)
- (error "Github: %s" err))))
- `(:bugs ,newbugs)))
-
-(defun os-github-fetch-json (url)
- "Return a parsed JSON object of all the pages of URL."
- (let* ((ret (os-github-fetch-json-page url))
- (data (car ret))
- (url (cdr ret))
- (json data))
-
- (while url
- (setq ret (os-github-fetch-json-page url))
- (setq data (car ret))
- (setq url (cdr ret))
- (setq json (vconcat json data)))
-
- json))
-
-(defun os-github-url-retrieve-synchronously (url)
- "Retrieve the specified url using authentication data from
-os-github-auth. AUTH is a cons (\"user\" . \"pwd\")."
- (let ((auth os-github-auth))
- (if (consp auth)
- ;; dynamically bind auth related vars
- (let* ((str (concat (car auth) ":" (cdr auth)))
- (encoded (base64-encode-string str))
- (login `(("api.github.com:443" ("Github API" . ,encoded))))
- (url-basic-auth-storage 'login))
- (url-retrieve-synchronously url))
- ;; nothing more to bind
- (url-retrieve-synchronously url))))
-
-(defun os-github-fetch-json-page (url)
- "Return a cons (JSON object from URL . next page url)."
- (let ((download-buffer (os-github-url-retrieve-synchronously url))
- page-next
- header-end
- ret)
-
- (with-current-buffer download-buffer
- ;; get HTTP header end position
- (goto-char (point-min))
- (re-search-forward "^$" nil 'move)
- (forward-char)
- (setq header-end (point))
-
- ;; get next page url
- (goto-char (point-min))
- (when (re-search-forward
- "<\\(https://api.github.com.+?page=[0-9]+.*?\\)>; rel=\"next\""
- header-end t)
- (setq page-next (match-string 1)))
-
- (goto-char header-end)
- (setq ret (cons (json-read) page-next))
- (kill-buffer)
- ret)))
-
-(defun os-github-request (method url &optional data)
- "Send HTTP request at URL using METHOD with DATA.
-Return the server decoded JSON response."
- (message "%s %s %s" method url (prin1-to-string data))
- (let* ((url-request-method method)
- (url-request-data data)
- (buf (os-github-url-retrieve-synchronously url)))
-
- (with-current-buffer buf
- (goto-char url-http-end-of-headers)
- (prog1 (json-read) (kill-buffer)))))
-
-(defun os-github-repo-name (url)
- "Return the name of the repo at URL."
- (if (string-match "github.com/repos/[^/]+/\\([^/]+\\)" url)
- (match-string 1 url)
- "<project name>"))
-
-;; XXX: we need an actual markdown parser here...
-(defun os-github-filter-desc (desc)
- "Return a filtered description of a GitHub description."
- (if desc (progn
- (setq desc (replace-regexp-in-string "\r\n" "\n" desc))
- (setq desc (replace-regexp-in-string "\\([^ \t\n]\\)[ \t\n]*\\'"
- "\\1\n" desc)))))
-
-
-(defun os-github-json-to-bug (data)
- "Return DATA (in json) converted to a bug."
- (flet ((va (key alist) (cdr (assoc key alist)))
- (v (key) (va key data)))
- (let* ((id (v 'number))
- (stat (if (string= (v 'state) "open") 'open 'closed))
- (title (v 'title))
- (desc (os-github-filter-desc (v 'body)))
- (author (va 'login (v 'user)))
- (assignee (va 'login (v 'assignee)))
- (milestone-alist (v 'milestone))
- (milestone (va 'title milestone-alist))
- (ctime (os-parse-date (v 'created_at)))
- (dtime (os-parse-date (va 'due_on milestone-alist)))
- (mtime (os-parse-date (v 'updated_at)))
- (tags (mapcar (lambda (e)
- (va 'name e)) (v 'labels))))
-
- `(:id ,id
- :author ,author
- :assignee ,assignee
- :status ,stat
- :title ,title
- :desc ,desc
- :milestone ,milestone
- :tags ,tags
- :date-deadline ,dtime
- :date-creation ,ctime
- :date-modification ,mtime))))
-
-(defun os-github-bug-to-json (bug)
- "Return BUG as JSON."
- (let ((state (os-get-prop :status bug)))
- (unless (member state '(open closed))
- (error "Github: unsupported state \"%s\"" (symbol-name state)))
-
- (json-encode
- `((title . ,(os-get-prop :title bug))
- (body . ,(os-get-prop :desc bug))
- (assignee . ,(os-get-prop :assignee bug))
- (state . ,(symbol-name (os-get-prop :status bug)))
- (labels . [ ,@(os-get-prop :tags bug) ])))))
-
-;;; os-github.el ends here
.emacs.d/lisp/org-sync/os-rmine.el
@@ -1,221 +0,0 @@
-;;; os-rmine.el --- Redmine backend for org-sync.
-
-;; Copyright (C) 2012 Aurelien Aptel
-;;
-;; Author: Aurelien Aptel <aurelien dot aptel at gmail dot com>
-;; Keywords: org, redmine, synchronization
-;; Homepage: http://orgmode.org/worg/org-contrib/gsoc2012/student-projects/org-sync
-;;
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; This file is not part of GNU Emacs.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This package implements a backend for org-sync to synchnonize
-;; issues from a redmine repo with an org-mode buffer. Read Org-sync
-;; documentation for more information about it.
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-(require 'os)
-(require 'url)
-(require 'json)
-
-(defvar url-http-end-of-headers)
-(defvar url-http-response-status)
-
-(defvar os-rmine-backend
- '((base-url . os-rmine-base-url)
- (fetch-buglist . os-rmine-fetch-buglist)
- (send-buglist . os-rmine-send-buglist))
- "Redmine backend.")
-
-(defvar os-rmine-auth nil
- "Redmine login (\"user\" . \"pwd\")")
-
-(defvar os-rmine-project-id nil
- "Project id of current buglist.")
-
-(defconst os-rmine-date-regex
- (rx
- (seq
- (group (repeat 4 digit)) "/"
- (group (repeat 2 digit)) "/"
- (group (repeat 2 digit))
- " "
- (group
- (repeat 2 digit) ":"
- (repeat 2 digit) ":"
- (repeat 2 digit))
- " "
- (group (or "+" "-")
- (repeat 2 digit)
- (repeat 2 digit))))
- "Regex to parse date returned by redmine.")
-
-(defun os-rmine-fetch-meta ()
- "Set `os-rmine-project-id' for now."
- (let* ((res (os-rmine-request "GET" (concat os-base-url ".json")))
- (code (car res))
- (json (cdr res)))
- (when (/= code 200)
- (error "Can't fetch data from %s, wrong url?" os-base-url))
- (setq os-rmine-project-id (cdr (assoc 'id (cdr (assoc 'project json)))))))
-
-(defun os-rmine-parse-date (date)
- "Return time object of DATE."
- (when (string-match os-rmine-date-regex date)
- (os-parse-date (concat (match-string 1 date) "-"
- (match-string 2 date) "-"
- (match-string 3 date) "T"
- (match-string 4 date)
- (match-string 5 date)))))
-
-(defun os-rmine-request (method url &optional data)
- "Send HTTP request at URL using METHOD with DATA.
-AUTH is a cons (\"user\" . \"pwd\"). Return the server
-decoded response in JSON."
- (let* ((url-request-method method)
- (url-request-data data)
- (url-request-extra-headers
- (when data
- '(("Content-Type" . "application/json"))))
- (auth os-rmine-auth)
- (buf))
-
- (when (stringp auth)
- (setq url (os-url-param url `(("key" . ,auth)))))
-
- (message "%s %s %s" method url (prin1-to-string data))
- (setq buf (url-retrieve-synchronously url))
- (with-current-buffer buf
- (goto-char url-http-end-of-headers)
- (prog1
- (cons url-http-response-status (ignore-errors (json-read)))
- (kill-buffer)))))
-
-;; override
-(defun os-rmine-base-url (url)
- "Return base URL."
- ;; if no url type, try http
- (when (not (string-match "^https?://" url))
- (setq url (concat "http://" url)))
-
- (let ((purl (url-generic-parse-url url)))
- (when (string-match "^.*/projects/\\([^/]+\\)" (url-filename purl))
- (concat (url-type purl) "://"
- (url-host purl)
- (match-string 0 (url-filename purl))))))
-
-(defun os-rmine-repo-name (url)
- "Return repo name at URL."
- (when (string-match "projects/\\([^/]+\\)" url)
- (match-string 1 url)))
-
-(defun os-rmine-json-to-bug (json)
- "Return JSON as a bug."
- (flet ((va (key alist) (cdr (assoc key alist)))
- (v (key) (va key json)))
- (let* ((id (v 'id))
- (author (va 'name (v 'author)))
- (txtstatus (va 'name (v 'status)))
- (status (if (or (string= txtstatus "Open")
- (string= txtstatus "New"))
- 'open
- 'closed))
- (priority (va 'name (v 'priority)))
- (title (v 'subject))
- (desc (v 'description))
- (ctime (os-rmine-parse-date (v 'created_on)))
- (mtime (os-rmine-parse-date (v 'updated_on))))
-
- `(:id ,id
- :priority ,priority
- :status ,status
- :title ,title
- :desc ,desc
- :date-creation ,ctime
- :date-modification ,mtime))))
-
-(defun os-rmine-fetch-buglist (last-update)
- "Return the buglist at os-base-url."
- (let* ((url (concat os-base-url "/issues.json"))
- (res (os-rmine-request "GET" url))
- (code (car res))
- (json (cdr res))
- (title (concat "Bugs of " (os-rmine-repo-name url))))
-
- `(:title ,title
- :url ,os-base-url
- :bugs ,(mapcar 'os-rmine-json-to-bug (cdr (assoc 'issues json))))))
-
-(defun os-rmine-bug-to-json (bug)
- (json-encode
- `((issue .
- ((subject . ,(os-get-prop :title bug))
- (description . ,(os-get-prop :desc bug)))))))
-
-
-;; (defun os-rmine-code-success-p (code)
-;; "Return non-nil if HTTP CODE is a success code."
-;; (and (<= 200 code) (< code 300)))
-
-(defun os-rmine-send-buglist (buglist)
- "Send a BUGLIST on the bugtracker and return new bugs."
- (let* ((new-url (concat os-base-url "/issues.json"))
- (root-url (replace-regexp-in-string "/projects/.+"
- "" os-base-url))
- new-bugs)
-
- (os-rmine-fetch-meta)
-
- (dolist (b (os-get-prop :bugs buglist))
- (let* ((id (os-get-prop :id b))
- (data (os-rmine-bug-to-json b))
- (modif-url (format "%s/issues/%d.json" root-url (or id 0)))
- res)
- (cond
- ;; new bug
- ((null id)
- (setq res (os-rmine-request "POST" new-url data))
- (when (/= (car res) 201)
- (error "Can't create new bug \"%s\"" (os-get-prop :title b)))
- (push (os-rmine-json-to-bug
- (cdr (assoc 'issue (cdr res))))
- new-bugs))
-
- ;; delete bug
- ((os-get-prop :delete b)
- (setq res (os-rmine-request "DELETE" modif-url))
- (when (not (member (car res) '(404 204)))
- (error "Can't delete bug #%d" id)))
-
- ;; update bug
- (t
- (setq res (os-rmine-request "PUT" modif-url data))
- (when (/= (car res) 200)
- (error "Can't update bug #%d" id))
-
- ;; fetch the new version since redmine doesn't send it
- (setq res (os-rmine-request "GET" modif-url))
- (when (/= (car res) 200)
- (error "Can't update bug #%d" id))
-
- (push (os-rmine-json-to-bug
- (cdr (assoc 'issue (cdr res))))
- new-bugs)))))
- `(:bugs ,new-bugs)))
-;;; os-rmine.el ends here
.emacs.d/lisp/org-sync/os-rtm.el
@@ -1,176 +0,0 @@
-;;; os-rtm.el --- Remember The Milk backend for org-sync.
-
-;; Copyright (C) 2012 Aurelien Aptel
-;;
-;; Author: Aurelien Aptel <aurelien dot aptel at gmail dot com>
-;; Keywords: org, rtm, synchronization
-;; Homepage: http://orgmode.org/worg/org-contrib/gsoc2012/student-projects/org-sync
-;;
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; This file is not part of GNU Emacs.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This package implements a backend for org-sync to synchnonize
-;; issues from a remember the milk repo with an org-mode buffer. Read
-;; Org-sync documentation for more information about it.
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-(require 'os)
-(require 'json)
-(require 'url)
-
-(defvar os-rtm-api-key "e9b28a9ac67f1bffc3dab1bd94dab722")
-(defvar os-rtm-shared-secret "caef7e509a8dcd82")
-(defvar os-rtm-token nil)
-
-(defvar url-http-end-of-headers)
-(defvar url-http-response-status)
-
-(defun os-rtm-call (method &rest args)
- "Call API METHOD and return result."
- (let* ((param `(("method" . ,method)
- ,@args)))
- (os-rtm-request "GET" "http://api.rememberthemilk.com/services/rest/" param nil 'sign)))
-
-(defvar os-rtm-backend
- '((base-url . os-rtm-base-url)
- (fetch-buglist . os-rtm-fetch-buglist)
- (send-buglist . os-rtm-send-buglist))
- "Bitbucket backend.")
-
-(defun os-rtm-base-url (url)
- "Return base URL. Not used with RTM."
- url)
-
-(defun os-rtm-filter-tasks (response)
- "Return all the real task from RTM rtm.tasks.getList RESPONSE."
- (let (final)
- (mapc (lambda (e)
- (when (assoc 'taskseries e)
- (mapc (lambda (task-series)
- (push task-series final))
- (os-getalist e 'taskseries))))
- (os-getalist (cdr response) 'rsp 'tasks 'list))
- final))
-
-(defun os-rtm-fetch-buglist (last-update)
- (unless os-rtm-token
- (os-rtm-auth))
- (let ((bl
- (mapcar 'os-rtm-task-to-bug
- (os-rtm-filter-tasks (os-rtm-call "rtm.tasks.getList")))))
- `(:title "Tasks"
- :url ,os-base-url
- :bugs ,bl)))
-
-(defun os-rtm-task-to-bug (task)
- "Return TASK as a bug."
- (flet ((v (&rest key) (apply 'os-getalist task key)))
- (let* ((id (string-to-number (v 'id)))
- (title (v 'name))
- (status (if (string= (v 'task 'completed) "")
- 'open
- 'closed))
- (priority (v 'task 'priority))
- (ctime (os-parse-date (v 'created)))
- (mtime (os-parse-date (v 'modified)))
- (dtime (os-parse-date (v 'task 'due))))
- `(:id ,id
- :title ,title
- :status ,status
- :priority ,priority
- :date-creation ,ctime
- :date-modification ,mtime
- :date-deadline ,dtime))))
-
-
-(defun os-rtm-request (method url &optional param data sign)
- "Send HTTP request at URL using METHOD with DATA."
-
- (unless (string-match "/auth/" url)
- (push (cons "format" "json") param))
-
- (when os-rtm-token
- (push (cons "auth_token" os-rtm-token) param))
-
- (push `("api_key" . ,os-rtm-api-key) param)
-
- (when sign
- (push `("api_sig" . ,(os-rtm-sign param)) param))
-
- (setq url (os-url-param url param))
-
- (let* ((url-request-method method)
- (url-request-data data)
- (url-request-extra-headers
- (when data
- '(("Content-Type" . "application/x-www-form-urlencoded"))))
- buf)
-
- (message "%s %s %s" method url (prin1-to-string data))
- (setq buf (url-retrieve-synchronously url))
- (with-current-buffer buf
- (goto-char url-http-end-of-headers)
- (message "%s" (buffer-substring (point) (point-max)))
- (prog1
- (cons url-http-response-status (ignore-errors (json-read)))
- (kill-buffer)))))
-
-(defun os-rtm-auth ()
- "Return the URL to grant access to the user account."
- ;; http://www.rememberthemilk.com/services/auth/?api_key=abc123&perms=delete
-
- (let* ((res (os-rtm-call "rtm.auth.getFrob"))
- (frob (cdr (assoc 'frob (cdadr res))))
- (param `(("api_key" . ,os-rtm-api-key)
- ("perms" . "delete")
- ("frob" . ,frob)))
- url)
-
- ;; add signature
- (push `("api_sig" . ,(os-rtm-sign param)) param)
- (setq url (os-url-param "http://www.rememberthemilk.com/services/auth/" param))
- (browse-url url)
- (when (yes-or-no-p "Application accepted? ")
- (setq
- os-rtm-token
- (os-getalist
- (cdr (os-rtm-call "rtm.auth.getToken" `("frob" . ,frob)))
- 'rsp 'auth 'token)))))
-
-(defun os-rtm-sign (param-alist)
- "Return the signature for the PARAM-ALIST request."
- (let ((param (copy-tree param-alist))
- sign)
-
- ;; sort by key
- (setq param (sort param (lambda (a b)
- (string< (car a) (car b)))))
-
- ;; sign = md5(shared_secret . k1 . v1 . k2 . v2...)
- (md5
- (message
- (concat
- os-rtm-shared-secret
- ;; concat key&value
- (mapconcat (lambda (x)
- (concat (car x) (cdr x)))
- param ""))
-
- nil nil 'utf-8))))
-;;; os-rtm.el ends here
.emacs.d/lisp/org-sync/os.el
@@ -1,943 +0,0 @@
-;;; os.el --- Synchronize Org documents with external services
-
-;; Copyright (C) 2012 Aurelien Aptel
-;;
-;; Author: Aurelien Aptel <aurelien dot aptel at gmail dot com>
-;; Keywords: org, synchronization
-;; Homepage: http://orgmode.org/worg/org-contrib/gsoc2012/student-projects/org-sync
-;;
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; This file is not part of GNU Emacs.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This package implements an extension to org-mode that synchnonizes
-;; org document with external services. It provides an interface that
-;; can be implemented in backends. The current focus is on
-;; bugtrackers services.
-
-;; The entry points are `os-import', `os-sync' and `os'. The first
-;; one prompts for a URL to import, the second one pulls, merges and
-;; pushes every buglists in the current buffer and the third one
-;; combines the others in one function: if nothing in the buffer can
-;; be synchronized, ask for an URL to import.
-
-;; The usual workflow is first to import your buglist with
-;; `os-import', modify it or add a bug and run `os-sync'.
-
-;; A buglist is a top-level headline which has a :url: in its
-;; PROPERTIES block. This headline is composed of a list of
-;; subheadlines which corresponds to bugs. The requirement for a bug
-;; is to have a state, a title and an id. If you add a new bug, it
-;; wont have an id but it will get one once you sync. If you omit the
-;; status, OPEN is chose.
-
-;; The status is an org TODO state. It can be either OPEN or CLOSED.
-;; The title is just the title of the headline. The id is a number in
-;; the PROPERTIES block of the headline.
-
-;; Org DEADLINE timestamp are also handled and can be inserted in a
-;; bug headline which can then be used by the backend if it supports
-;; it.
-
-;; Paragraphs under bug-headlines are considered as their description.
-;; Additionnal data used by the backend are in the PROPERTIES block of
-;; the bug.
-
-;; To add a bug, just insert a new headline under the buglist you want
-;; to modify e.g.:
-;; ** OPEN my new bug
-;; Then simply call `os-sync'.
-
-;;; Code:
-
-;; The data structures used to represent bugs and buglists are simple
-;; plists. It is what backend have to handle, process or return.
-
-;; Buglist example:
-
-;; '(:title "My buglist"
-;; :url "http://github.com/repos/octocat/Hello-World"
-;; :bugs (BUGS...))
-
-;; Bug example:
-
-;; '(:id 3
-;; :status 'open or 'closed
-;; :sync 'conflict-local or 'conflict-remote
-;; :title "foo"
-;; :desc "blah"
-;; :priority "major"
-;; :tags ("a" "b" "c")
-;; :author "Aurélien"
-;; :assignee "Foo"
-;; :milestone "foo"
-
-;; ;; dates are regular emacs time object
-;; :date-deadline ...
-;; :date-creation ...
-;; :date-modification ...
-
-;; ;; backend-specific properties
-;; ;; ...
-;; )
-
-;; Some accesors are available for both structure. See `os-set-prop',
-;; and `os-get-prop'.
-
-
-;; When importing an URL, Org-sync matches the URL against the
-;; variable `os-backend-alist' which maps regexps to backend symbols.
-;; The backend symbol is then used to call the backend functions.
-;; When these functions are called, the variable `os-backend' and
-;; `os-base-url' are dynamically bound to respectively the backend
-;; symbol and the cannonical URL for the thing you are synching with.
-
-;; The symbol part in a `os-backend-alist' pair must be a variable
-;; defined in the backend. It is an alist that maps verb to function
-;; symbol. Each backend must implement at least 3 verbs:
-
-;; * base-url (param: URL)
-
-;; Given the user URL, returns the cannonical URL to represent it.
-;; This URL will be available dynamically to all of your backend
-;; function through the `os-base-url' variable.
-
-;; * fetch-buglist (param: LAST-FETCH-TIME)
-
-;; Fetch the buglist at `os-base-url'. If LAST-FETCH-TIME is non-nil,
-;; and you only fetched things modified since it, you are expected to
-;; set the property :since to it in the buglist you return. You can
-;; add whatever properties you want in a bug. The lisp printer is
-;; used to persist them in the buffer.
-
-;; * send-buglist (param: BUGLIST)
-
-;; Send BUGLIST to the repo at `os-base-url' and return the new bugs
-;; created that way. A bug without an id in BUGLIST is a new bug, the
-;; rest are modified bug.
-
-
-;; When synchronizing, Org-sync parses the current buffer using
-;; org-element and convert any found buglist headline to a buglist
-;; data structure. See `os-headline-to-buglist',
-;; `os-headline-to-bug'.
-
-;; When writing buglists back to the document, Org-sync converts them
-;; to elements -- the data structure used by org-element -- which are
-;; then interpreted by `org-element-interpret-data'. The resulting
-;; string is then inserted in the buffer. See `os-buglist-to-element'
-;; and `os-bug-to-element'.
-
-(eval-when-compile (require 'cl))
-(require 'org)
-(require 'org-element)
-
-(defvar os-backend nil
- "Org-sync current backend.")
-
-(defvar os-base-url nil
- "Org-sync current base url.")
-
-(defvar os-backend-alist
- '(("github.com/\\(?:repos/\\)?[^/]+/[^/]+" . os-github-backend)
- ("bitbucket.org/[^/]+/[^/]+" . os-bb-backend)
- ("/projects/[^/]+" . os-rmine-backend)
- ("rememberthemilk.com" . os-rtm-backend))
- "Alist of url patterns vs corresponding org-sync backend.")
-
-(defvar os-cache-file (concat user-emacs-directory "org-sync-cache")
- "Path to Org-sync cache file.")
-
-(defvar os-cache-alist nil
- "Org-sync cache for buglists.
-Maps URLs to buglist cache.")
-
-(defvar os-conflict-buffer "*Org-sync conflict*"
- "Name of the conflict buffer")
-
-(defvar os-sync-props nil
- "List of property to sync or nil to sync everything.")
-
-(defun os-action-fun (action)
- "Return current backend ACTION function or nil."
- (unless (or (null action) (null os-backend))
- (let ((fsym (assoc-default action (eval os-backend))))
- (when (fboundp fsym)
- fsym))))
-
-(defun os-get-backend (url)
- "Return backend symbol matching URL from `os-backend-alist'."
- (assoc-default url os-backend-alist 'string-match))
-
-(defmacro os-with-backend (backend &rest body)
- "Eval BODY with os-backend set to corresponding BACKEND.
-
-If BACKEND evals to a string it is passed to os-get-backend, the
-resulting symbol is dynamically assigned to os-backend. The url
-is passed to os--base-url and dynamically assigned to
-os-base-url.
-
-Else BACKEND should be a backend symbol. It is
-assigned to os-backend."
- (declare (indent 1) (debug t))
- (let ((res (gensym))
- (url (gensym)))
-
- `(let* ((,res ,backend)
- (,url))
- (when (stringp ,res)
- (setq ,url ,res)
- (setq ,res (os-get-backend ,url)))
- (unless (symbolp ,res)
- (error "Backend %s does not evaluate to a symbol."
- (prin1-to-string ',backend)))
- (let* ((os-backend ,res)
- (os-base-url (os--base-url ,url)))
- ,@body))))
-
-(defun os-set-cache (url buglist)
- "Update URL to BUGLIST in `os-cache-alist'."
- (let ((cell (assoc url os-cache-alist)))
- (if cell
- (setcdr cell buglist)
- (push (cons url buglist) os-cache-alist))))
-
-(defun os-get-cache (url)
- "Return the buglist at URL in cache or nil."
- (cdr (assoc url os-cache-alist)))
-
-(defun os-write-cache ()
- "Write Org-sync cache to `os-cache-file'."
- (with-temp-file os-cache-file
- (prin1 `(setq os-cache-alist ',os-cache-alist) (current-buffer))))
-
-(defun os-load-cache ()
- "Load Org-sync cache from `os-cache-file'."
- (load os-cache-file 'noerror nil))
-
-(defun os-plist-to-alist (plist)
- "Return PLIST as an association list."
- (let* (alist cell q (p plist))
- (while p
- (setq cell (cons (car p) (cadr p)))
- (if alist
- (progn
- (setcdr q (cons cell nil))
- (setq q (cdr q)))
- (setq alist (cons cell nil))
- (setq q alist))
- (setq p (cddr p)))
- alist))
-
-(defun os-propertize (sym)
- "Return sym as a property i.e. prefixed with :."
- (intern (concat ":" (if (symbolp sym)
- (symbol-name sym)
- sym))))
-
-(defun os-get-prop (key b)
- "Return value of the property KEY in buglist or bug B."
- (plist-get b key))
-
-(defun os-set-prop (key val b)
- "Set KEY to VAL in buglist or bug B."
- (plist-put b key val))
-
-(defun os-append! (elem list)
- "Add ELEM at the end of LIST by side effect if it isn't present.
-
-Return ELEM if it was added, nil otherwise."
- (catch :exit
- (let ((p list))
- (while (cdr p)
- (when (equal (car p) elem)
- (throw :exit nil))
- (setq p (cdr p)))
- (setcdr p (cons elem nil))
- elem)))
-
-(defun os--send-buglist (buglist)
- "Send a BUGLIST on the bugtracker."
- (let ((f (os-action-fun 'send-buglist)))
- (if f
- (funcall f buglist)
- (error "No send backend available."))))
-
-(defun os--fetch-buglist (last-update)
- "Return the buglist at url REPO."
- (let ((f (os-action-fun 'fetch-buglist)))
- (if f
- (funcall f last-update)
- (error "No fetch backend available."))))
-
-
-(defun os--base-url (url)
- "Return the base url of URL."
- (let ((f (os-action-fun 'base-url)))
- (if f
- (funcall f url)
- (error "No base-url backend available."))))
-
-
-(defun os-url-param (url param)
- "Return URL with PARAM alist appended."
- (let* ((split (split-string url "\\?" t))
- (base (car split))
- (rest (cadr split))
- (final))
-
- ;; read all param
- (when rest
- (mapc
- (lambda (s)
- (let* ((split (split-string s "=" t))
- (var (car split))
- (val (cadr split))
- (cell (assoc var final)))
- (if cell
- (setcdr cell val)
- (push (cons var val) final))))
- (split-string rest "&" t)))
-
- ;; add params from arg
- (mapc (lambda (p)
- (let* ((var (car p))
- (val (cdr p))
- (cell (assoc var final)))
- (if cell
- (setcdr cell val)
- (push p final))))
- param)
-
- ;; output new url
- (concat
- base
- "?"
- (mapconcat (lambda (p)
- (concat
- (url-hexify-string (car p))
- "="
- (url-hexify-string (cdr p))))
- final "&"))))
-
-;; OPEN bugs sorted by mod time then CLOSED bugs sorted by mod time
-(defun os-bug-sort (a b)
- "Return non-nil if bug A should appear before bug B."
- (flet ((time-less-safe (a b)
- (if (and a b)
- (time-less-p a b)
- (or a b))))
- (let* ((ao (eq 'open (os-get-prop :status a)))
- (bc (not (eq 'open (os-get-prop :status b))))
- (am (time-less-safe
- (os-get-prop :date-modification b)
- (os-get-prop :date-modification a))))
- (or
- (and ao am)
- (and bc am)
- (and ao bc)))))
-
-(defun os-buglist-to-element (bl)
- "Return buglist BL as an element."
- (let* ((skip '(:title :bugs :date-cache))
- (sorted (sort (os-get-prop :bugs bl) 'os-bug-sort))
- (elist (delq nil (mapcar 'os-bug-to-element sorted)))
- (title (os-get-prop :title bl))
- (url (os-get-prop :url bl))
- (props (sort (mapcar
- ;; stringify prop name
- (lambda (x)
- (cons (substring (symbol-name (car x)) 1) (cdr x)))
- ;; remove skipped prop
- (remove-if (lambda (x)
- (memq (car x) skip))
- (os-plist-to-alist bl)))
- ;; sort prop by key
- (lambda (a b)
- (string< (car a) (car b))))))
-
- (os-set-prop :bugs sorted bl)
- `(headline
- (:level 1 :title (,title))
- (section
- nil
- ,(os-alist-to-property-drawer props))
- ,@elist)))
-
-(defun os-filter-list (list minus)
- "Return a copy of LIST without elements in MINUS."
- (let ((final (copy-seq list)))
- (mapc (lambda (x)
- (delq x final)) minus)
- final))
-
-(defun os-bug-to-element (b)
- "Return bug B as a TODO element if it is visible or nil."
- ;; not in PROPERTIES block
- (let* ((skip '(:title :status :desc :old-bug
- :date-deadline :date-creation :date-modification))
- (title (os-get-prop :title b))
- (dtime (os-get-prop :date-deadline b))
- (ctime (os-get-prop :date-creation b))
- (mtime (os-get-prop :date-modification b))
- (prop-alist (loop for (a b) on b by #'cddr
- if (and b (not (memq a skip)))
- collect (cons (substring (symbol-name a) 1)
- (prin1-to-string b)))))
- (unless (os-get-prop :delete b)
- ;; add date-xxx props manually in a human readable way.
- (push (cons
- "date-creation"
- (os-time-to-string ctime)) prop-alist)
- (push (cons
- "date-modification"
- (os-time-to-string mtime)) prop-alist)
-
- ;; sort PROPERTIES by property name
- (setq prop-alist (sort prop-alist
- (lambda (a b)
- (string< (car b) (car a)))))
-
- `(headline
- (:title ,(concat
- title
- (when dtime
- (concat
- " DEADLINE: "
- (format-time-string (org-time-stamp-format) dtime))))
- :level 2
- :todo-type todo
- :todo-keyword ,(upcase (symbol-name (os-get-prop :status b))))
- (section
- nil
- ,(os-alist-to-property-drawer prop-alist)
- (fixed-width (:value ,(os-get-prop :desc b))))))))
-
-(defun os-headline-url (e)
- "Returns the url of the buglist in headline E."
- (cdr (assoc "url"
- (os-property-drawer-to-alist
- (car (org-element-contents
- (car (org-element-contents e))))))))
-
-(defun os-buglist-headline-p (elem)
- "Return t if ELEM is a buglist headline."
- (and
- (eq (org-element-type elem) 'headline)
- (stringp (os-headline-url elem))))
-
-(defun os-property-drawer-to-alist (drawer)
- "Return the alist of all key value pairs"
- (org-element-map drawer
- 'node-property
- (lambda (x) (cons (org-element-property :key x)
- (org-element-property :value x)))))
-
-(defun os-alist-to-property-drawer (alist)
- "Return the property drawer corresponding to an alist of key
- value pairs"
- `(property-drawer nil
- ,(mapcar
- (lambda (x) `(node-property (:key ,(car x) :value ,(cdr x))))
- alist)))
-
-(defun os-headline-to-buglist (h)
- "Return headline H as a buglist."
- (let* ((skip '(:url))
- (alist (os-property-drawer-to-alist
- (car (org-element-contents
- (car (org-element-contents h))))))
- (title (car (org-element-property :title h)))
- (url (cdr (assoc "url" alist)))
- (bugs (mapcar
- 'os-headline-to-bug
- (nthcdr 1 (org-element-contents h))))
- (bl `(:title ,title
- :url ,url
- :bugs ,bugs)))
-
- ;; add all other properties
- (mapc (lambda (x)
- (let ((k (os-propertize (car x)))
- (v (cdr x)))
- (unless (memq k skip)
- (os-set-prop k v bl))))
- alist)
-
- bl))
-
-(defun os-headline-to-bug (h)
- "Return headline H as a bug."
- (let* ((todo-keyword (org-element-property :todo-keyword h))
- ;; properties to skip when looking at the PROPERTIES block
- (skip '(:status :title :desc :date-deadline :date-creation :date-modification))
- (status (intern (downcase (or todo-keyword "open"))))
- (dtime (os-parse-date (org-element-property :deadline h)))
- (title (car (org-element-property :title h)))
- (section (org-element-contents (car (org-element-contents h))))
- (headline-alist (os-property-drawer-to-alist
- (car
- (org-element-contents
- (car (org-element-contents h))))))
- (ctime (os-parse-date (cdr (assoc "date-creation" headline-alist))))
- (mtime (os-parse-date (cdr (assoc "date-modification" headline-alist))))
- desc
- bug)
-
- (dolist (e section)
- (let ((type (org-element-type e))
- (content (org-element-contents e)))
- (cond
- ;; interpret quote block as actual text
- ((eq type 'fixed-width)
- (setq desc (concat desc (org-element-property :value e))))
-
- ;; ignore these
- ((or (eq type 'property-drawer)
- (eq type 'planning)
- (and (eq type 'paragraph)
- (string-match "^ *DEADLINE: " (car content))))
- nil)
-
- ;; else, interpret via org-element
- (t
- (setq desc (concat desc (org-element-interpret-data e)))))))
-
- ;; deadlines can be either on the same line as the headline or
- ;; on the next one. org-element doesn't parse it the same way
- ;; when on the same line, remove DEADLINE tag from title
- ;; else ignore DEADLINE tag in paragraph
- (when dtime
- (setq title (replace-regexp-in-string " DEADLINE: " "" title)))
-
- (setq bug (list
- :status status
- :title title
- :desc desc
- :date-deadline dtime
- :date-creation ctime
- :date-modification mtime))
-
- ;; add all properties
- (mapc (lambda (x)
- (let ((k (os-propertize (car x)))
- (v (when (and (cdr x) (not (equal (cdr x) "")))
- (read (cdr x)))))
- (unless (memq k skip)
- (setq bug (cons k (cons v bug)))))) headline-alist)
- bug))
-
-(defun os-find-buglists (elem)
- "Return every buglist headlines in ELEM."
- (let ((type (org-element-type elem))
- (contents (org-element-contents elem)))
- (cond
- ;; if it's a buglist, return it
- ((os-buglist-headline-p elem)
- elem)
- ;; else if it contains elements, look recursively in it
- ((or (eq type 'org-data) (memq type org-element-greater-elements))
- (let (buglist)
- (mapc (lambda (e)
- (let ((h (os-find-buglists e)))
- (when h
- (setq buglist (cons h buglist)))))
- contents)
- buglist))
- ;; terminal case
- (t
- nil))))
-
-(defun os-add-keyword (tree key val)
- "Add KEY:VAL as a header in TREE by side-effects and return TREE.
-If KEY is already equal to VAL, no change is made."
- (catch :exit
- (let* ((section (first (org-element-contents tree))))
- (when (and (eq 'org-data (org-element-type tree))
- (eq 'section (org-element-type section)))
-
- (dolist (e (org-element-contents section))
- (let* ((type (org-element-type e))
- (ekey (org-element-property :key e))
- (eval (org-element-property :value e)))
-
- (when (and (eq 'keyword type)
- (string= ekey key)
- (string= eval val))
- (throw :exit nil))))
-
- (setf (nthcdr 2 section)
- (cons
- `(keyword (:key ,key :value ,val))
- (org-element-contents section))))))
- tree)
-
-(defun os-org-reparse ()
- "Reparse current buffer."
- ;; from org-ctrl-c-ctrl-c, thanks to vsync in #org-mode
- (let ((org-inhibit-startup-visibility-stuff t)
- (org-startup-align-all-tables nil))
- (when (boundp 'org-table-coordinate-overlays)
- (mapc 'delete-overlay org-table-coordinate-overlays)
- (setq org-table-coordinate-overlays nil))
- (org-save-outline-visibility 'use-markers (org-mode-restart))))
-
-(defun os-import (url)
- "Fetch and insert at point bugs from URL."
- (interactive "sURL: ")
- (os-with-backend url
- (let* ((buglist (os--fetch-buglist nil))
- (elem (os-buglist-to-element buglist))
- (bug-keyword '(sequence "OPEN" "|" "CLOSED")))
-
- ;; we add the buglist to the cache
- (os-set-prop :date-cache (current-time) buglist)
- (os-set-cache os-base-url buglist)
-
- (save-excursion
- (insert (org-element-interpret-data
- `(org-data nil ,elem)))
-
- (unless (member bug-keyword org-todo-keywords)
- (goto-char (point-min))
- (insert "#+TODO: OPEN | CLOSED\n")
- (add-to-list 'org-todo-keywords bug-keyword)
-
- ;; the buffer has to be reparsed in order to have the new
- ;; keyword taken into account
- (os-org-reparse)))))
- (message "Import complete."))
-
-(defun os-get-bug-id (buglist id)
- "Return bug ID from BUGLIST."
- (when id
- (catch :exit
- (mapc (lambda (x)
- (let ((current-id (os-get-prop :id x)))
- (when (and (numberp current-id) (= current-id id))
- (throw :exit x))))
- (os-get-prop :bugs buglist))
- nil)))
-
-(defun os-buglist-dups (buglist)
- "Return non-nil if BUGLIST contains bugs with the same id.
-The value returned is a list of duplicated ids."
- (let ((hash (make-hash-table))
- (dups))
- (mapc (lambda (x)
- (let ((id (os-get-prop :id x)))
- (puthash id (1+ (gethash id hash 0)) hash)))
- (os-get-prop :bugs buglist))
- (maphash (lambda (id nb)
- (when (> nb 1)
- (push id dups))) hash)
- dups))
-
-(defun os-time-max (&rest timelist)
- "Return the largest time in TIMELIST."
- (reduce (lambda (a b)
- (if (and a b)
- (if (time-less-p a b) b a))
- (or a b))
- timelist))
-
-(defun os-buglist-last-update (buglist)
- "Return the most recent creation/modi date in BUGLIST."
- (apply 'os-time-max (loop for x in (os-get-prop :bugs buglist)
- collect (os-get-prop :date-creation x) and
- collect (os-get-prop :date-modification x))))
-
-(defun os-set-equal (a b)
- "Return t if list A and B have the same elements, no matter the order."
- (catch :exit
- (mapc (lambda (e)
- (unless (member e b)
- (throw :exit nil)))
- a)
- (mapc (lambda (e)
- (unless (member e a)
- (throw :exit nil)))
- b)
- t))
-
-(defun os-parse-date (date)
- "Parse and return DATE as a time or nil."
- (when (and (stringp date) (not (string= date "")))
- (date-to-time date)))
-
-(defun os-time-to-string (time)
- "Return TIME as a full ISO 8601 date string."
- (format-time-string "%Y-%m-%dT%T%z" time))
-
-(defun os-bug-diff (a b)
- "Return an alist of properties that differs in A and B or nil if A = B.
-The form of the alist is ((:property . (valueA valueB)...)"
- (let ((diff)
- (props-list
- (append
- (loop for (akey aval) on a by #'cddr collect akey)
- (loop for (bkey bval) on b by #'cddr collect bkey))))
- (delete-dups props-list)
- (dolist (key props-list diff)
- (let ((va (os-get-prop key a))
- (vb (os-get-prop key b)))
- (unless (equal va vb)
- (setq diff (cons `(,key . (,va ,vb)) diff)))))))
-
-(defun os-bug-prop-equalp (prop a b)
- "Return t if bug A PROP = bug B PROP, nil otherwise."
- (equal (os-get-prop prop a) (os-get-prop prop b)))
-
-(defun os-buglist-diff (a b)
- "Return a diff buglist which turns buglist A to B when applied.
-This function makes the assumption that A ⊂ B."
- (let (diff)
- (dolist (bbug (os-get-prop :bugs b))
- (let ((abug (os-get-bug-id a (os-get-prop :id bbug))))
- (when (or (null abug) (os-bug-diff abug bbug))
- (push bbug diff))))
- `(:bugs ,diff)))
-
-(defun os-merge-diff (local remote)
- "Return the merge of LOCAL diff and REMOTE diff.
-The merge is the union of the diff. Conflicting bugs are tagged
-with :sync conflict-local or conflict-remote."
- (let ((added (make-hash-table))
- merge)
- ;; add all local bugs
- (dolist (lbug (os-get-prop :bugs local))
- (let* ((id (os-get-prop :id lbug))
- (rbug (os-get-bug-id remote id))
- rnew lnew)
-
- ;; if there's a remote bug with the same id, we have a
- ;; conflict
-
- ;; if the local bug has a sync prop, it was merged by the
- ;; user, so we keep the local one (which might be the
- ;; remote from a previous sync)
- (if (and rbug (null (os-get-prop :sync lbug)) (os-bug-diff lbug rbug))
- (progn
- (setq lnew (copy-tree lbug))
- (os-set-prop :sync 'conflict-local lnew)
- (setq rnew (copy-tree rbug))
- (os-set-prop :sync 'conflict-remote rnew)
- (push rnew merge)
- (push lnew merge))
- (progn
- (push lbug merge)))
-
- ;; mark it
- (puthash id t added)))
-
- ;; add new remote bug which are the unmarked bugs in remote
- (dolist (rbug (os-get-prop :bugs remote))
- (unless (gethash (os-get-prop :id rbug) added)
- (push rbug merge)))
-
- `(:bugs ,merge)))
-
-(defun os-update-buglist (base diff)
- "Apply buglist DIFF to buglist BASE and return the result.
-This is done according to `os-sync-props'."
- (let ((added (make-hash-table))
- new)
- (dolist (bug (os-get-prop :bugs base))
- (let* ((id (os-get-prop :id bug))
- (diff-bug (os-get-bug-id diff id))
- new-bug)
-
- (if (and os-sync-props diff-bug)
- (progn
- (setq new-bug bug)
- (mapc (lambda (p)
- (os-set-prop p (os-get-prop p diff-bug) new-bug))
- os-sync-props))
- (setq new-bug (or diff-bug bug)))
-
- (push new-bug new)
- (puthash id t added)))
-
- (dolist (bug (os-get-prop :bugs diff))
- (let ((id (os-get-prop :id bug)))
- (when (or (null id) (null (gethash id added)))
- (push bug new))))
-
- (let ((new-buglist (copy-list base)))
- (os-set-prop :bugs new new-buglist)
- new-buglist)))
-
-(defun os-remove-unidentified-bug (buglist)
- "Remove bugs without id from BUGLIST."
- (let ((new-bugs))
- (dolist (b (os-get-prop :bugs buglist))
- (when (os-get-prop :id b)
- (push b new-bugs)))
- (os-set-prop :bugs new-bugs buglist)
- buglist))
-
-(defun os-replace-headline-by-buglist (headline buglist)
- "Replace HEADLINE by BUGLIST by side effects."
- (let ((new-headline (os-buglist-to-element buglist)))
- (setf (car headline) (car new-headline)
- (cdr headline) (cdr new-headline))))
-
-(defun os-show-conflict (buglist url)
- "Show conflict in BUGLIST at URL in conflict window."
- (let ((buf (get-buffer-create os-conflict-buffer)))
- (with-help-window buf
- (with-current-buffer buf
- (erase-buffer)
- (org-mode)
- (insert "There were some conflicts while merging. Here
-are the problematic items. Look at the :sync property to know
-their origin. Copy what you want to keep in your org buffer and
-sync again.\n\n")
- (dolist (b (os-get-prop :bugs buglist))
- (when (and b (os-get-prop :sync b))
- (insert (org-element-interpret-data (os-bug-to-element b))
- "\n")))))))
-
-(defun os-getalist (obj &rest keys)
- "Apply assoc in nested alist OBJ with KEYS."
- (let ((p obj))
- (dolist (k keys p)
- (setq p (cdr (assoc k p))))))
-
-(defun os-filter-bug (bug)
- "Filter BUG according to `os-sync-props'."
- (if os-sync-props
- (let ((new-bug `(:id ,(os-get-prop :id bug))))
- (mapc (lambda (x)
- (os-set-prop x (os-get-prop x bug) new-bug))
- os-sync-props)
- new-bug)
- bug))
-
-(defun os-filter-diff (diff)
- "Filter DIFF according to `os-sync-props'."
- (when os-sync-props
- (let (final)
- (dolist (b (os-get-prop :bugs diff))
- (let ((id (os-get-prop :id b)))
- ;; drop new bugs
- (when id
- (push (os-filter-bug b) final))))
- (os-set-prop :bugs final diff)))
- diff)
-
-(defun os-sync ()
- "Update buglists in current buffer."
- (interactive)
- (ignore-errors (kill-buffer os-conflict-buffer))
-
- ;; parse the buffer and find the buglist-looking headlines
- (let* ((local-doc (org-element-parse-buffer))
- (local-headlines (os-find-buglists local-doc)))
-
- ;; for each of these headlines, convert it to buglist
- (dolist (headline local-headlines)
- (let* ((local (os-headline-to-buglist headline))
- (url (os-get-prop :url local)))
-
- ;; if it has several bug with the same id, stop
- (when (os-buglist-dups local)
- (error
- "Buglist \"%s\" contains unmerged bugs."
- (os-get-prop :title local)))
-
- ;; local cache remote
- ;; \ / \ /
- ;; parse load load fetch
- ;; \ / \ /
- ;; local-diff remote-diff
- ;; \ /
- ;; \ /
- ;; merged-diff --------send-------->
- ;; (...)
- ;; local <--recv-updated-diff---
- ;; v
- ;; merged
- ;; v
- ;; new cache/local/remote
-
- ;; handle buglist with the approriate backend
- (os-with-backend url
- (let* ((cache (os-get-cache os-base-url))
- (last-fetch (os-get-prop :date-cache cache))
- (local-diff (os-buglist-diff cache local))
- remote remote-diff merged merged-diff)
-
- ;; fetch remote buglist
- (if last-fetch
- ;; make a partial fetch and apply it to cache if the backend
- ;; supports it
- (let* ((partial-fetch (os--fetch-buglist last-fetch)))
- (if (os-get-prop :since partial-fetch)
- (setq remote (os-update-buglist cache partial-fetch))
- (setq remote partial-fetch)))
- (setq remote (os--fetch-buglist nil)))
- ;; at this point remote is the full remote buglist
-
- (setq remote-diff (os-buglist-diff cache remote))
- (setq merged-diff (os-merge-diff local-diff remote-diff))
-
- ;; filter according to os-sync-props
- (os-filter-diff merged-diff)
-
- (setq merged (os-update-buglist local merged-diff))
-
- ;; if merged-diff has duplicate bugs, there's a conflict
- (let ((dups (os-buglist-dups merged-diff)))
- (if dups
- (progn
- (message "Synchronization failed, manual merge needed.")
- (os-show-conflict merged-diff os-base-url))
-
- ;; else update buffer and cache
- (setq merged
- (os-remove-unidentified-bug
- (os-update-buglist merged (os--send-buglist merged-diff))))
- (os-set-prop :date-cache (current-time) merged)
- (os-set-cache os-base-url merged)
- (message "Synchronization complete.")))
-
- ;; replace headlines in local-doc
- (os-replace-headline-by-buglist headline merged)))))
-
- (os-add-keyword local-doc "TODO" "OPEN | CLOSED")
-
- ;; since we replace the whole buffer, save-excusion doesn't work so
- ;; we manually (re)store the point
- (let ((oldpoint (point)))
- (delete-region (point-min) (point-max))
- (goto-char (point-min))
- (insert (org-element-interpret-data local-doc))
- (goto-char oldpoint))))
-
-(defun os ()
- "Synchronize current buffer or import an external document.
-
-If no Org-sync elements are present in the buffer, ask for a URL
-to import otherwise synchronize the buffer."
- (interactive)
- (let* ((local-doc (org-element-parse-buffer)))
- (if (os-find-buglists local-doc)
- (os-sync)
- (call-interactively 'os-import))))
-
-(provide 'os)
-;;; os.el ends here
.emacs.d/emacs.org
@@ -1995,45 +1995,6 @@
(org-agenda-text-search-extra-files nil)))))
#+END_SRC
-*** Externals (caldav, issues, ..)
-**** General (org-sync)
-
-
- #+BEGIN_SRC emacs-lisp
- (add-to-list 'load-path "~/.emacs.d/lisp/org-sync")
- (mapc 'load
- '("org-element" "os" "os-bb" "os-github" "os-rmine"))
- #+END_SRC
-
-
-**** Redmine
-
- On some project (mainly @work), redmine is used. As I'm using
- org-mode for tracking the stuff I do and the time I spent on it,
- let's integrate org-mode and redmine.
-
- #+BEGIN_SRC emacs-lisp
- (use-package org-redmine
- :ensure t)
- #+END_SRC
-
- The uri of the redmine(s) will be specified in a org-babel
- matter in the org files that need it. Still have to define a
- default template.
-
-**** Trello
-
- On some project, [[https://trello.com/][Trello]] is used and, there a emacs package for
- that :).
-
- #+BEGIN_SRC emacs-lisp
- (use-package org-trello
- :ensure t)
- #+END_SRC
-
- Now, a /manual/ step will be to install consumer key and stuff
- (see [[https://org-trello.github.io/trello-setup.html][documentation]] for that).
-
*** Pomodoro