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