| 1 | ;;; gnus-sync.el --- synchronization facility for Gnus |
| 2 | |
| 3 | ;; Copyright (C) 2010-2012 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: Ted Zlatanov <tzz@lifelogs.com> |
| 6 | ;; Keywords: news synchronization nntp nnrss |
| 7 | |
| 8 | ;; This file is part of GNU Emacs. |
| 9 | |
| 10 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
| 11 | ;; it under the terms of the GNU General Public License as published by |
| 12 | ;; the Free Software Foundation, either version 3 of the License, or |
| 13 | ;; (at your option) any later version. |
| 14 | |
| 15 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 18 | ;; GNU General Public License for more details. |
| 19 | |
| 20 | ;; You should have received a copy of the GNU General Public License |
| 21 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
| 22 | |
| 23 | ;;; Commentary: |
| 24 | |
| 25 | ;; This is the gnus-sync.el package. |
| 26 | |
| 27 | ;; Put this in your startup file (~/.gnus.el for instance) |
| 28 | |
| 29 | ;; possibilities for gnus-sync-backend: |
| 30 | ;; Tramp over SSH: /ssh:user@host:/path/to/filename |
| 31 | ;; ...or any other file Tramp and Emacs can handle... |
| 32 | |
| 33 | ;; (setq gnus-sync-backend "/remote:/path.gpg" ; will use Tramp+EPA if loaded |
| 34 | ;; gnus-sync-global-vars '(gnus-newsrc-last-checked-date) |
| 35 | ;; gnus-sync-newsrc-groups '("nntp" "nnrss")) |
| 36 | ;; gnus-sync-newsrc-offsets '(2 3)) |
| 37 | ;; against a LeSync server (beware the vampire LeSync, who knows your newsrc) |
| 38 | |
| 39 | ;; (setq gnus-sync-backend '(lesync "http://lesync.info:5984/tzz") |
| 40 | ;; gnus-sync-newsrc-groups '("nntp" "nnrss")) |
| 41 | |
| 42 | ;; What's a LeSync server? |
| 43 | |
| 44 | ;; 1. install CouchDB, set up a real server admin user, and create a |
| 45 | ;; database, e.g. "tzz" and save the URL, |
| 46 | ;; e.g. http://lesync.info:5984/tzz |
| 47 | |
| 48 | ;; 2. run `M-: (gnus-sync-lesync-setup "http://lesync.info:5984/tzz" "tzzadmin" "mypassword" "mysalt" t t)' |
| 49 | |
| 50 | ;; (If you run it more than once, you have to remove the entry from |
| 51 | ;; _users yourself. This is intentional. This sets up a database |
| 52 | ;; admin for the "tzz" database, distinct from the server admin |
| 53 | ;; user in (1) above.) |
| 54 | |
| 55 | ;; That's it, you can start using http://lesync.info:5984/tzz in your |
| 56 | ;; gnus-sync-backend as a LeSync backend. Fan fiction about the |
| 57 | ;; vampire LeSync is welcome. |
| 58 | |
| 59 | ;; You may not want to expose a CouchDB install to the Big Bad |
| 60 | ;; Internet, especially if your love of all things furry would be thus |
| 61 | ;; revealed. Make sure it's not accessible by unauthorized users and |
| 62 | ;; guests, at least. |
| 63 | |
| 64 | ;; If you want to try it out, I will create a test DB for you under |
| 65 | ;; http://lesync.info:5984/yourfavoritedbname |
| 66 | |
| 67 | ;; TODO: |
| 68 | |
| 69 | ;; - after gnus-sync-read, the message counts look wrong until you do |
| 70 | ;; `g'. So it's not run automatically, you have to call it with M-x |
| 71 | ;; gnus-sync-read |
| 72 | |
| 73 | ;; - use gnus-after-set-mark-hook and gnus-before-update-mark-hook to |
| 74 | ;; catch the mark updates |
| 75 | |
| 76 | ;; - repositioning of groups within topic after a LeSync sync is a |
| 77 | ;; weird sort of bubble sort ("buttle" sort: the old entry ends up |
| 78 | ;; at the rear of the list); you will eventually end up with the |
| 79 | ;; right order after calling `gnus-sync-read' a bunch of times. |
| 80 | |
| 81 | ;; - installing topics and groups is inefficient and annoying, lots of |
| 82 | ;; prompts could be avoided |
| 83 | |
| 84 | ;;; Code: |
| 85 | |
| 86 | (eval-when-compile (require 'cl)) |
| 87 | (require 'json) |
| 88 | (require 'gnus) |
| 89 | (require 'gnus-start) |
| 90 | (require 'gnus-util) |
| 91 | |
| 92 | (defvar gnus-topic-alist) ;; gnus-group.el |
| 93 | (eval-when-compile |
| 94 | (autoload 'gnus-group-topic "gnus-topic") |
| 95 | (autoload 'gnus-topic-create-topic "gnus-topic" nil t) |
| 96 | (autoload 'gnus-topic-enter-dribble "gnus-topic")) |
| 97 | |
| 98 | (defgroup gnus-sync nil |
| 99 | "The Gnus synchronization facility." |
| 100 | :version "24.1" |
| 101 | :group 'gnus) |
| 102 | |
| 103 | (defcustom gnus-sync-newsrc-groups '("nntp" "nnrss") |
| 104 | "List of groups to be synchronized in the gnus-newsrc-alist. |
| 105 | The group names are matched, they don't have to be fully |
| 106 | qualified. Typically you would choose all of these. That's the |
| 107 | default because there is no active sync backend by default, so |
| 108 | this setting is harmless until the user chooses a sync backend." |
| 109 | :group 'gnus-sync |
| 110 | :type '(repeat regexp)) |
| 111 | |
| 112 | (defcustom gnus-sync-global-vars nil |
| 113 | "List of global variables to be synchronized. |
| 114 | You may want to sync `gnus-newsrc-last-checked-date' but pretty |
| 115 | much any symbol is fair game. You could additionally sync |
| 116 | `gnus-newsrc-alist', `gnus-server-alist', `gnus-topic-topology', |
| 117 | and `gnus-topic-alist'. Also see `gnus-variable-list'." |
| 118 | :group 'gnus-sync |
| 119 | :type '(repeat (choice (variable :tag "A known variable") |
| 120 | (symbol :tag "Any symbol")))) |
| 121 | |
| 122 | (defcustom gnus-sync-backend nil |
| 123 | "The synchronization backend." |
| 124 | :group 'gnus-sync |
| 125 | :type '(radio (const :format "None" nil) |
| 126 | (list :tag "Sync server" |
| 127 | (const :format "LeSync Server API" lesync) |
| 128 | (string :tag "URL of a CouchDB database for API access")) |
| 129 | (string :tag "Sync to a file"))) |
| 130 | |
| 131 | (defvar gnus-sync-newsrc-loader nil |
| 132 | "Carrier for newsrc data") |
| 133 | |
| 134 | (defcustom gnus-sync-lesync-name (system-name) |
| 135 | "The LeSync name for this machine." |
| 136 | :group 'gnus-sync |
| 137 | :type 'string) |
| 138 | |
| 139 | (defcustom gnus-sync-lesync-install-topics 'ask |
| 140 | "Should LeSync install the recorded topics?" |
| 141 | :group 'gnus-sync |
| 142 | :type '(choice (const :tag "Never Install" nil) |
| 143 | (const :tag "Always Install" t) |
| 144 | (const :tag "Ask Me Once" ask))) |
| 145 | |
| 146 | (defvar gnus-sync-lesync-props-hash (make-hash-table :test 'equal) |
| 147 | "LeSync props, keyed by group name") |
| 148 | |
| 149 | (defvar gnus-sync-lesync-design-prefix "/_design/lesync" |
| 150 | "The LeSync design prefix for CouchDB") |
| 151 | |
| 152 | (defvar gnus-sync-lesync-security-object "/_security" |
| 153 | "The LeSync security object for CouchDB") |
| 154 | |
| 155 | (defun gnus-sync-lesync-parse () |
| 156 | "Parse the result of a LeSync request." |
| 157 | (goto-char (point-min)) |
| 158 | (condition-case nil |
| 159 | (when (search-forward-regexp "^$" nil t) |
| 160 | (json-read)) |
| 161 | (error |
| 162 | (gnus-message |
| 163 | 1 |
| 164 | "gnus-sync-lesync-parse: Could not read the LeSync response!") |
| 165 | nil))) |
| 166 | |
| 167 | (defun gnus-sync-lesync-call (url method headers &optional kvdata) |
| 168 | "Make an access request to URL using KVDATA and METHOD. |
| 169 | KVDATA must be an alist." |
| 170 | (flet ((json-alist-p (list) (gnus-sync-json-alist-p list))) ; temp patch |
| 171 | (let ((url-request-method method) |
| 172 | (url-request-extra-headers headers) |
| 173 | (url-request-data (if kvdata (json-encode kvdata) nil))) |
| 174 | (with-current-buffer (url-retrieve-synchronously url) |
| 175 | (let ((data (gnus-sync-lesync-parse))) |
| 176 | (gnus-message 12 "gnus-sync-lesync-call: %s URL %s sent %S got %S" |
| 177 | method url `((headers . ,headers) (data ,kvdata)) data) |
| 178 | (kill-buffer (current-buffer)) |
| 179 | data))))) |
| 180 | |
| 181 | (defun gnus-sync-lesync-PUT (url headers &optional data) |
| 182 | (gnus-sync-lesync-call url "PUT" headers data)) |
| 183 | |
| 184 | (defun gnus-sync-lesync-POST (url headers &optional data) |
| 185 | (gnus-sync-lesync-call url "POST" headers data)) |
| 186 | |
| 187 | (defun gnus-sync-lesync-GET (url headers &optional data) |
| 188 | (gnus-sync-lesync-call url "GET" headers data)) |
| 189 | |
| 190 | (defun gnus-sync-lesync-DELETE (url headers &optional data) |
| 191 | (gnus-sync-lesync-call url "DELETE" headers data)) |
| 192 | |
| 193 | ;; this is not necessary with newer versions of json.el but 1.2 or older |
| 194 | ;; (which are in Emacs 24.1 and earlier) need it |
| 195 | (defun gnus-sync-json-alist-p (list) |
| 196 | "Non-null if and only if LIST is an alist." |
| 197 | (while (consp list) |
| 198 | (setq list (if (consp (car list)) |
| 199 | (cdr list) |
| 200 | 'not-alist))) |
| 201 | (null list)) |
| 202 | |
| 203 | ;; this is not necessary with newer versions of json.el but 1.2 or older |
| 204 | ;; (which are in Emacs 24.1 and earlier) need it |
| 205 | (defun gnus-sync-json-plist-p (list) |
| 206 | "Non-null if and only if LIST is a plist." |
| 207 | (while (consp list) |
| 208 | (setq list (if (and (keywordp (car list)) |
| 209 | (consp (cdr list))) |
| 210 | (cddr list) |
| 211 | 'not-plist))) |
| 212 | (null list)) |
| 213 | |
| 214 | ; (gnus-sync-lesync-setup "http://lesync.info:5984/tzz" "tzzadmin" "mypassword" "mysalt" t t) |
| 215 | ; (gnus-sync-lesync-setup "http://lesync.info:5984/tzz") |
| 216 | |
| 217 | (defun gnus-sync-lesync-setup (url &optional user password salt reader admin) |
| 218 | (interactive "sEnter URL to set up: ") |
| 219 | "Set up the LeSync database at URL. |
| 220 | Install USER as a READER and/or an ADMIN in the security object |
| 221 | under \"_security\", and in the CouchDB \"_users\" table using |
| 222 | PASSWORD and SALT. Only one USER is thus supported for now. |
| 223 | When SALT is nil, a random one will be generated using `random'." |
| 224 | (let* ((design-url (concat url gnus-sync-lesync-design-prefix)) |
| 225 | (security-object (concat url "/_security")) |
| 226 | (user-record `((names . [,user]) (roles . []))) |
| 227 | (couch-user-name (format "org.couchdb.user:%s" user)) |
| 228 | (salt (or salt (sha1 (format "%s" (random))))) |
| 229 | (couch-user-record |
| 230 | `((_id . ,couch-user-name) |
| 231 | (type . user) |
| 232 | (name . ,(format "%s" user)) |
| 233 | (roles . []) |
| 234 | (salt . ,salt) |
| 235 | (password_sha . ,(when password |
| 236 | (sha1 |
| 237 | (format "%s%s" password salt)))))) |
| 238 | (rev (progn |
| 239 | (gnus-sync-lesync-find-prop 'rev design-url design-url) |
| 240 | (gnus-sync-lesync-get-prop 'rev design-url))) |
| 241 | (latest-func "function(head,req) |
| 242 | { |
| 243 | var tosend = []; |
| 244 | var row; |
| 245 | var ftime = (req.query['ftime'] || 0); |
| 246 | while (row = getRow()) |
| 247 | { |
| 248 | if (row.value['float-time'] > ftime) |
| 249 | { |
| 250 | var s = row.value['_id']; |
| 251 | if (s) tosend.push('\"'+s.replace('\"', '\\\"')+'\"'); |
| 252 | } |
| 253 | } |
| 254 | send('['+tosend.join(',') + ']'); |
| 255 | }") |
| 256 | ;; <key>read</key> |
| 257 | ;; <dict> |
| 258 | ;; <key>de.alt.fan.ipod</key> |
| 259 | ;; <array> |
| 260 | ;; <integer>1</integer> |
| 261 | ;; <integer>2</integer> |
| 262 | ;; <dict> |
| 263 | ;; <key>start</key> |
| 264 | ;; <integer>100</integer> |
| 265 | ;; <key>length</key> |
| 266 | ;; <integer>100</integer> |
| 267 | ;; </dict> |
| 268 | ;; </array> |
| 269 | ;; </dict> |
| 270 | (xmlplistread-func "function(head, req) { |
| 271 | var row; |
| 272 | start({ 'headers': { 'Content-Type': 'text/xml' } }); |
| 273 | |
| 274 | send('<dict>'); |
| 275 | send('<key>read</key>'); |
| 276 | send('<dict>'); |
| 277 | while(row = getRow()) |
| 278 | { |
| 279 | var read = row.value.read; |
| 280 | if (read && read[0] && read[0] == 'invlist') |
| 281 | { |
| 282 | send('<key>'+row.key+'</key>'); |
| 283 | //send('<invlist>'+read+'</invlist>'); |
| 284 | send('<array>'); |
| 285 | |
| 286 | var from = 0; |
| 287 | var flip = false; |
| 288 | |
| 289 | for (var i = 1; i < read.length && read[i]; i++) |
| 290 | { |
| 291 | var cur = read[i]; |
| 292 | if (flip) |
| 293 | { |
| 294 | if (from == cur-1) |
| 295 | { |
| 296 | send('<integer>'+read[i]+'</integer>'); |
| 297 | } |
| 298 | else |
| 299 | { |
| 300 | send('<dict>'); |
| 301 | send('<key>start</key>'); |
| 302 | send('<integer>'+from+'</integer>'); |
| 303 | send('<key>end</key>'); |
| 304 | send('<integer>'+(cur-1)+'</integer>'); |
| 305 | send('</dict>'); |
| 306 | } |
| 307 | |
| 308 | } |
| 309 | flip = ! flip; |
| 310 | from = cur; |
| 311 | } |
| 312 | send('</array>'); |
| 313 | } |
| 314 | } |
| 315 | |
| 316 | send('</dict>'); |
| 317 | send('</dict>'); |
| 318 | } |
| 319 | ") |
| 320 | (subs-func "function(doc){emit([doc._id, doc.source], doc._rev);}") |
| 321 | (revs-func "function(doc){emit(doc._id, doc._rev);}") |
| 322 | (bytimesubs-func "function(doc) |
| 323 | {emit([(doc['float-time']||0), doc._id], doc._rev);}") |
| 324 | (bytime-func "function(doc) |
| 325 | {emit([(doc['float-time']||0), doc._id], doc);}") |
| 326 | (groups-func "function(doc){emit(doc._id, doc);}")) |
| 327 | (and (if user |
| 328 | (and (assq 'ok (gnus-sync-lesync-PUT |
| 329 | security-object |
| 330 | nil |
| 331 | (append (and reader |
| 332 | (list `(readers . ,user-record))) |
| 333 | (and admin |
| 334 | (list `(admins . ,user-record)))))) |
| 335 | (assq 'ok (gnus-sync-lesync-PUT |
| 336 | (concat (file-name-directory url) |
| 337 | "_users/" |
| 338 | couch-user-name) |
| 339 | nil |
| 340 | couch-user-record))) |
| 341 | t) |
| 342 | (assq 'ok (gnus-sync-lesync-PUT |
| 343 | design-url |
| 344 | nil |
| 345 | `(,@(when rev (list (cons '_rev rev))) |
| 346 | (lists . ((latest . ,latest-func) |
| 347 | (xmlplistread . ,xmlplistread-func))) |
| 348 | (views . ((subs . ((map . ,subs-func))) |
| 349 | (revs . ((map . ,revs-func))) |
| 350 | (bytimesubs . ((map . ,bytimesubs-func))) |
| 351 | (bytime . ((map . ,bytime-func))) |
| 352 | (groups . ((map . ,groups-func))))))))))) |
| 353 | |
| 354 | (defun gnus-sync-lesync-find-prop (prop url key) |
| 355 | "Retrieve a PROPerty of a document KEY at URL. |
| 356 | Calls `gnus-sync-lesync-set-prop'. |
| 357 | For the 'rev PROP, uses '_rev against the document." |
| 358 | (gnus-sync-lesync-set-prop |
| 359 | prop key (cdr (assq (if (eq prop 'rev) '_rev prop) |
| 360 | (gnus-sync-lesync-GET url nil))))) |
| 361 | |
| 362 | (defun gnus-sync-lesync-set-prop (prop key val) |
| 363 | "Update the PROPerty of document KEY at URL to VAL. |
| 364 | Updates `gnus-sync-lesync-props-hash'." |
| 365 | (puthash (format "%s.%s" key prop) val gnus-sync-lesync-props-hash)) |
| 366 | |
| 367 | (defun gnus-sync-lesync-get-prop (prop key) |
| 368 | "Get the PROPerty of KEY from `gnus-sync-lesync-props-hash'." |
| 369 | (gethash (format "%s.%s" key prop) gnus-sync-lesync-props-hash)) |
| 370 | |
| 371 | (defun gnus-sync-deep-print (data) |
| 372 | (let* ((print-quoted t) |
| 373 | (print-readably t) |
| 374 | (print-escape-multibyte nil) |
| 375 | (print-escape-nonascii t) |
| 376 | (print-length nil) |
| 377 | (print-level nil) |
| 378 | (print-circle nil) |
| 379 | (print-escape-newlines t)) |
| 380 | (format "%S" data))) |
| 381 | |
| 382 | (defun gnus-sync-newsrc-loader-builder (&optional only-modified) |
| 383 | (let* ((entries (cdr gnus-newsrc-alist)) |
| 384 | entry name ret) |
| 385 | (while entries |
| 386 | (setq entry (pop entries) |
| 387 | name (car entry)) |
| 388 | (when (gnus-grep-in-list name gnus-sync-newsrc-groups) |
| 389 | (if only-modified |
| 390 | (when (not (equal (gnus-sync-deep-print entry) |
| 391 | (gnus-sync-lesync-get-prop 'checksum name))) |
| 392 | (gnus-message 9 "%s: add %s, it's modified" |
| 393 | "gnus-sync-newsrc-loader-builder" name) |
| 394 | (push entry ret)) |
| 395 | (push entry ret)))) |
| 396 | ret)) |
| 397 | |
| 398 | ; (json-encode (gnus-sync-range2invlist '((1 . 47137) (47139 . 47714) 48129 48211 49231 49281 49342 49473 49475 49502))) |
| 399 | (defun gnus-sync-range2invlist (ranges) |
| 400 | (append '(invlist) |
| 401 | (let ((ranges (delq nil ranges)) |
| 402 | ret range from to) |
| 403 | (while ranges |
| 404 | (setq range (pop ranges)) |
| 405 | (if (atom range) |
| 406 | (setq from range |
| 407 | to range) |
| 408 | (setq from (car range) |
| 409 | to (cdr range))) |
| 410 | (push from ret) |
| 411 | (push (1+ to) ret)) |
| 412 | (reverse ret)))) |
| 413 | |
| 414 | ; (let* ((d '((1 . 47137) (47139 . 47714) 48129 48211 49231 49281 49342 49473 49475 49502)) (j (format "%S" (gnus-sync-invlist2range (gnus-sync-range2invlist d))))) (or (equal (format "%S" d) j) j)) |
| 415 | (defun gnus-sync-invlist2range (inv) |
| 416 | (setq inv (append inv nil)) |
| 417 | (if (equal (format "%s" (car inv)) "invlist") |
| 418 | (let ((i (cdr inv)) |
| 419 | (start 0) |
| 420 | ret cur top flip) |
| 421 | (while i |
| 422 | (setq cur (pop i)) |
| 423 | (when flip |
| 424 | (setq top (1- cur)) |
| 425 | (if (= start top) |
| 426 | (push start ret) |
| 427 | (push (cons start top) ret))) |
| 428 | (setq flip (not flip)) |
| 429 | (setq start cur)) |
| 430 | (reverse ret)) |
| 431 | inv)) |
| 432 | |
| 433 | (defun gnus-sync-position (search list &optional test) |
| 434 | "Find the position of SEARCH in LIST using TEST, defaulting to `eq'." |
| 435 | (let ((pos 0) |
| 436 | (test (or test 'eq))) |
| 437 | (while (and list (not (funcall test (car list) search))) |
| 438 | (pop list) |
| 439 | (incf pos)) |
| 440 | (if (funcall test (car list) search) pos nil))) |
| 441 | |
| 442 | (defun gnus-sync-topic-group-position (group topic-name) |
| 443 | (gnus-sync-position |
| 444 | group (cdr (assoc topic-name gnus-topic-alist)) 'equal)) |
| 445 | |
| 446 | (defun gnus-sync-fix-topic-group-position (group topic-name position) |
| 447 | (unless (equal position (gnus-sync-topic-group-position group topic-name)) |
| 448 | (let* ((loc "gnus-sync-fix-topic-group-position") |
| 449 | (groups (delete group (cdr (assoc topic-name gnus-topic-alist)))) |
| 450 | (position (min position (1- (length groups)))) |
| 451 | (old (nth position groups))) |
| 452 | (when (and old (not (equal old group))) |
| 453 | (setf (nth position groups) group) |
| 454 | (setcdr (assoc topic-name gnus-topic-alist) |
| 455 | (append groups (list old))) |
| 456 | (gnus-message 9 "%s: %s moved to %d, swap with %s" |
| 457 | loc group position old))))) |
| 458 | |
| 459 | (defun gnus-sync-lesync-pre-save-group-entry (url nentry &rest passed-props) |
| 460 | (let* ((loc "gnus-sync-lesync-save-group-entry") |
| 461 | (k (car nentry)) |
| 462 | (revision (gnus-sync-lesync-get-prop 'rev k)) |
| 463 | (sname gnus-sync-lesync-name) |
| 464 | (topic (gnus-group-topic k)) |
| 465 | (topic-offset (gnus-sync-topic-group-position k topic)) |
| 466 | (sources (gnus-sync-lesync-get-prop 'source k))) |
| 467 | ;; set the revision so we don't have a conflict |
| 468 | `(,@(when revision |
| 469 | (list (cons '_rev revision))) |
| 470 | (_id . ,k) |
| 471 | ;; the time we saved |
| 472 | ,@passed-props |
| 473 | ;; add our name to the sources list for this key |
| 474 | (source ,@(if (member gnus-sync-lesync-name sources) |
| 475 | sources |
| 476 | (cons gnus-sync-lesync-name sources))) |
| 477 | ,(cons 'level (nth 1 nentry)) |
| 478 | ,@(if topic (list (cons 'topic topic)) nil) |
| 479 | ,@(if topic-offset (list (cons 'topic-offset topic-offset)) nil) |
| 480 | ;; the read marks |
| 481 | ,(cons 'read (gnus-sync-range2invlist (nth 2 nentry))) |
| 482 | ;; the other marks |
| 483 | ,@(delq nil (mapcar (lambda (mark-entry) |
| 484 | (gnus-message 12 "%s: prep param %s in %s" |
| 485 | loc |
| 486 | (car mark-entry) |
| 487 | (nth 3 nentry)) |
| 488 | (if (listp (cdr mark-entry)) |
| 489 | (cons (car mark-entry) |
| 490 | (gnus-sync-range2invlist |
| 491 | (cdr mark-entry))) |
| 492 | (progn ; else this is not a list |
| 493 | (gnus-message 9 "%s: non-list param %s in %s" |
| 494 | loc |
| 495 | (car mark-entry) |
| 496 | (nth 3 nentry)) |
| 497 | nil))) |
| 498 | (nth 3 nentry)))))) |
| 499 | |
| 500 | (defun gnus-sync-lesync-post-save-group-entry (url entry) |
| 501 | (let* ((loc "gnus-sync-lesync-post-save-group-entry") |
| 502 | (k (cdr (assq 'id entry)))) |
| 503 | (cond |
| 504 | ;; success! |
| 505 | ((and (assq 'rev entry) (assq 'id entry)) |
| 506 | (progn |
| 507 | (gnus-sync-lesync-set-prop 'rev k (cdr (assq 'rev entry))) |
| 508 | (gnus-sync-lesync-set-prop 'checksum |
| 509 | k |
| 510 | (gnus-sync-deep-print |
| 511 | (assoc k gnus-newsrc-alist))) |
| 512 | (gnus-message 9 "%s: successfully synced %s to %s" |
| 513 | loc k url))) |
| 514 | ;; specifically check for document conflicts |
| 515 | ((equal "conflict" (format "%s" (cdr-safe (assq 'error entry)))) |
| 516 | (gnus-error |
| 517 | 1 |
| 518 | "%s: use `%s' to resolve the conflict synchronizing %s to %s: %s" |
| 519 | loc "gnus-sync-read" k url (cdr (assq 'reason entry)))) |
| 520 | ;; generic errors |
| 521 | ((assq 'error entry) |
| 522 | (gnus-error 1 "%s: got error while synchronizing %s to %s: %s" |
| 523 | loc k url (cdr (assq 'reason entry)))) |
| 524 | |
| 525 | (t |
| 526 | (gnus-message 2 "%s: unknown sync status after %s to %s: %S" |
| 527 | loc k url entry))) |
| 528 | (assoc 'error entry))) |
| 529 | |
| 530 | (defun gnus-sync-lesync-groups-builder (url) |
| 531 | (let ((u (concat url gnus-sync-lesync-design-prefix "/_view/groups"))) |
| 532 | (cdr (assq 'rows (gnus-sync-lesync-GET u nil))))) |
| 533 | |
| 534 | (defun gnus-sync-subscribe-group (name) |
| 535 | "Subscribe to group NAME. Returns NAME on success, nil otherwise." |
| 536 | (gnus-subscribe-newsgroup name)) |
| 537 | |
| 538 | (defun gnus-sync-lesync-read-group-entry (url name entry &rest passed-props) |
| 539 | "Read ENTRY information for NAME. Returns NAME if successful. |
| 540 | Skips entries whose sources don't contain |
| 541 | `gnus-sync-lesync-name'. When the alist PASSED-PROPS has a |
| 542 | `subscribe-all' element that evaluates to true, we attempt to |
| 543 | subscribe to unknown groups. The user is also allowed to delete |
| 544 | unwanted groups via the LeSync URL." |
| 545 | (let* ((loc "gnus-sync-lesync-read-group-entry") |
| 546 | (entry (gnus-sync-lesync-normalize-group-entry entry passed-props)) |
| 547 | (subscribe-all (cdr (assq 'subscribe-all passed-props))) |
| 548 | (sources (cdr (assq 'source entry))) |
| 549 | (rev (cdr (assq 'rev entry))) |
| 550 | (in-sources (member gnus-sync-lesync-name sources)) |
| 551 | (known (assoc name gnus-newsrc-alist)) |
| 552 | cell) |
| 553 | (unless known |
| 554 | (if (and subscribe-all |
| 555 | (y-or-n-p (format "Subscribe to group %s?" name))) |
| 556 | (setq known (gnus-sync-subscribe-group name) |
| 557 | in-sources t) |
| 558 | ;; else... |
| 559 | (when (y-or-n-p (format "Delete group %s from server?" name)) |
| 560 | (if (equal name (gnus-sync-lesync-delete-group url name)) |
| 561 | (gnus-message 1 "%s: removed group %s from server %s" |
| 562 | loc name url) |
| 563 | (gnus-error 1 "%s: could not remove group %s from server %s" |
| 564 | loc name url))))) |
| 565 | (when known |
| 566 | (unless in-sources |
| 567 | (setq in-sources |
| 568 | (y-or-n-p |
| 569 | (format "Read group %s even though %s is not in sources %S?" |
| 570 | name gnus-sync-lesync-name (or sources "")))))) |
| 571 | (when rev |
| 572 | (gnus-sync-lesync-set-prop 'rev name rev)) |
| 573 | |
| 574 | ;; if the source matches AND we have this group |
| 575 | (if (and known in-sources) |
| 576 | (progn |
| 577 | (gnus-message 10 "%s: reading LeSync entry %s, sources %S" |
| 578 | loc name sources) |
| 579 | (while entry |
| 580 | (setq cell (pop entry)) |
| 581 | (let ((k (car cell)) |
| 582 | (val (cdr cell))) |
| 583 | (gnus-sync-lesync-set-prop k name val))) |
| 584 | name) |
| 585 | ;; else... |
| 586 | (unless known |
| 587 | (gnus-message 5 "%s: ignoring entry %s, it wasn't subscribed. %s" |
| 588 | loc name "Call `gnus-sync-read' with C-u to force it.")) |
| 589 | (unless in-sources |
| 590 | (gnus-message 5 "%s: ignoring entry %s, %s not in sources %S" |
| 591 | loc name gnus-sync-lesync-name (or sources ""))) |
| 592 | nil))) |
| 593 | |
| 594 | (defun gnus-sync-lesync-install-group-entry (name) |
| 595 | (let* ((master (assoc name gnus-newsrc-alist)) |
| 596 | (old-topic-name (gnus-group-topic name)) |
| 597 | (old-topic (assoc old-topic-name gnus-topic-alist)) |
| 598 | (target-topic-name (gnus-sync-lesync-get-prop 'topic name)) |
| 599 | (target-topic-offset (gnus-sync-lesync-get-prop 'topic-offset name)) |
| 600 | (target-topic (assoc target-topic-name gnus-topic-alist)) |
| 601 | (loc "gnus-sync-lesync-install-group-entry")) |
| 602 | (if master |
| 603 | (progn |
| 604 | (when (eq 'ask gnus-sync-lesync-install-topics) |
| 605 | (setq gnus-sync-lesync-install-topics |
| 606 | (y-or-n-p "Install topics from LeSync?"))) |
| 607 | (when (and (eq t gnus-sync-lesync-install-topics) |
| 608 | target-topic-name) |
| 609 | (if (equal old-topic-name target-topic-name) |
| 610 | (gnus-message 12 "%s: %s is already in topic %s" |
| 611 | loc name target-topic-name) |
| 612 | ;; see `gnus-topic-move-group' |
| 613 | (when (and old-topic target-topic) |
| 614 | (setcdr old-topic (gnus-delete-first name (cdr old-topic))) |
| 615 | (gnus-message 5 "%s: removing %s from topic %s" |
| 616 | loc name old-topic-name)) |
| 617 | (unless target-topic |
| 618 | (when (y-or-n-p (format "Create missing topic %s?" |
| 619 | target-topic-name)) |
| 620 | (gnus-topic-create-topic target-topic-name nil) |
| 621 | (setq target-topic (assoc target-topic-name |
| 622 | gnus-topic-alist)))) |
| 623 | (if target-topic |
| 624 | (prog1 |
| 625 | (nconc target-topic (list name)) |
| 626 | (gnus-message 5 "%s: adding %s to topic %s" |
| 627 | loc name (car target-topic)) |
| 628 | (gnus-topic-enter-dribble)) |
| 629 | (gnus-error 2 "%s: LeSync group %s can't go in missing topic %s" |
| 630 | loc name target-topic-name))) |
| 631 | (when (and target-topic-offset target-topic) |
| 632 | (gnus-sync-fix-topic-group-position |
| 633 | name target-topic-name target-topic-offset))) |
| 634 | ;; install the subscription level |
| 635 | (when (gnus-sync-lesync-get-prop 'level name) |
| 636 | (setf (nth 1 master) (gnus-sync-lesync-get-prop 'level name))) |
| 637 | ;; install the read and other marks |
| 638 | (setf (nth 2 master) (gnus-sync-lesync-get-prop 'read name)) |
| 639 | (setf (nth 3 master) (gnus-sync-lesync-get-prop 'marks name)) |
| 640 | (gnus-sync-lesync-set-prop 'checksum |
| 641 | name |
| 642 | (gnus-sync-deep-print master)) |
| 643 | nil) |
| 644 | (gnus-error 1 "%s: invalid LeSync group %s" loc name) |
| 645 | 'invalid-name))) |
| 646 | |
| 647 | ; (gnus-sync-lesync-delete-group (cdr gnus-sync-backend) "nntp+Gmane:gwene.org.slashdot") |
| 648 | |
| 649 | (defun gnus-sync-lesync-delete-group (url name) |
| 650 | "Returns NAME if successful deleting it from URL, an error otherwise." |
| 651 | (interactive "sEnter URL to set up: \rsEnter group name: ") |
| 652 | (let* ((u (concat (cadr gnus-sync-backend) "/" (url-hexify-string name))) |
| 653 | (del (gnus-sync-lesync-DELETE |
| 654 | u |
| 655 | `(,@(when (gnus-sync-lesync-get-prop 'rev name) |
| 656 | (list (cons "If-Match" |
| 657 | (gnus-sync-lesync-get-prop 'rev name)))))))) |
| 658 | (or (cdr (assq 'id del)) del))) |
| 659 | |
| 660 | ;;; (gnus-sync-lesync-normalize-group-entry '((subscribe . ["invlist"]) (read . ["invlist"]) (topic-offset . 20) (topic . "news") (level . 6) (source . ["a" "b"]) (float-time . 1319671237.099285) (_rev . "10-edf5107f41e5e6f7f6629d1c0ee172f7") (_id . "nntp+news.net:alt.movies")) '((read-time 1319672156.486414) (subscribe-all nil))) |
| 661 | |
| 662 | (defun gnus-sync-lesync-normalize-group-entry (entry &optional passed-props) |
| 663 | (let (ret |
| 664 | marks |
| 665 | cell) |
| 666 | (setq entry (append passed-props entry)) |
| 667 | (while (setq cell (pop entry)) |
| 668 | (let ((k (car cell)) |
| 669 | (val (cdr cell))) |
| 670 | (cond |
| 671 | ((eq k 'read) |
| 672 | (push (cons k (gnus-sync-invlist2range val)) ret)) |
| 673 | ;; we ignore these parameters |
| 674 | ((member k '(_id subscribe-all _deleted_conflicts)) |
| 675 | nil) |
| 676 | ((eq k '_rev) |
| 677 | (push (cons 'rev val) ret)) |
| 678 | ((eq k 'source) |
| 679 | (push (cons 'source (append val nil)) ret)) |
| 680 | ((or (eq k 'float-time) |
| 681 | (eq k 'level) |
| 682 | (eq k 'topic) |
| 683 | (eq k 'topic-offset) |
| 684 | (eq k 'read-time)) |
| 685 | (push (cons k val) ret)) |
| 686 | ;;; "How often have I said to you that when you have eliminated the |
| 687 | ;;; impossible, whatever remains, however improbable, must be the |
| 688 | ;;; truth?" --Sherlock Holmes |
| 689 | ;; everything remaining must be a mark |
| 690 | (t (push (cons k (gnus-sync-invlist2range val)) marks))))) |
| 691 | (cons (cons 'marks marks) ret))) |
| 692 | |
| 693 | (defun gnus-sync-save (&optional force) |
| 694 | "Save the Gnus sync data to the backend. |
| 695 | With a prefix, FORCE is set and all groups will be saved." |
| 696 | (interactive "P") |
| 697 | (cond |
| 698 | ((and (listp gnus-sync-backend) |
| 699 | (eq (nth 0 gnus-sync-backend) 'lesync) |
| 700 | (stringp (nth 1 gnus-sync-backend))) |
| 701 | |
| 702 | ;; refresh the revisions if we're forcing the save |
| 703 | (when force |
| 704 | (mapc (lambda (entry) |
| 705 | (when (and (assq 'key entry) |
| 706 | (assq 'value entry)) |
| 707 | (gnus-sync-lesync-set-prop |
| 708 | 'rev |
| 709 | (cdr (assq 'key entry)) |
| 710 | (cdr (assq 'value entry))))) |
| 711 | ;; the revs view is key = name, value = rev |
| 712 | (cdr (assq 'rows (gnus-sync-lesync-GET |
| 713 | (concat (nth 1 gnus-sync-backend) |
| 714 | gnus-sync-lesync-design-prefix |
| 715 | "/_view/revs") |
| 716 | nil))))) |
| 717 | |
| 718 | (let* ((ftime (float-time)) |
| 719 | (url (nth 1 gnus-sync-backend)) |
| 720 | (entries |
| 721 | (mapcar (lambda (entry) |
| 722 | (gnus-sync-lesync-pre-save-group-entry |
| 723 | (cadr gnus-sync-backend) |
| 724 | entry |
| 725 | (cons 'float-time ftime))) |
| 726 | (gnus-sync-newsrc-loader-builder (not force)))) |
| 727 | ;; when there are no entries, there's nothing to save |
| 728 | (sync (if entries |
| 729 | (gnus-sync-lesync-POST |
| 730 | (concat url "/_bulk_docs") |
| 731 | '(("Content-Type" . "application/json")) |
| 732 | `((docs . ,(vconcat entries nil)))) |
| 733 | (gnus-message |
| 734 | 2 "gnus-sync-save: nothing to save to the LeSync backend") |
| 735 | nil))) |
| 736 | (mapcar (lambda (e) (gnus-sync-lesync-post-save-group-entry url e)) |
| 737 | sync))) |
| 738 | ((stringp gnus-sync-backend) |
| 739 | (gnus-message 7 "gnus-sync-save: saving to backend %s" gnus-sync-backend) |
| 740 | ;; populate gnus-sync-newsrc-loader from all but the first dummy |
| 741 | ;; entry in gnus-newsrc-alist whose group matches any of the |
| 742 | ;; gnus-sync-newsrc-groups |
| 743 | ;; TODO: keep the old contents for groups we don't have! |
| 744 | (let ((gnus-sync-newsrc-loader (gnus-sync-newsrc-loader-builder))) |
| 745 | (with-temp-file gnus-sync-backend |
| 746 | (progn |
| 747 | (let ((coding-system-for-write gnus-ding-file-coding-system) |
| 748 | (standard-output (current-buffer))) |
| 749 | (princ (format ";; -*- mode:emacs-lisp; coding: %s; -*-\n" |
| 750 | gnus-ding-file-coding-system)) |
| 751 | (princ ";; Gnus sync data v. 0.0.1\n") |
| 752 | ;; TODO: replace with `gnus-sync-deep-print' |
| 753 | (let* ((print-quoted t) |
| 754 | (print-readably t) |
| 755 | (print-escape-multibyte nil) |
| 756 | (print-escape-nonascii t) |
| 757 | (print-length nil) |
| 758 | (print-level nil) |
| 759 | (print-circle nil) |
| 760 | (print-escape-newlines t) |
| 761 | (variables (cons 'gnus-sync-newsrc-loader |
| 762 | gnus-sync-global-vars)) |
| 763 | variable) |
| 764 | (while variables |
| 765 | (if (and (boundp (setq variable (pop variables))) |
| 766 | (symbol-value variable)) |
| 767 | (progn |
| 768 | (princ "\n(setq ") |
| 769 | (princ (symbol-name variable)) |
| 770 | (princ " '") |
| 771 | (prin1 (symbol-value variable)) |
| 772 | (princ ")\n")) |
| 773 | (princ "\n;;; skipping empty variable ") |
| 774 | (princ (symbol-name variable))))) |
| 775 | (gnus-message |
| 776 | 7 |
| 777 | "gnus-sync-save: stored variables %s and %d groups in %s" |
| 778 | gnus-sync-global-vars |
| 779 | (length gnus-sync-newsrc-loader) |
| 780 | gnus-sync-backend) |
| 781 | |
| 782 | ;; Idea from Dan Christensen <jdc@chow.mat.jhu.edu> |
| 783 | ;; Save the .eld file with extra line breaks. |
| 784 | (gnus-message 8 "gnus-sync-save: adding whitespace to %s" |
| 785 | gnus-sync-backend) |
| 786 | (save-excursion |
| 787 | (goto-char (point-min)) |
| 788 | (while (re-search-forward "^(\\|(\\\"" nil t) |
| 789 | (replace-match "\n\\&" t)) |
| 790 | (goto-char (point-min)) |
| 791 | (while (re-search-forward " $" nil t) |
| 792 | (replace-match "" t t)))))))) |
| 793 | ;; the pass-through case: gnus-sync-backend is not a known choice |
| 794 | (nil))) |
| 795 | |
| 796 | (defun gnus-sync-read (&optional subscribe-all) |
| 797 | "Load the Gnus sync data from the backend. |
| 798 | With a prefix, SUBSCRIBE-ALL is set and unknown groups will be subscribed." |
| 799 | (interactive "P") |
| 800 | (when gnus-sync-backend |
| 801 | (gnus-message 7 "gnus-sync-read: loading from backend %s" gnus-sync-backend) |
| 802 | (cond |
| 803 | ((and (listp gnus-sync-backend) |
| 804 | (eq (nth 0 gnus-sync-backend) 'lesync) |
| 805 | (stringp (nth 1 gnus-sync-backend))) |
| 806 | (let ((errored nil) |
| 807 | name ftime) |
| 808 | (mapc (lambda (entry) |
| 809 | (setq name (cdr (assq 'id entry))) |
| 810 | ;; set ftime the FIRST time through this loop, that |
| 811 | ;; way it reflects the time we FINISHED reading |
| 812 | (unless ftime (setq ftime (float-time))) |
| 813 | |
| 814 | (unless errored |
| 815 | (setq errored |
| 816 | (when (equal name |
| 817 | (gnus-sync-lesync-read-group-entry |
| 818 | (nth 1 gnus-sync-backend) |
| 819 | name |
| 820 | (cdr (assq 'value entry)) |
| 821 | `(read-time ,ftime) |
| 822 | `(subscribe-all ,subscribe-all))) |
| 823 | (gnus-sync-lesync-install-group-entry |
| 824 | (cdr (assq 'id entry))))))) |
| 825 | (gnus-sync-lesync-groups-builder (nth 1 gnus-sync-backend))))) |
| 826 | |
| 827 | ((stringp gnus-sync-backend) |
| 828 | ;; read data here... |
| 829 | (if (or debug-on-error debug-on-quit) |
| 830 | (load gnus-sync-backend nil t) |
| 831 | (condition-case var |
| 832 | (load gnus-sync-backend nil t) |
| 833 | (error |
| 834 | (error "Error in %s: %s" gnus-sync-backend (cadr var))))) |
| 835 | (let ((valid-count 0) |
| 836 | invalid-groups) |
| 837 | (dolist (node gnus-sync-newsrc-loader) |
| 838 | (if (gnus-gethash (car node) gnus-newsrc-hashtb) |
| 839 | (progn |
| 840 | (incf valid-count) |
| 841 | (loop for store in (cdr node) |
| 842 | do (setf (nth (car store) |
| 843 | (assoc (car node) gnus-newsrc-alist)) |
| 844 | (cdr store)))) |
| 845 | (push (car node) invalid-groups))) |
| 846 | (gnus-message |
| 847 | 7 |
| 848 | "gnus-sync-read: loaded %d groups (out of %d) from %s" |
| 849 | valid-count (length gnus-sync-newsrc-loader) |
| 850 | gnus-sync-backend) |
| 851 | (when invalid-groups |
| 852 | (gnus-message |
| 853 | 7 |
| 854 | "gnus-sync-read: skipped %d groups (out of %d) from %s" |
| 855 | (length invalid-groups) |
| 856 | (length gnus-sync-newsrc-loader) |
| 857 | gnus-sync-backend) |
| 858 | (gnus-message 9 "gnus-sync-read: skipped groups: %s" |
| 859 | (mapconcat 'identity invalid-groups ", "))))) |
| 860 | (nil)) |
| 861 | |
| 862 | (gnus-message 9 "gnus-sync-read: remaking the newsrc hashtable") |
| 863 | (gnus-make-hashtable-from-newsrc-alist))) |
| 864 | |
| 865 | ;;;###autoload |
| 866 | (defun gnus-sync-initialize () |
| 867 | "Initialize the Gnus sync facility." |
| 868 | (interactive) |
| 869 | (gnus-message 5 "Initializing the sync facility") |
| 870 | (gnus-sync-install-hooks)) |
| 871 | |
| 872 | ;;;###autoload |
| 873 | (defun gnus-sync-install-hooks () |
| 874 | "Install the sync hooks." |
| 875 | (interactive) |
| 876 | ;; (add-hook 'gnus-get-new-news-hook 'gnus-sync-read) |
| 877 | ;; (add-hook 'gnus-read-newsrc-el-hook 'gnus-sync-read) |
| 878 | (add-hook 'gnus-save-newsrc-hook 'gnus-sync-save)) |
| 879 | |
| 880 | (defun gnus-sync-unload-hook () |
| 881 | "Uninstall the sync hooks." |
| 882 | (interactive) |
| 883 | (remove-hook 'gnus-save-newsrc-hook 'gnus-sync-save)) |
| 884 | |
| 885 | (add-hook 'gnus-sync-unload-hook 'gnus-sync-unload-hook) |
| 886 | |
| 887 | (when gnus-sync-backend (gnus-sync-initialize)) |
| 888 | |
| 889 | (provide 'gnus-sync) |
| 890 | |
| 891 | ;;; gnus-sync.el ends here |