cgit.sxemacs.org Git - gnus/blob - lisp/gnus-sync.el

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