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
 223 (defun gnus-sync-lesync-setup (url &optional user password salt reader admin)
 224   (interactive "sEnter URL to set up: ")
 225   "Set up the LeSync database at URL.
 226 Install USER as a READER and/or an ADMIN in the security object
 227 under \"_security\", and in the CouchDB \"_users\" table using
 228 PASSWORD and SALT.  Only one USER is thus supported for now.
 229 When SALT is nil, a random one will be generated using `random'."
 230   (let* ((design-url (concat url gnus-sync-lesync-design-prefix))
 231          (security-object (concat url "/_security"))
 232          (user-record `((names . [,user]) (roles . [])))
 233          (couch-user-name (format "org.couchdb.user:%s" user))
 234          (salt (or salt (sha1 (random t))))
 235          (couch-user-record `((_id . ,couch-user-name)
 236                               (type . user)
 237                               (name . ,(format "%s" user))
 238                               (roles . [])
 239                               (password_sha . ,(sha1
 240                                                 (format "%s%s" password salt)))
 241                               (salt . ,(format "%s" salt))))
 242          (rev (progn
 243                 (gnus-sync-lesync-find-prop 'rev design-url design-url)
 244                 (gnus-sync-lesync-get-prop 'rev design-url)))
 245          (latest-func "function(head,req)
 246 {
 247   var tosend = [];
 248   var row;
 249   var ftime = (req.query['ftime'] || 0);
 250   while (row = getRow())
 251   {
 252     if (row.value['float-time'] > ftime)
 253     {
 254       var s = row.value['_id'];
 255       if (s) tosend.push('\"'+s.replace('\"', '\\\"')+'\"');
 256     }
 257   }
 258   send('['+tosend.join(',') + ']');
 259 }")
 260          (subs-func "function(doc){emit([doc._id, doc.source], doc._rev);}")
 261          (revs-func "function(doc){emit(doc._id, doc._rev);}")
 262          (bytimesubs-func "function(doc)
 263 {emit([(doc['float-time']||0), doc._id], doc._rev);}")
 264          (bytime-func "function(doc)
 265 {emit([(doc['float-time']||0), doc._id], doc);}")
 266          (groups-func "function(doc){emit(doc._id, doc);}"))
 267     (and (if user
 268              (and (assq 'ok (gnus-sync-lesync-PUT
 269                              security-object
 270                              nil
 271                              (append (and reader
 272                                           (list `(readers . ,user-record)))
 273                                      (and admin
 274                                           (list `(admins . ,user-record))))))
 275                   (assq 'ok (gnus-sync-lesync-PUT
 276                              (concat (file-name-directory url)
 277                                      "_users/"
 278                                      couch-user-name)
 279                              nil
 280                              couch-user-record)))
 281            t)
 282          (assq 'ok (gnus-sync-lesync-PUT
 283                     design-url
 284                     nil
 285                     `(,@(when rev (list (cons '_rev rev)))
 286                       (lists . ((latest . ,latest-func)))
 287                       (views . ((subs . ((map . ,subs-func)))
 288                                 (revs . ((map . ,revs-func)))
 289                                 (bytimesubs . ((map . ,bytimesubs-func)))
 290                                 (bytime . ((map . ,bytime-func)))
 291                                 (groups . ((map . ,groups-func)))))))))))
 292
 293 (defun gnus-sync-lesync-find-prop (prop url key)
 294   "Retrieve a PROPerty of a document KEY at URL.
 295 Calls `gnus-sync-lesync-set-prop'.
 296 For the 'rev PROP, uses '_rev against the document."
 297   (gnus-sync-lesync-set-prop
 298    prop key (cdr (assq (if (eq prop 'rev) '_rev prop)
 299                        (gnus-sync-lesync-GET url nil)))))
 300
 301 (defun gnus-sync-lesync-set-prop (prop key val)
 302   "Update the PROPerty of document KEY at URL to VAL.
 303 Updates `gnus-sync-lesync-props-hash'."
 304     (puthash (format "%s.%s" key prop) val gnus-sync-lesync-props-hash))
 305
 306 (defun gnus-sync-lesync-get-prop (prop key)
 307   "Get the PROPerty of KEY from `gnus-sync-lesync-props-hash'."
 308     (gethash (format "%s.%s" key prop) gnus-sync-lesync-props-hash))
 309
 310 (defun gnus-sync-deep-print (data)
 311   (let* ((print-quoted t)
 312          (print-readably t)
 313          (print-escape-multibyte nil)
 314          (print-escape-nonascii t)
 315          (print-length nil)
 316          (print-level nil)
 317          (print-circle nil)
 318          (print-escape-newlines t))
 319     (format "%S" data)))
 320
 321 (defun gnus-sync-newsrc-loader-builder (&optional only-modified)
 322   (let* ((entries (cdr gnus-newsrc-alist))
 323          entry name ret)
 324     (while entries
 325       (setq entry (pop entries)
 326             name (car entry))
 327       (when (gnus-grep-in-list name gnus-sync-newsrc-groups)
 328         (if only-modified
 329             (when (not (equal (gnus-sync-deep-print entry)
 330                               (gnus-sync-lesync-get-prop 'checksum name)))
 331               (gnus-message 9 "%s: add %s, it's modified"
 332                             "gnus-sync-newsrc-loader-builder" name)
 333               (push entry ret))
 334           (push entry ret))))
 335     ret))
 336
 337 ; (json-encode (gnus-sync-range2invlist '((1 . 47137) (47139 . 47714) 48129 48211 49231 49281 49342 49473 49475 49502)))
 338 (defun gnus-sync-range2invlist (ranges)
 339   (append '(invlist)
 340           (let ((ranges (delq nil ranges))
 341                 ret range from to)
 342             (while ranges
 343               (setq range (pop ranges))
 344               (if (atom range)
 345                   (setq from range
 346                         to range)
 347                 (setq from (car range)
 348                       to (cdr range)))
 349               (push from ret)
 350               (push (1+ to) ret))
 351             (reverse ret))))
 352
 353 ; (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))
 354 (defun gnus-sync-invlist2range (inv)
 355   (setq inv (append inv nil))
 356   (if (equal (format "%s" (car inv)) "invlist")
 357       (let ((i (cdr inv))
 358             (start 0)
 359             ret cur top flip)
 360         (while i
 361           (setq cur (pop i))
 362           (when flip
 363             (setq top (1- cur))
 364             (if (= start top)
 365                 (push start ret)
 366               (push (cons start top) ret)))
 367           (setq flip (not flip))
 368           (setq start cur))
 369         (reverse ret))
 370     inv))
 371
 372 (defun gnus-sync-position (search list &optional test)
 373   "Find the position of SEARCH in LIST using TEST, defaulting to `eq'."
 374   (let ((pos 0)
 375         (test (or test 'eq)))
 376     (while (and list (not (funcall test (car list) search)))
 377       (pop list)
 378       (incf pos))
 379     (if (funcall test (car list) search) pos nil)))
 380
 381 (defun gnus-sync-topic-group-position (group topic-name)
 382   (gnus-sync-position
 383    group (cdr (assoc topic-name gnus-topic-alist)) 'equal))
 384
 385 (defun gnus-sync-fix-topic-group-position (group topic-name position)
 386   (unless (equal position (gnus-sync-topic-group-position group topic-name))
 387     (let* ((loc "gnus-sync-fix-topic-group-position")
 388            (groups (delete group (cdr (assoc topic-name gnus-topic-alist))))
 389            (position (min position (1- (length groups))))
 390            (old (nth position groups)))
 391       (when (and old (not (equal old group)))
 392         (setf (nth position groups) group)
 393         (setcdr (assoc topic-name gnus-topic-alist)
 394                 (append groups (list old)))
 395         (gnus-message 9 "%s: %s moved to %d, swap with %s"
 396                       loc group position old)))))
 397
 398 (defun gnus-sync-lesync-pre-save-group-entry (url nentry &rest passed-props)
 399   (let* ((loc "gnus-sync-lesync-save-group-entry")
 400          (k (car nentry))
 401          (revision (gnus-sync-lesync-get-prop 'rev k))
 402          (sname gnus-sync-lesync-name)
 403          (topic (gnus-group-topic k))
 404          (topic-offset (gnus-sync-topic-group-position k topic))
 405          (sources (gnus-sync-lesync-get-prop 'source k)))
 406     ;; set the revision so we don't have a conflict
 407     `(,@(when revision
 408           (list (cons '_rev revision)))
 409       (_id . ,k)
 410       ;; the time we saved
 411       ,@passed-props
 412       ;; add our name to the sources list for this key
 413       (source ,@(if (member gnus-sync-lesync-name sources)
 414                     sources
 415                   (cons gnus-sync-lesync-name sources)))
 416       ,(cons 'level (nth 1 nentry))
 417       ,@(if topic (list (cons 'topic topic)) nil)
 418       ,@(if topic-offset (list (cons 'topic-offset topic-offset)) nil)
 419       ;; the read marks
 420       ,(cons 'read (gnus-sync-range2invlist (nth 2 nentry)))
 421       ;; the other marks
 422       ,@(mapcar (lambda (mark-entry)
 423                   (cons (car mark-entry)
 424                         (gnus-sync-range2invlist (cdr mark-entry))))
 425                 (nth 3 nentry)))))
 426
 427 (defun gnus-sync-lesync-post-save-group-entry (url entry)
 428   (let* ((loc "gnus-sync-lesync-post-save-group-entry")
 429          (k (cdr (assq 'id entry))))
 430     (cond
 431      ;; success!
 432      ((and (assq 'rev entry) (assq 'id entry))
 433       (progn
 434         (gnus-sync-lesync-set-prop 'rev k (cdr (assq 'rev entry)))
 435         (gnus-sync-lesync-set-prop 'checksum
 436                                    k
 437                                    (gnus-sync-deep-print
 438                                     (assoc k gnus-newsrc-alist)))
 439         (gnus-message 9 "%s: successfully synced %s to %s"
 440                       loc k url)))
 441      ;; specifically check for document conflicts
 442      ((equal "conflict" (format "%s" (cdr-safe (assq 'error entry))))
 443       (gnus-error
 444        1
 445        "%s: use `%s' to resolve the conflict synchronizing %s to %s: %s"
 446        loc "gnus-sync-read" k url (cdr (assq 'reason entry))))
 447      ;; generic errors
 448      ((assq 'error entry)
 449       (gnus-error 1 "%s: got error while synchronizing %s to %s: %s"
 450                   loc k url (cdr (assq 'reason entry))))
 451
 452      (t
 453       (gnus-message 2 "%s: unknown sync status after %s to %s: %S"
 454                     loc k url entry)))
 455     (assoc 'error entry)))
 456
 457 (defun gnus-sync-lesync-groups-builder (url)
 458   (let ((u (concat url gnus-sync-lesync-design-prefix "/_view/groups")))
 459     (cdr (assq 'rows (gnus-sync-lesync-GET u nil)))))
 460
 461 (defun gnus-sync-subscribe-group (name)
 462   "Subscribe to group NAME.  Returns NAME on success, nil otherwise."
 463   (gnus-subscribe-newsgroup name))
 464
 465 (defun gnus-sync-lesync-read-group-entry (url name entry &rest passed-props)
 466   "Read ENTRY information for NAME.  Returns NAME if successful.
 467 Skips entries whose sources don't contain
 468 `gnus-sync-lesync-name'.  When the alist PASSED-PROPS has a
 469 `subscribe-all' element that evaluates to true, we attempt to
 470 subscribe to unknown groups.  The user is also allowed to delete
 471 unwanted groups via the LeSync URL."
 472   (let* ((loc "gnus-sync-lesync-read-group-entry")
 473          (entry (gnus-sync-lesync-normalize-group-entry entry passed-props))
 474          (subscribe-all (cdr (assq 'subscribe-all passed-props)))
 475          (sources (cdr (assq 'source entry)))
 476          (rev (cdr (assq 'rev entry)))
 477          (in-sources (member gnus-sync-lesync-name sources))
 478          (known (assoc name gnus-newsrc-alist))
 479          cell)
 480     (unless known
 481       (if (and subscribe-all
 482                (y-or-n-p (format "Subscribe to group %s?" name)))
 483           (setq known (gnus-sync-subscribe-group name)
 484                 in-sources t)
 485         ;; else...
 486         (when (y-or-n-p (format "Delete group %s from server?" name))
 487           (if (equal name (gnus-sync-lesync-delete-group url name))
 488               (gnus-message 1 "%s: removed group %s from server %s"
 489                             loc name url)
 490             (gnus-error 1 "%s: could not remove group %s from server %s"
 491                         loc name url)))))
 492     (when known
 493       (unless in-sources
 494         (setq in-sources
 495               (y-or-n-p
 496                (format "Read group %s even though %s is not in sources %S?"
 497                        name gnus-sync-lesync-name (or sources ""))))))
 498     (when rev
 499       (gnus-sync-lesync-set-prop 'rev name rev))
 500
 501     ;; if the source matches AND we have this group
 502     (if (and known in-sources)
 503         (progn
 504           (gnus-message 10 "%s: reading LeSync entry %s, sources %S"
 505                         loc name sources)
 506           (while entry
 507             (setq cell (pop entry))
 508             (let ((k (car cell))
 509                   (val (cdr cell)))
 510               (gnus-sync-lesync-set-prop k name val)))
 511           name)
 512       ;; else...
 513       (unless known
 514         (gnus-message 5 "%s: ignoring entry %s, it wasn't subscribed.  %s"
 515                         loc name "Call `gnus-sync-read' with C-u to force it."))
 516       (unless in-sources
 517         (gnus-message 5 "%s: ignoring entry %s, %s not in sources %S"
 518                       loc name gnus-sync-lesync-name (or sources "")))
 519       nil)))
 520
 521 (defun gnus-sync-lesync-install-group-entry (name)
 522   (let* ((master (assoc name gnus-newsrc-alist))
 523          (old-topic-name (gnus-group-topic name))
 524          (old-topic (assoc old-topic-name gnus-topic-alist))
 525          (target-topic-name (gnus-sync-lesync-get-prop 'topic name))
 526          (target-topic-offset (gnus-sync-lesync-get-prop 'topic-offset name))
 527          (target-topic (assoc target-topic-name gnus-topic-alist))
 528          (loc "gnus-sync-lesync-install-group-entry"))
 529     (if master
 530         (progn
 531           (when (eq 'ask gnus-sync-lesync-install-topics)
 532             (setq gnus-sync-lesync-install-topics
 533                   (y-or-n-p "Install topics from LeSync?")))
 534           (when (and (eq t gnus-sync-lesync-install-topics)
 535                      target-topic-name)
 536             (if (equal old-topic-name target-topic-name)
 537                 (gnus-message 12 "%s: %s is already in topic %s"
 538                               loc name target-topic-name)
 539               ;; see `gnus-topic-move-group'
 540               (when (and old-topic target-topic)
 541                 (setcdr old-topic (gnus-delete-first name (cdr old-topic)))
 542                 (gnus-message 5 "%s: removing %s from topic %s"
 543                               loc name old-topic-name))
 544               (unless target-topic
 545                 (when (y-or-n-p (format "Create missing topic %s?"
 546                                         target-topic-name))
 547                   (gnus-topic-create-topic target-topic-name nil)
 548                   (setq target-topic (assoc target-topic-name
 549                                             gnus-topic-alist))))
 550               (if target-topic
 551                   (prog1
 552                       (nconc target-topic (list name))
 553                     (gnus-message 5 "%s: adding %s to topic %s"
 554                                   loc name (car target-topic))
 555                     (gnus-topic-enter-dribble))
 556                 (gnus-error 2 "%s: LeSync group %s can't go in missing topic %s"
 557                             loc name target-topic-name)))
 558             (when (and target-topic-offset target-topic)
 559               (gnus-sync-fix-topic-group-position
 560                name target-topic-name target-topic-offset)))
 561           ;; install the subscription level
 562           (when (gnus-sync-lesync-get-prop 'level name)
 563             (setf (nth 1 master) (gnus-sync-lesync-get-prop 'level name)))
 564           ;; install the read and other marks
 565           (setf (nth 2 master) (gnus-sync-lesync-get-prop 'read name))
 566           (setf (nth 3 master) (gnus-sync-lesync-get-prop 'marks name))
 567           (gnus-sync-lesync-set-prop 'checksum
 568                                      name
 569                                      (gnus-sync-deep-print master))
 570           nil)
 571       (gnus-error 1 "%s: invalid LeSync group %s" loc name)
 572       'invalid-name)))
 573
 574 ; (gnus-sync-lesync-delete-group (cdr gnus-sync-backend) "nntp+Gmane:gwene.org.slashdot")
 575
 576 (defun gnus-sync-lesync-delete-group (url name)
 577   "Returns NAME if successful deleting it from URL, an error otherwise."
 578   (interactive "sEnter URL to set up: \rsEnter group name: ")
 579   (let* ((u (concat (cadr gnus-sync-backend) "/" (url-hexify-string name)))
 580          (del (gnus-sync-lesync-DELETE
 581                u
 582                `(,@(when (gnus-sync-lesync-get-prop 'rev name)
 583                      (list (cons "If-Match"
 584                                  (gnus-sync-lesync-get-prop 'rev name))))))))
 585     (or (cdr (assq 'id del)) del)))
 586
 587 ;;; (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)))
 588
 589 (defun gnus-sync-lesync-normalize-group-entry (entry &optional passed-props)
 590   (let (ret
 591         marks
 592         cell)
 593     (setq entry (append passed-props entry))
 594     (while (setq cell (pop entry))
 595       (let ((k (car cell))
 596             (val (cdr cell)))
 597         (cond
 598          ((eq k 'read)
 599           (push (cons k (gnus-sync-invlist2range val)) ret))
 600          ;; we already know the name
 601          ((eq k '_id)
 602           nil)
 603          ((eq k '_rev)
 604           (push (cons 'rev val) ret))
 605          ((eq k 'source)
 606           (push (cons 'source (append val nil)) ret))
 607          ((or (eq k 'float-time)
 608               (eq k 'level)
 609               (eq k 'topic)
 610               (eq k 'topic-offset)
 611               (eq k 'read-time))
 612           (push (cons k val) ret))
 613 ;;; "How often have I said to you that when you have eliminated the
 614 ;;; impossible, whatever remains, however improbable, must be the
 615 ;;; truth?" --Sherlock Holmes
 616           ;; everything remaining must be a mark
 617           (t (push (cons k (gnus-sync-invlist2range val)) marks)))))
 618     (cons (cons 'marks marks) ret)))
 619
 620 (defun gnus-sync-save (&optional force)
 621 "Save the Gnus sync data to the backend.
 622 With a prefix, FORCE is set and all groups will be saved."
 623   (interactive "P")
 624   (cond
 625    ((and (listp gnus-sync-backend)
 626          (eq (nth 0 gnus-sync-backend) 'lesync)
 627          (stringp (nth 1 gnus-sync-backend)))
 628
 629     ;; refresh the revisions if we're forcing the save
 630     (when force
 631       (mapc (lambda (entry)
 632               (when (and (assq 'key entry)
 633                          (assq 'value entry))
 634                 (gnus-sync-lesync-set-prop
 635                  'rev
 636                  (cdr (assq 'key entry))
 637                  (cdr (assq 'value entry)))))
 638             ;; the revs view is key = name, value = rev
 639             (cdr (assq 'rows (gnus-sync-lesync-GET
 640                               (concat (nth 1 gnus-sync-backend)
 641                                       gnus-sync-lesync-design-prefix
 642                                       "/_view/revs")
 643                               nil)))))
 644
 645     (let* ((ftime (float-time))
 646            (url (nth 1 gnus-sync-backend))
 647            (entries
 648             (mapcar (lambda (entry)
 649                       (gnus-sync-lesync-pre-save-group-entry
 650                        (cadr gnus-sync-backend)
 651                        entry
 652                        (cons 'float-time ftime)))
 653                     (gnus-sync-newsrc-loader-builder (not force))))
 654            ;; when there are no entries, there's nothing to save
 655            (sync (if entries
 656                      (gnus-sync-lesync-POST
 657                       (concat url "/_bulk_docs")
 658                       '(("Content-Type" . "application/json"))
 659                       `((docs . ,(vconcat entries nil))))
 660                    (gnus-message
 661                     2 "gnus-sync-save: nothing to save to the LeSync backend")
 662                    nil)))
 663       (mapcar (apply-partially 'gnus-sync-lesync-post-save-group-entry url)
 664               sync)))
 665    ((stringp gnus-sync-backend)
 666     (gnus-message 7 "gnus-sync-save: saving to backend %s" gnus-sync-backend)
 667     ;; populate gnus-sync-newsrc-loader from all but the first dummy
 668     ;; entry in gnus-newsrc-alist whose group matches any of the
 669     ;; gnus-sync-newsrc-groups
 670     ;; TODO: keep the old contents for groups we don't have!
 671     (let ((gnus-sync-newsrc-loader (gnus-sync-newsrc-loader-builder)))
 672       (with-temp-file gnus-sync-backend
 673         (progn
 674           (let ((coding-system-for-write gnus-ding-file-coding-system)
 675                 (standard-output (current-buffer)))
 676             (princ (format ";; -*- mode:emacs-lisp; coding: %s; -*-\n"
 677                            gnus-ding-file-coding-system))
 678             (princ ";; Gnus sync data v. 0.0.1\n")
 679             ;; TODO: replace with `gnus-sync-deep-print'
 680             (let* ((print-quoted t)
 681                    (print-readably t)
 682                    (print-escape-multibyte nil)
 683                    (print-escape-nonascii t)
 684                    (print-length nil)
 685                    (print-level nil)
 686                    (print-circle nil)
 687                    (print-escape-newlines t)
 688                    (variables (cons 'gnus-sync-newsrc-loader
 689                                     gnus-sync-global-vars))
 690                    variable)
 691               (while variables
 692                 (if (and (boundp (setq variable (pop variables)))
 693                            (symbol-value variable))
 694                     (progn
 695                       (princ "\n(setq ")
 696                       (princ (symbol-name variable))
 697                       (princ " '")
 698                       (prin1 (symbol-value variable))
 699                       (princ ")\n"))
 700                   (princ "\n;;; skipping empty variable ")
 701                   (princ (symbol-name variable)))))
 702             (gnus-message
 703              7
 704              "gnus-sync-save: stored variables %s and %d groups in %s"
 705              gnus-sync-global-vars
 706              (length gnus-sync-newsrc-loader)
 707              gnus-sync-backend)
 708
 709             ;; Idea from Dan Christensen <jdc@chow.mat.jhu.edu>
 710             ;; Save the .eld file with extra line breaks.
 711             (gnus-message 8 "gnus-sync-save: adding whitespace to %s"
 712                           gnus-sync-backend)
 713             (save-excursion
 714               (goto-char (point-min))
 715               (while (re-search-forward "^(\\|(\\\"" nil t)
 716                 (replace-match "\n\\&" t))
 717               (goto-char (point-min))
 718               (while (re-search-forward " $" nil t)
 719                 (replace-match "" t t))))))))
 720     ;; the pass-through case: gnus-sync-backend is not a known choice
 721     (nil)))
 722
 723 (defun gnus-sync-read (&optional subscribe-all)
 724   "Load the Gnus sync data from the backend.
 725 With a prefix, SUBSCRIBE-ALL is set and unknown groups will be subscribed."
 726   (interactive "P")
 727   (when gnus-sync-backend
 728     (gnus-message 7 "gnus-sync-read: loading from backend %s" gnus-sync-backend)
 729     (cond
 730      ((and (listp gnus-sync-backend)
 731            (eq (nth 0 gnus-sync-backend) 'lesync)
 732            (stringp (nth 1 gnus-sync-backend)))
 733       (let ((errored nil)
 734             name ftime)
 735         (mapcar (lambda (entry)
 736                   (setq name (cdr (assq 'id entry)))
 737                   ;; set ftime the FIRST time through this loop, that
 738                   ;; way it reflects the time we FINISHED reading
 739                   (unless ftime (setq ftime (float-time)))
 740
 741                   (unless errored
 742                     (setq errored
 743                           (when (equal name
 744                                        (gnus-sync-lesync-read-group-entry
 745                                         (nth 1 gnus-sync-backend)
 746                                         name
 747                                         (cdr (assq 'value entry))
 748                                         `(read-time ,ftime)
 749                                         `(subscribe-all ,subscribe-all)))
 750                             (gnus-sync-lesync-install-group-entry
 751                              (cdr (assq 'id entry)))))))
 752                 (gnus-sync-lesync-groups-builder (nth 1 gnus-sync-backend)))))
 753
 754      ((stringp gnus-sync-backend)
 755       ;; read data here...
 756       (if (or debug-on-error debug-on-quit)
 757           (load gnus-sync-backend nil t)
 758         (condition-case var
 759             (load gnus-sync-backend nil t)
 760           (error
 761            (error "Error in %s: %s" gnus-sync-backend (cadr var)))))
 762       (let ((valid-count 0)
 763             invalid-groups)
 764         (dolist (node gnus-sync-newsrc-loader)
 765           (if (gnus-gethash (car node) gnus-newsrc-hashtb)
 766               (progn
 767                 (incf valid-count)
 768                 (loop for store in (cdr node)
 769                       do (setf (nth (car store)
 770                                     (assoc (car node) gnus-newsrc-alist))
 771                                (cdr store))))
 772             (push (car node) invalid-groups)))
 773         (gnus-message
 774          7
 775          "gnus-sync-read: loaded %d groups (out of %d) from %s"
 776          valid-count (length gnus-sync-newsrc-loader)
 777          gnus-sync-backend)
 778         (when invalid-groups
 779           (gnus-message
 780            7
 781            "gnus-sync-read: skipped %d groups (out of %d) from %s"
 782            (length invalid-groups)
 783            (length gnus-sync-newsrc-loader)
 784            gnus-sync-backend)
 785           (gnus-message 9 "gnus-sync-read: skipped groups: %s"
 786                         (mapconcat 'identity invalid-groups ", ")))))
 787      (nil))
 788
 789     (gnus-message 9 "gnus-sync-read: remaking the newsrc hashtable")
 790     (gnus-make-hashtable-from-newsrc-alist)))
 791
 792 ;;;###autoload
 793 (defun gnus-sync-initialize ()
 794 "Initialize the Gnus sync facility."
 795   (interactive)
 796   (gnus-message 5 "Initializing the sync facility")
 797   (gnus-sync-install-hooks))
 798
 799 ;;;###autoload
 800 (defun gnus-sync-install-hooks ()
 801   "Install the sync hooks."
 802   (interactive)
 803   ;; (add-hook 'gnus-get-new-news-hook 'gnus-sync-read)
 804   ;; (add-hook 'gnus-read-newsrc-el-hook 'gnus-sync-read)
 805   (add-hook 'gnus-save-newsrc-hook 'gnus-sync-save))
 806
 807 (defun gnus-sync-unload-hook ()
 808   "Uninstall the sync hooks."
 809   (interactive)
 810   (remove-hook 'gnus-save-newsrc-hook 'gnus-sync-save))
 811
 812 (add-hook 'gnus-sync-unload-hook 'gnus-sync-unload-hook)
 813
 814 (when gnus-sync-backend (gnus-sync-initialize))
 815
 816 (provide 'gnus-sync)
 817
 818 ;;; gnus-sync.el ends here