mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2025-01-29 19:48:19 +00:00
Bring the Gnus Cloud package into working order.
* lisp/gnus/gnus-sync.el: Removed in favor of gnus-cloud.el. * lisp/gnus/gnus-cloud.el: Autoload EPG functions. Change storage format to simplify non-file data. (gnus-cloud-storage-method): New defcustom to support nil, Base64, Base64+gzip, or EPG encoding on the Gnus Cloud IMAP server. Defaults to EPG if that's available, Base64+gzip otherwise. (gnus-cloud-interactive): New defcustom to make Gnus Cloud operations interactive, defaults to enabled. (gnus-cloud-group-name): New variable for the Gnus Cloud group name. (gnus-cloud-make-chunk): Tag with "Gnus-Cloud-Version" instead of just "Version". (gnus-cloud-insert-data): Simplify and support :newsrc-data entries. (gnus-cloud-encode-data, gnus-cloud-decode-data): Support various storage methods as per gnus-cloud-storage-method. (gnus-cloud-parse-chunk): Look for "Gnus-Cloud-Version" marker. (gnus-cloud-parse-version-1): Fix parsing loop bug. Handle :newsrc-data entries. (gnus-cloud-update-all): Handle :newsrc-data entries and dispatch to file and data handlers. (gnus-cloud-update-newsrc-data): New function to handle :newrsc-data entries. (gnus-cloud-update-file): Rework to support gnus-cloud-interactive and be more careful. (gnus-cloud-delete-file): Remove; merged into gnus-cloud-update-file. (gnus-cloud-file-covered-p, gnus-cloud-all-files) (gnus-cloud-files-to-upload, gnus-cloud-ensure-cloud-group) (gnus-cloud-add-timestamps, gnus-cloud-available-chunks) (gnus-cloud-prune-old-chunks): Fix indentation. (gnus-cloud-timestamp): New function to make a standard Gnus Cloud timestamp. (gnus-cloud-file-new-p): Use it. (gnus-cloud-upload-all-data): Add interactive convenience function to upload all data. (gnus-cloud-upload-data): Make interactive; collect files and newsrc data separately; refresh Gnus Cloud group after insert. (gnus-cloud-download-all-data): Add interactive convenience function to download all data. (gnus-cloud-download-data): Rework to support "Gnus-Cloud-Version" marker and different storage methods. (gnus-cloud-host-server-p): New function to check if a server is the Gnus Cloud host. (gnus-cloud-collect-full-newsrc): Tag entries with :newsrc-data. (gnus-cloud-host-acceptable-method-p): New function so other code can check if a server method can host the Gnus cloud. (gnus-cloud-storage-method): Use 'radio instead of 'choice for better UI. (gnus-cloud-method): Make this a defcustom and note how to set it. * lisp/gnus/gnus-group.el (gnus-group-cloud-map): Add Gnus Cloud autoloaded keybindings under the `~' prefix. * lisp/gnus/gnus-srvr.el (gnus-server-mode-map, gnus-server-make-menu-bar) (gnus-server-cloud, gnus-server-cloud-host) (gnus-server-font-lock-keywords, gnus-server-insert-server-line) (gnus-server-toggle-cloud-method-server): Support Gnus Cloud synchronized servers and synchronization host server toggling (`i' and `I') and visual display. (gnus-server-toggle-cloud-method-server): Use gnus-cloud-host-acceptable-method-p. (gnus-server-toggle-cloud-method-server): Use custom-set-variables to set the gnus-cloud-method. Ask the user if it's OK to upload the data right now. * doc/misc/gnus.texi: Document Gnus Cloud package.
This commit is contained in:
Ted Zlatanov
parent
60dd094a8c
commit
30b3a842ec
@ -828,6 +828,7 @@ Various
|
||||
* Thwarting Email Spam:: Simple ways to avoid unsolicited commercial email.
|
||||
* Spam Package:: A package for filtering and processing spam.
|
||||
* The Gnus Registry:: A package for tracking messages by Message-ID.
|
||||
* The Gnus Cloud:: A package for synchronizing Gnus marks.
|
||||
* Other modes:: Interaction with other modes.
|
||||
* Various Various:: Things that are really various.
|
||||
|
||||
@ -22208,6 +22209,7 @@ to you, using @kbd{G b u} and updating the group will usually fix this.
|
||||
* Thwarting Email Spam:: Simple ways to avoid unsolicited commercial email.
|
||||
* Spam Package:: A package for filtering and processing spam.
|
||||
* The Gnus Registry:: A package for tracking messages by Message-ID.
|
||||
* The Gnus Cloud:: A package for synchronizing Gnus marks.
|
||||
* Other modes:: Interaction with other modes.
|
||||
* Various Various:: Things that are really various.
|
||||
@end menu
|
||||
@ -26166,6 +26168,100 @@ default this is just @code{(marks)} so the custom registry marks are
|
||||
precious.
|
||||
@end defvar
|
||||
|
||||
@node The Gnus Cloud
|
||||
@section The Gnus Cloud
|
||||
@cindex cloud
|
||||
@cindex gnus-cloud
|
||||
@cindex synchronization
|
||||
@cindex sync
|
||||
@cindex synch
|
||||
|
||||
The Gnus Cloud is a way to synchronize marks and general files and
|
||||
data across multiple machines.
|
||||
|
||||
Very often, you want all your marks (what articles you've read, which
|
||||
ones were important, and so on) to be synchronized between several
|
||||
machines. With IMAP, that's built into the protocol, so you can read
|
||||
nnimap groups from many machines and they are automatically
|
||||
synchronized. But NNTP, nnrss, and many other backends do not store
|
||||
marks, so you have to do it locally.
|
||||
|
||||
The Gnus Cloud package stores the marks, plus any files you choose, on
|
||||
an IMAP server in a special folder. It's like a
|
||||
DropTorrentSyncBoxOakTree(TM).
|
||||
|
||||
@menu
|
||||
* Gnus Cloud Setup::
|
||||
* Gnus Cloud Usage::
|
||||
@end menu
|
||||
|
||||
@node Gnus Cloud Setup
|
||||
@subsection Gnus Cloud Setup
|
||||
|
||||
Setting up the Gnus Cloud takes less than a minute. From the Group
|
||||
buffer:
|
||||
|
||||
Press @kbd{^} to go to the Server buffer. Here you'll see all the
|
||||
servers that Gnus knows. @xref{Server Buffer}.
|
||||
|
||||
Then press @kbd{i} to mark any servers as cloud-synchronized (their marks are synchronized).
|
||||
|
||||
Then press @kbd{I} to mark a single server as the cloud host (it must
|
||||
be an IMAP server, and will host a special IMAP folder with all the
|
||||
synchronization data). This will set the variable
|
||||
@code{gnus-cloud-method} (using the Customize facilities), then ask
|
||||
you to optionally upload your first CloudSynchronizationDataPack(TM).
|
||||
|
||||
@node Gnus Cloud Usage
|
||||
@subsection Gnus Cloud Usage
|
||||
|
||||
After setting up, you can use these shortcuts from the Group buffer:
|
||||
|
||||
@table @kbd
|
||||
@item ~ RET
|
||||
@item ~ d
|
||||
@findex gnus-cloud-download-all-data
|
||||
@cindex cloud, download
|
||||
Download the latest Gnus Cloud data.
|
||||
|
||||
@item ~ u
|
||||
@item ~ ~
|
||||
@findex gnus-cloud-upload-all-data
|
||||
@cindex cloud, download
|
||||
Upload the local Gnus Cloud data. Creates a new
|
||||
CloudSynchronizationDataPack(TM).
|
||||
|
||||
@end table
|
||||
|
||||
But wait, there's more. Of course there's more. So much more. You can
|
||||
customize all of the following.
|
||||
|
||||
@defvar gnus-cloud-synced-files
|
||||
These are the files that will be part of every
|
||||
CloudSynchronizationDataPack(TM). They are included in every upload,
|
||||
so don't synchronize a lot of large files. Files under 100Kb are best.
|
||||
@end defvar
|
||||
|
||||
@defvar gnus-cloud-storage-method
|
||||
This is a choice from several storage methods. It's highly recommended
|
||||
to use the EPG facilities. It will be automatic if have GnuPG
|
||||
installed and EPG loaded. Otherwise, you could use Base64+gzip,
|
||||
Base64, or no encoding.
|
||||
@end defvar
|
||||
|
||||
@defvar gnus-cloud-interactive
|
||||
When this is set, and by default it is, the Gnus Cloud package will
|
||||
ask you for confirmation here and there. Leave it on until you're
|
||||
comfortable with the package.
|
||||
@end defvar
|
||||
|
||||
|
||||
@defvar gnus-cloud-method
|
||||
The name of the IMAP server to store the
|
||||
CloudSynchronizationDataPack(TM)s. It's easiest to set this from the
|
||||
Server buffer (@pxref{Gnus Cloud Setup}).
|
||||
@end defvar
|
||||
|
||||
@node Other modes
|
||||
@section Interaction with other modes
|
||||
|
||||
|
||||
@ -28,6 +28,12 @@
|
||||
(require 'parse-time)
|
||||
(require 'nnimap)
|
||||
|
||||
(eval-when-compile (require 'epg)) ;; setf-method for `epg-context-armor'
|
||||
(autoload 'epg-make-context "epg")
|
||||
(autoload 'epg-context-set-passphrase-callback "epg")
|
||||
(autoload 'epg-decrypt-string "epg")
|
||||
(autoload 'epg-encrypt-string "epg")
|
||||
|
||||
(defgroup gnus-cloud nil
|
||||
"Syncing Gnus data via IMAP."
|
||||
:version "25.1"
|
||||
@ -43,18 +49,36 @@
|
||||
;; FIXME this type does not match the default. Nor does the documentation.
|
||||
:type '(repeat regexp))
|
||||
|
||||
(defvar gnus-cloud-group-name "*Emacs Cloud*")
|
||||
(defcustom gnus-cloud-storage-method (if (featurep 'epg) 'epg 'base64-gzip)
|
||||
"Storage method for cloud data, defaults to EPG if that's available."
|
||||
:group 'gnus-cloud
|
||||
:type '(radio (const :tag "No encoding" nil)
|
||||
(const :tag "Base64" base64)
|
||||
(const :tag "Base64+gzip" base64-gzip)
|
||||
(const :tag "EPG" epg)))
|
||||
|
||||
(defcustom gnus-cloud-interactive t
|
||||
"Whether Gnus Cloud changes should be confirmed."
|
||||
:group 'gnus-cloud
|
||||
:type 'boolean)
|
||||
|
||||
(defvar gnus-cloud-group-name "Emacs-Cloud")
|
||||
(defvar gnus-cloud-covered-servers nil)
|
||||
|
||||
(defvar gnus-cloud-version 1)
|
||||
(defvar gnus-cloud-sequence 1)
|
||||
|
||||
(defvar gnus-cloud-method nil
|
||||
"The IMAP select method used to store the cloud data.")
|
||||
(defcustom gnus-cloud-method nil
|
||||
"The IMAP select method used to store the cloud data.
|
||||
See also `gnus-server-toggle-cloud-method-server' for an
|
||||
easy interactive way to set this from the Server buffer."
|
||||
:group 'gnus-cloud
|
||||
:type '(radio (const :tag "Not set" nil)
|
||||
(string :tag "A Gnus server name as a string")))
|
||||
|
||||
(defun gnus-cloud-make-chunk (elems)
|
||||
(with-temp-buffer
|
||||
(insert (format "Version %s\n" gnus-cloud-version))
|
||||
(insert (format "Gnus-Cloud-Version %s\n" gnus-cloud-version))
|
||||
(insert (gnus-cloud-insert-data elems))
|
||||
(buffer-string)))
|
||||
|
||||
@ -63,106 +87,187 @@
|
||||
(dolist (elem elems)
|
||||
(cond
|
||||
((eq (plist-get elem :type) :file)
|
||||
(let (length data)
|
||||
(mm-with-unibyte-buffer
|
||||
(insert-file-contents-literally (plist-get elem :file-name))
|
||||
(setq length (buffer-size)
|
||||
data (buffer-string)))
|
||||
(insert (format "(:type :file :file-name %S :timestamp %S :length %d)\n"
|
||||
(plist-get elem :file-name)
|
||||
(plist-get elem :timestamp)
|
||||
length))
|
||||
(insert data)
|
||||
(insert "\n")))
|
||||
((eq (plist-get elem :type) :data)
|
||||
(insert (format "(:type :data :name %S :length %d)\n"
|
||||
(plist-get elem :name)
|
||||
(with-current-buffer (plist-get elem :buffer)
|
||||
(buffer-size))))
|
||||
(insert-buffer-substring (plist-get elem :buffer))
|
||||
(insert "\n"))
|
||||
(let (length data)
|
||||
(mm-with-unibyte-buffer
|
||||
(insert-file-contents-literally (plist-get elem :file-name))
|
||||
(setq length (buffer-size)
|
||||
data (buffer-string)))
|
||||
(insert (format "(:type :file :file-name %S :timestamp %S :length %d)\n"
|
||||
(plist-get elem :file-name)
|
||||
(plist-get elem :timestamp)
|
||||
length))
|
||||
(insert data)
|
||||
(insert "\n")))
|
||||
((eq (plist-get elem :type) :newsrc-data)
|
||||
(let ((print-level nil)
|
||||
(print-length nil))
|
||||
(print elem (current-buffer)))
|
||||
(insert "\n"))
|
||||
((eq (plist-get elem :type) :delete)
|
||||
(insert (format "(:type :delete :file-name %S)\n"
|
||||
(plist-get elem :file-name))))))
|
||||
(insert (format "(:type :delete :file-name %S)\n"
|
||||
(plist-get elem :file-name))))))
|
||||
(gnus-cloud-encode-data)
|
||||
(buffer-string)))
|
||||
|
||||
(defun gnus-cloud-encode-data ()
|
||||
(call-process-region (point-min) (point-max) "gzip"
|
||||
t (current-buffer) nil
|
||||
"-c")
|
||||
(base64-encode-region (point-min) (point-max)))
|
||||
(cond
|
||||
((eq gnus-cloud-storage-method 'base64-gzip)
|
||||
(call-process-region (point-min) (point-max) "gzip"
|
||||
t (current-buffer) nil
|
||||
"-c"))
|
||||
|
||||
((memq gnus-cloud-storage-method '(base64 base64-gzip))
|
||||
(base64-encode-region (point-min) (point-max)))
|
||||
|
||||
((eq gnus-cloud-storage-method 'epg)
|
||||
(let ((context (epg-make-context 'OpenPGP))
|
||||
cipher)
|
||||
(setf (epg-context-armor context) t)
|
||||
(setf (epg-context-textmode context) t)
|
||||
(let ((data (epg-encrypt-string context
|
||||
(buffer-substring-no-properties
|
||||
(point-min)
|
||||
(point-max))
|
||||
nil)))
|
||||
(delete-region (point-min) (point-max))
|
||||
(insert data))))
|
||||
|
||||
((null gnus-cloud-storage-method)
|
||||
(gnus-message 5 "Leaving cloud data plaintext"))
|
||||
(t (gnus-error 1 "Invalid cloud storage method %S"
|
||||
gnus-cloud-storage-method))))
|
||||
|
||||
(defun gnus-cloud-decode-data ()
|
||||
(base64-decode-region (point-min) (point-max))
|
||||
(call-process-region (point-min) (point-max) "gunzip"
|
||||
t (current-buffer) nil
|
||||
"-c"))
|
||||
(cond
|
||||
((memq gnus-cloud-storage-method '(base64 base64-gzip))
|
||||
(base64-decode-region (point-min) (point-max)))
|
||||
|
||||
((eq gnus-cloud-storage-method 'base64-gzip)
|
||||
(call-process-region (point-min) (point-max) "gunzip"
|
||||
t (current-buffer) nil
|
||||
"-c"))
|
||||
|
||||
((eq gnus-cloud-storage-method 'epg)
|
||||
(let* ((context (epg-make-context 'OpenPGP))
|
||||
(data (epg-decrypt-string context (buffer-substring-no-properties
|
||||
(point-min)
|
||||
(point-max)))))
|
||||
(delete-region (point-min) (point-max))
|
||||
(insert data)))
|
||||
|
||||
((null gnus-cloud-storage-method)
|
||||
(gnus-message 5 "Reading cloud data as plaintext"))
|
||||
|
||||
(t (gnus-error 1 "Invalid cloud storage method %S"
|
||||
gnus-cloud-storage-method))))
|
||||
|
||||
(defun gnus-cloud-parse-chunk ()
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(unless (looking-at "Version \\([0-9]+\\)")
|
||||
(unless (looking-at "Gnus-Cloud-Version \\([0-9]+\\)")
|
||||
(error "Not a valid Cloud chunk in the current buffer"))
|
||||
(forward-line 1)
|
||||
(let ((version (string-to-number (match-string 1)))
|
||||
(data (buffer-substring (point) (point-max))))
|
||||
(data (buffer-substring (point) (point-max))))
|
||||
(mm-with-unibyte-buffer
|
||||
(insert data)
|
||||
(cond
|
||||
((= version 1)
|
||||
(gnus-cloud-decode-data)
|
||||
(goto-char (point-min))
|
||||
(gnus-cloud-parse-version-1))
|
||||
(t
|
||||
(error "Unsupported Cloud chunk version %s" version)))))))
|
||||
(insert data)
|
||||
(cond
|
||||
((= version 1)
|
||||
(gnus-cloud-decode-data)
|
||||
(goto-char (point-min))
|
||||
(gnus-cloud-parse-version-1))
|
||||
(t
|
||||
(error "Unsupported Cloud chunk version %s" version)))))))
|
||||
|
||||
(defun gnus-cloud-parse-version-1 ()
|
||||
(let ((elems nil))
|
||||
(while (not (eobp))
|
||||
(while (and (not (eobp))
|
||||
(not (looking-at "(:type")))
|
||||
(forward-line 1))
|
||||
(not (looking-at "(:type")))
|
||||
(forward-line 1))
|
||||
(unless (eobp)
|
||||
(let ((spec (ignore-errors (read (current-buffer))))
|
||||
length)
|
||||
(when (and (consp spec)
|
||||
(memq (plist-get spec :type) '(:file :data :delete)))
|
||||
(setq length (plist-get spec :length))
|
||||
(push (append spec
|
||||
(list
|
||||
:contents (buffer-substring (1+ (point))
|
||||
(+ (point) 1 length))))
|
||||
elems)
|
||||
(goto-char (+ (point) 1 length))))))
|
||||
(let ((spec (ignore-errors (read (current-buffer))))
|
||||
length)
|
||||
(when (consp spec)
|
||||
(cond
|
||||
((memq (plist-get spec :type) '(:file :delete))
|
||||
(setq length (plist-get spec :length))
|
||||
(push (append spec
|
||||
(list
|
||||
:contents (buffer-substring (1+ (point))
|
||||
(+ (point) 1 length))))
|
||||
elems)
|
||||
(goto-char (+ (point) 1 length)))
|
||||
((memq (plist-get spec :type) '(:newsrc-data))
|
||||
(push spec elems)))))))
|
||||
(nreverse elems)))
|
||||
|
||||
(defun gnus-cloud-update-data (elems)
|
||||
(defun gnus-cloud-update-all (elems)
|
||||
(dolist (elem elems)
|
||||
(let ((type (plist-get elem :type)))
|
||||
(cond
|
||||
((eq type :data)
|
||||
)
|
||||
((eq type :delete)
|
||||
(gnus-cloud-delete-file (plist-get elem :file-name))
|
||||
)
|
||||
((eq type :file)
|
||||
(gnus-cloud-update-file elem))
|
||||
((eq type :newsrc-data)
|
||||
(gnus-cloud-update-newsrc-data (plist-get elem :name) elem))
|
||||
((memq type '(:delete :file))
|
||||
(gnus-cloud-update-file elem type))
|
||||
(t
|
||||
(message "Unknown type %s; ignoring" type))))))
|
||||
(gnus-message 1 "Unknown type %s; ignoring" type))))))
|
||||
|
||||
(defun gnus-cloud-update-file (elem)
|
||||
(let ((file-name (plist-get elem :file-name))
|
||||
(date (plist-get elem :timestamp))
|
||||
(contents (plist-get elem :contents)))
|
||||
(unless (gnus-cloud-file-covered-p file-name)
|
||||
(message "%s isn't covered by the cloud; ignoring" file-name))
|
||||
(when (or (not (file-exists-p file-name))
|
||||
(and (file-exists-p file-name)
|
||||
(mm-with-unibyte-buffer
|
||||
(insert-file-contents-literally file-name)
|
||||
(not (equal (buffer-string) contents)))))
|
||||
(gnus-cloud-replace-file file-name date contents))))
|
||||
(defun gnus-cloud-update-newsrc-data (group elem &optional force-older)
|
||||
"Update the newsrc data for GROUP from ELEM.
|
||||
Use old data if FORCE-OLDER is not nil."
|
||||
(let* ((contents (plist-get elem :contents))
|
||||
(date (or (plist-get elem :timestamp) "0"))
|
||||
(now (gnus-cloud-timestamp (current-time)))
|
||||
(newer (string-lessp date now))
|
||||
(group-info (gnus-get-info group)))
|
||||
(if (and contents
|
||||
(stringp (nth 0 contents))
|
||||
(integerp (nth 1 contents)))
|
||||
(if group-info
|
||||
(if (equal (format "%S" group-info)
|
||||
(format "%S" contents))
|
||||
(gnus-message 3 "Skipping cloud update of group %s, the info is the same" group)
|
||||
(if (and newer (not force-older))
|
||||
(gnus-message 3 "Skipping outdated cloud info for group %s, the info is from %s (now is %s)" group date now)
|
||||
(when (or (not gnus-cloud-interactive)
|
||||
(gnus-y-or-n-p
|
||||
(format "%s has older different info in the cloud as of %s, update it here? "
|
||||
group date))))
|
||||
(gnus-message 2 "Installing cloud update of group %s" group)
|
||||
(gnus-set-info group contents)
|
||||
(gnus-group-update-group group)))
|
||||
(gnus-error 1 "Sorry, group %s is not subscribed" group))
|
||||
(gnus-error 1 "Sorry, could not update newsrc for group %s (invalid data %S)"
|
||||
group elem))))
|
||||
|
||||
(defun gnus-cloud-update-file (elem op)
|
||||
"Apply Gnus Cloud data ELEM and operation OP to a file."
|
||||
(let* ((file-name (plist-get elem :file-name))
|
||||
(date (plist-get elem :timestamp))
|
||||
(contents (plist-get elem :contents))
|
||||
(exists (file-exists-p file-name)))
|
||||
(if (gnus-cloud-file-covered-p file-name)
|
||||
(cond
|
||||
((eq op :delete)
|
||||
(if (and exists
|
||||
;; prompt only if the file exists already
|
||||
(or (not gnus-cloud-interactive)
|
||||
(gnus-y-or-n-p (format "%s has been deleted as of %s, delete it locally? "
|
||||
file-name date))))
|
||||
(rename-file file-name (car (find-backup-file-name file-name)))
|
||||
(gnus-message 3 "%s was already deleted before the cloud got it" file-name)))
|
||||
((eq op :file)
|
||||
(when (or (not exists)
|
||||
(and exists
|
||||
(mm-with-unibyte-buffer
|
||||
(insert-file-contents-literally file-name)
|
||||
(not (equal (buffer-string) contents)))
|
||||
;; prompt only if the file exists already
|
||||
(or (not gnus-cloud-interactive)
|
||||
(gnus-y-or-n-p (format "%s has updated contents as of %s, update it? "
|
||||
file-name date)))))
|
||||
(gnus-cloud-replace-file file-name date contents))))
|
||||
(gnus-message 2 "%s isn't covered by the cloud; ignoring" file-name))))
|
||||
|
||||
(defun gnus-cloud-replace-file (file-name date new-contents)
|
||||
(mm-with-unibyte-buffer
|
||||
@ -172,25 +277,19 @@
|
||||
(write-region (point-min) (point-max) file-name)
|
||||
(set-file-times file-name (parse-iso8601-time-string date))))
|
||||
|
||||
(defun gnus-cloud-delete-file (file-name)
|
||||
(unless (gnus-cloud-file-covered-p file-name)
|
||||
(message "%s isn't covered by the cloud; ignoring" file-name))
|
||||
(when (file-exists-p file-name)
|
||||
(rename-file file-name (car (find-backup-file-name file-name)))))
|
||||
|
||||
(defun gnus-cloud-file-covered-p (file-name)
|
||||
(let ((matched nil))
|
||||
(dolist (elem gnus-cloud-synced-files)
|
||||
(cond
|
||||
((stringp elem)
|
||||
(when (equal elem file-name)
|
||||
(setq matched t)))
|
||||
(when (equal elem file-name)
|
||||
(setq matched t)))
|
||||
((consp elem)
|
||||
(when (and (equal (directory-file-name (plist-get elem :directory))
|
||||
(directory-file-name (file-name-directory file-name)))
|
||||
(string-match (plist-get elem :match)
|
||||
(file-name-nondirectory file-name)))
|
||||
(setq matched t)))))
|
||||
(when (and (equal (directory-file-name (plist-get elem :directory))
|
||||
(directory-file-name (file-name-directory file-name)))
|
||||
(string-match (plist-get elem :match)
|
||||
(file-name-nondirectory file-name)))
|
||||
(setq matched t)))))
|
||||
matched))
|
||||
|
||||
(defun gnus-cloud-all-files ()
|
||||
@ -198,106 +297,126 @@
|
||||
(dolist (elem gnus-cloud-synced-files)
|
||||
(cond
|
||||
((stringp elem)
|
||||
(push elem files))
|
||||
(push elem files))
|
||||
((consp elem)
|
||||
(dolist (file (directory-files (plist-get elem :directory)
|
||||
nil
|
||||
(plist-get elem :match)))
|
||||
(push (format "%s/%s"
|
||||
(directory-file-name (plist-get elem :directory))
|
||||
file)
|
||||
files)))))
|
||||
(dolist (file (directory-files (plist-get elem :directory)
|
||||
nil
|
||||
(plist-get elem :match)))
|
||||
(push (format "%s/%s"
|
||||
(directory-file-name (plist-get elem :directory))
|
||||
file)
|
||||
files)))))
|
||||
(nreverse files)))
|
||||
|
||||
(defvar gnus-cloud-file-timestamps nil)
|
||||
|
||||
(defun gnus-cloud-files-to-upload (&optional full)
|
||||
(let ((files nil)
|
||||
timestamp)
|
||||
timestamp)
|
||||
(dolist (file (gnus-cloud-all-files))
|
||||
(if (file-exists-p file)
|
||||
(when (setq timestamp (gnus-cloud-file-new-p file full))
|
||||
(push `(:type :file :file-name ,file :timestamp ,timestamp) files))
|
||||
(when (assoc file gnus-cloud-file-timestamps)
|
||||
(push `(:type :delete :file-name ,file) files))))
|
||||
(when (setq timestamp (gnus-cloud-file-new-p file full))
|
||||
(push `(:type :file :file-name ,file :timestamp ,timestamp) files))
|
||||
(when (assoc file gnus-cloud-file-timestamps)
|
||||
(push `(:type :delete :file-name ,file) files))))
|
||||
(nreverse files)))
|
||||
|
||||
(defun gnus-cloud-timestamp (time)
|
||||
"Return a general timestamp string for TIME."
|
||||
(format-time-string "%FT%T%z" time))
|
||||
|
||||
(defun gnus-cloud-file-new-p (file full)
|
||||
(let ((timestamp (format-time-string
|
||||
"%FT%T%z" (nth 5 (file-attributes file))))
|
||||
(old (cadr (assoc file gnus-cloud-file-timestamps))))
|
||||
(let ((timestamp (gnus-cloud-timestamp (nth 5 (file-attributes file))))
|
||||
(old (cadr (assoc file gnus-cloud-file-timestamps))))
|
||||
(when (or full
|
||||
(null old)
|
||||
(string< old timestamp))
|
||||
(null old)
|
||||
(string< old timestamp))
|
||||
timestamp)))
|
||||
|
||||
(declare-function gnus-activate-group "gnus-start"
|
||||
(group &optional scan dont-check method dont-sub-check))
|
||||
(group &optional scan dont-check method dont-sub-check))
|
||||
(declare-function gnus-subscribe-group "gnus-start"
|
||||
(group &optional previous method))
|
||||
(group &optional previous method))
|
||||
|
||||
(defun gnus-cloud-ensure-cloud-group ()
|
||||
(let ((method (if (stringp gnus-cloud-method)
|
||||
(gnus-server-to-method gnus-cloud-method)
|
||||
gnus-cloud-method)))
|
||||
(gnus-server-to-method gnus-cloud-method)
|
||||
gnus-cloud-method)))
|
||||
(unless (or (gnus-active gnus-cloud-group-name)
|
||||
(gnus-activate-group gnus-cloud-group-name nil nil
|
||||
gnus-cloud-method))
|
||||
(gnus-activate-group gnus-cloud-group-name nil nil
|
||||
gnus-cloud-method))
|
||||
(and (gnus-request-create-group gnus-cloud-group-name gnus-cloud-method)
|
||||
(gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method)
|
||||
(gnus-subscribe-group gnus-cloud-group-name)))))
|
||||
(gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method)
|
||||
(gnus-subscribe-group gnus-cloud-group-name)))))
|
||||
|
||||
(defun gnus-cloud-upload-all-data ()
|
||||
"Upload all data (newsrc and files) to the Gnus Cloud."
|
||||
(interactive)
|
||||
(gnus-cloud-upload-data t))
|
||||
|
||||
(defun gnus-cloud-upload-data (&optional full)
|
||||
"Upload data (newsrc and files) to the Gnus Cloud.
|
||||
When FULL is t, upload everything, not just a difference from the last full."
|
||||
(interactive)
|
||||
(gnus-cloud-ensure-cloud-group)
|
||||
(with-temp-buffer
|
||||
(let ((elems (gnus-cloud-files-to-upload full)))
|
||||
(insert (format "Subject: (sequence: %d type: %s)\n"
|
||||
gnus-cloud-sequence
|
||||
(if full :full :partial)))
|
||||
(insert "From: nobody@invalid.com\n")
|
||||
(let ((elems (append
|
||||
(gnus-cloud-files-to-upload full)
|
||||
(gnus-cloud-collect-full-newsrc)))
|
||||
(group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method)))
|
||||
(insert (format "Subject: (sequence: %s type: %s storage-method: %s)\n"
|
||||
(or gnus-cloud-sequence "UNKNOWN")
|
||||
(if full :full :partial)
|
||||
gnus-cloud-storage-method))
|
||||
(insert "From: nobody@gnus.cloud.invalid\n")
|
||||
(insert "\n")
|
||||
(insert (gnus-cloud-make-chunk elems))
|
||||
(when (gnus-request-accept-article gnus-cloud-group-name gnus-cloud-method
|
||||
t t)
|
||||
(setq gnus-cloud-sequence (1+ gnus-cloud-sequence))
|
||||
(gnus-cloud-add-timestamps elems)))))
|
||||
(if (gnus-request-accept-article gnus-cloud-group-name gnus-cloud-method
|
||||
t t)
|
||||
(progn
|
||||
(setq gnus-cloud-sequence (1+ (or gnus-cloud-sequence 0)))
|
||||
(gnus-cloud-add-timestamps elems)
|
||||
(gnus-message 3 "Uploaded Gnus Cloud data successfully to %s" group)
|
||||
(gnus-group-refresh-group group))
|
||||
(gnus-error 2 "Failed to upload Gnus Cloud data to %s" group)))))
|
||||
|
||||
(defun gnus-cloud-add-timestamps (elems)
|
||||
(dolist (elem elems)
|
||||
(let* ((file-name (plist-get elem :file-name))
|
||||
(old (assoc file-name gnus-cloud-file-timestamps)))
|
||||
(old (assoc file-name gnus-cloud-file-timestamps)))
|
||||
(when old
|
||||
(setq gnus-cloud-file-timestamps
|
||||
(delq old gnus-cloud-file-timestamps)))
|
||||
(setq gnus-cloud-file-timestamps
|
||||
(delq old gnus-cloud-file-timestamps)))
|
||||
(push (list file-name (plist-get elem :timestamp))
|
||||
gnus-cloud-file-timestamps))))
|
||||
gnus-cloud-file-timestamps))))
|
||||
|
||||
(defun gnus-cloud-available-chunks ()
|
||||
(gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method)
|
||||
(let* ((group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method))
|
||||
(active (gnus-active group))
|
||||
headers head)
|
||||
(active (gnus-active group))
|
||||
headers head)
|
||||
(when (gnus-retrieve-headers (gnus-uncompress-range active) group)
|
||||
(with-current-buffer nntp-server-buffer
|
||||
(goto-char (point-min))
|
||||
(while (and (not (eobp))
|
||||
(setq head (nnheader-parse-head)))
|
||||
(push head headers))))
|
||||
(goto-char (point-min))
|
||||
(while (and (not (eobp))
|
||||
(setq head (nnheader-parse-head)))
|
||||
(push head headers))))
|
||||
(sort (nreverse headers)
|
||||
(lambda (h1 h2)
|
||||
(> (gnus-cloud-chunk-sequence (mail-header-subject h1))
|
||||
(gnus-cloud-chunk-sequence (mail-header-subject h2)))))))
|
||||
(lambda (h1 h2)
|
||||
(> (gnus-cloud-chunk-sequence (mail-header-subject h1))
|
||||
(gnus-cloud-chunk-sequence (mail-header-subject h2)))))))
|
||||
|
||||
(defun gnus-cloud-chunk-sequence (string)
|
||||
(if (string-match "sequence: \\([0-9]+\\)" string)
|
||||
(string-to-number (match-string 1 string))
|
||||
0))
|
||||
|
||||
;; TODO: use this
|
||||
(defun gnus-cloud-prune-old-chunks (headers)
|
||||
(let ((headers (reverse headers))
|
||||
(found nil))
|
||||
(found nil))
|
||||
(while (and headers
|
||||
(not found))
|
||||
(not found))
|
||||
(when (string-match "type: :full" (mail-header-subject (car headers)))
|
||||
(setq found t))
|
||||
(pop headers))
|
||||
@ -306,37 +425,68 @@
|
||||
(when headers
|
||||
(gnus-request-expire-articles
|
||||
(mapcar (lambda (h)
|
||||
(mail-header-number h))
|
||||
(nreverse headers))
|
||||
(mail-header-number h))
|
||||
(nreverse headers))
|
||||
(gnus-group-full-name gnus-cloud-group-name gnus-cloud-method)))))
|
||||
|
||||
(defun gnus-cloud-download-data ()
|
||||
(defun gnus-cloud-download-all-data ()
|
||||
"Download the Gnus Cloud data and install it.
|
||||
Starts at `gnus-cloud-sequence' in the sequence."
|
||||
(interactive)
|
||||
(gnus-cloud-download-data t))
|
||||
|
||||
(defun gnus-cloud-download-data (&optional update sequence-override)
|
||||
"Download the Gnus Cloud data and install it if UPDATE is t.
|
||||
When SEQUENCE-OVERRIDE is given, start at that sequence number
|
||||
instead of `gnus-cloud-sequence'.
|
||||
|
||||
When UPDATE is t, returns the result of calling `gnus-cloud-update-all'.
|
||||
Otherwise, returns the Gnus Cloud data chunks."
|
||||
(let ((articles nil)
|
||||
chunks)
|
||||
chunks)
|
||||
(dolist (header (gnus-cloud-available-chunks))
|
||||
(when (> (gnus-cloud-chunk-sequence (mail-header-subject header))
|
||||
gnus-cloud-sequence)
|
||||
(push (mail-header-number header) articles)))
|
||||
(or sequence-override gnus-cloud-sequence -1))
|
||||
|
||||
(if (string-match (format "storage-method: %s" gnus-cloud-storage-method)
|
||||
(mail-header-subject header))
|
||||
(push (mail-header-number header) articles)
|
||||
(gnus-message 1 "Skipping article %s because it didn't match the Gnus Cloud method %s: %s"
|
||||
(mail-header-number header)
|
||||
gnus-cloud-storage-method
|
||||
(mail-header-subject header)))))
|
||||
(when articles
|
||||
(nnimap-request-articles (nreverse articles) gnus-cloud-group-name)
|
||||
(with-current-buffer nntp-server-buffer
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "^Version " nil t)
|
||||
(beginning-of-line)
|
||||
(push (gnus-cloud-parse-chunk) chunks)
|
||||
(forward-line 1))))))
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "^Gnus-Cloud-Version " nil t)
|
||||
(beginning-of-line)
|
||||
(push (gnus-cloud-parse-chunk) chunks)
|
||||
(forward-line 1))))
|
||||
(if update
|
||||
(mapcar #'gnus-cloud-update-all chunks)
|
||||
chunks)))
|
||||
|
||||
(defun gnus-cloud-server-p (server)
|
||||
(member server gnus-cloud-covered-servers))
|
||||
|
||||
(defun gnus-cloud-host-server-p (server)
|
||||
(equal gnus-cloud-method server))
|
||||
|
||||
(defun gnus-cloud-host-acceptable-method-p (server)
|
||||
(eq (car-safe (gnus-server-to-method server)) 'nnimap))
|
||||
|
||||
(defun gnus-cloud-collect-full-newsrc ()
|
||||
"Collect all the Gnus newsrc data in a portable format."
|
||||
(let ((infos nil))
|
||||
(dolist (info (cdr gnus-newsrc-alist))
|
||||
(when (gnus-cloud-server-p
|
||||
(gnus-method-to-server
|
||||
(gnus-find-method-for-group (gnus-info-group info))))
|
||||
(push info infos)))
|
||||
))
|
||||
(gnus-method-to-server
|
||||
(gnus-find-method-for-group (gnus-info-group info))))
|
||||
|
||||
(push `(:type :newsrc-data :name ,(gnus-info-group info) :contents ,info :timestamp ,(gnus-cloud-timestamp (current-time)))
|
||||
infos)))
|
||||
infos))
|
||||
|
||||
(provide 'gnus-cloud)
|
||||
|
||||
|
||||
@ -51,6 +51,9 @@
|
||||
|
||||
(autoload 'gnus-group-make-nnir-group "nnir")
|
||||
|
||||
(autoload 'gnus-cloud-upload-all-data "gnus-cloud")
|
||||
(autoload 'gnus-cloud-download-all-data "gnus-cloud")
|
||||
|
||||
(defcustom gnus-no-groups-message "No news is good news"
|
||||
"Message displayed by Gnus when no groups are available."
|
||||
:group 'gnus-start
|
||||
@ -636,6 +639,12 @@ simple manner."
|
||||
"#" gnus-group-mark-group
|
||||
"\M-#" gnus-group-unmark-group)
|
||||
|
||||
(gnus-define-keys (gnus-group-cloud-map "~" gnus-group-mode-map)
|
||||
"u" gnus-cloud-upload-all-data
|
||||
"~" gnus-cloud-upload-all-data
|
||||
"d" gnus-cloud-download-all-data
|
||||
"\r" gnus-cloud-download-all-data)
|
||||
|
||||
(gnus-define-keys (gnus-group-mark-map "M" gnus-group-mode-map)
|
||||
"m" gnus-group-mark-group
|
||||
"u" gnus-group-unmark-group
|
||||
|
||||
@ -32,6 +32,7 @@
|
||||
(require 'gnus-group)
|
||||
(require 'gnus-int)
|
||||
(require 'gnus-range)
|
||||
(require 'gnus-cloud)
|
||||
|
||||
(autoload 'gnus-group-make-nnir-group "nnir")
|
||||
|
||||
@ -140,7 +141,8 @@ If nil, a faster, but more primitive, buffer is used instead."
|
||||
["Close" gnus-server-close-server t]
|
||||
["Offline" gnus-server-offline-server t]
|
||||
["Deny" gnus-server-deny-server t]
|
||||
["Toggle Cloud" gnus-server-toggle-cloud-server t]
|
||||
["Toggle Cloud Sync for this server" gnus-server-toggle-cloud-server t]
|
||||
["Toggle Cloud Sync Host" gnus-server-toggle-cloud-method-server t]
|
||||
"---"
|
||||
["Open All" gnus-server-open-all-servers t]
|
||||
["Close All" gnus-server-close-all-servers t]
|
||||
@ -187,6 +189,7 @@ If nil, a faster, but more primitive, buffer is used instead."
|
||||
"z" gnus-server-compact-server
|
||||
|
||||
"i" gnus-server-toggle-cloud-server
|
||||
"I" gnus-server-toggle-cloud-method-server
|
||||
|
||||
"\C-c\C-i" gnus-info-find-node
|
||||
"\C-c\C-b" gnus-bug))
|
||||
@ -205,7 +208,14 @@ If nil, a faster, but more primitive, buffer is used instead."
|
||||
'((((class color) (background light)) (:foreground "ForestGreen" :bold t))
|
||||
(((class color) (background dark)) (:foreground "PaleGreen" :bold t))
|
||||
(t (:bold t)))
|
||||
"Face used for displaying AGENTIZED servers"
|
||||
"Face used for displaying Cloud-synced servers"
|
||||
:group 'gnus-server-visual)
|
||||
|
||||
(defface gnus-server-cloud-host
|
||||
'((((class color) (background light)) (:foreground "ForestGreen" :inverse-video t :italic t))
|
||||
(((class color) (background dark)) (:foreground "PaleGreen" :inverse-video t :italic t))
|
||||
(t (:inverse-video t :italic t)))
|
||||
"Face used for displaying the Cloud Host"
|
||||
:group 'gnus-server-visual)
|
||||
|
||||
(defface gnus-server-opened
|
||||
@ -251,7 +261,8 @@ If nil, a faster, but more primitive, buffer is used instead."
|
||||
|
||||
(defvar gnus-server-font-lock-keywords
|
||||
'(("(\\(agent\\))" 1 'gnus-server-agent)
|
||||
("(\\(cloud\\))" 1 'gnus-server-cloud)
|
||||
("(\\(cloud[-]sync\\))" 1 'gnus-server-cloud)
|
||||
("(\\(CLOUD[-]HOST\\))" 1 'gnus-server-cloud-host)
|
||||
("(\\(opened\\))" 1 'gnus-server-opened)
|
||||
("(\\(closed\\))" 1 'gnus-server-closed)
|
||||
("(\\(offline\\))" 1 'gnus-server-offline)
|
||||
@ -306,9 +317,13 @@ The following commands are available:
|
||||
(gnus-agent-method-p method))
|
||||
" (agent)"
|
||||
""))
|
||||
(gnus-tmp-cloud (if (gnus-cloud-server-p gnus-tmp-name)
|
||||
" (cloud)"
|
||||
"")))
|
||||
(gnus-tmp-cloud (concat
|
||||
(if (gnus-cloud-host-server-p gnus-tmp-name)
|
||||
" (CLOUD-HOST)"
|
||||
"")
|
||||
(if (gnus-cloud-server-p gnus-tmp-name)
|
||||
" (cloud-sync)"
|
||||
""))))
|
||||
(beginning-of-line)
|
||||
(add-text-properties
|
||||
(point)
|
||||
@ -1132,6 +1147,20 @@ Requesting compaction of %s... (this may take a long time)"
|
||||
"Replication of %s in the cloud will stop")
|
||||
server)))
|
||||
|
||||
(defun gnus-server-toggle-cloud-method-server ()
|
||||
"Set the server under point to host the Emacs Cloud."
|
||||
(interactive)
|
||||
(let ((server (gnus-server-server-name)))
|
||||
(unless server
|
||||
(error "No server on the current line"))
|
||||
(unless (gnus-cloud-host-acceptable-method-p server)
|
||||
(error "The server under point can't host the Emacs Cloud"))
|
||||
|
||||
(custom-set-variables '(gnus-cloud-method server))
|
||||
(when (gnus-yes-or-no-p (format "Upload Cloud data to %S now? " server))
|
||||
(gnus-message 1 "Uploading all data to Emacs Cloud server %S" server)
|
||||
(gnus-cloud-upload-data t))))
|
||||
|
||||
(provide 'gnus-srvr)
|
||||
|
||||
;;; gnus-srvr.el ends here
|
||||
|
||||
@ -1,896 +0,0 @@
|
||||
;;; gnus-sync.el --- synchronization facility for Gnus
|
||||
|
||||
;; Copyright (C) 2010-2016 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Ted Zlatanov <tzz@lifelogs.com>
|
||||
;; Keywords: news synchronization nntp nnrss
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This is the gnus-sync.el package.
|
||||
|
||||
;; Put this in your startup file (~/.gnus.el for instance)
|
||||
|
||||
;; possibilities for gnus-sync-backend:
|
||||
;; Tramp over SSH: /ssh:user@host:/path/to/filename
|
||||
;; ...or any other file Tramp and Emacs can handle...
|
||||
|
||||
;; (setq gnus-sync-backend "/remote:/path.gpg" ; will use Tramp+EPA if loaded
|
||||
;; gnus-sync-global-vars '(gnus-newsrc-last-checked-date)
|
||||
;; gnus-sync-newsrc-groups '("nntp" "nnrss"))
|
||||
;; gnus-sync-newsrc-offsets '(2 3))
|
||||
;; against a LeSync server (beware the vampire LeSync, who knows your newsrc)
|
||||
|
||||
;; (setq gnus-sync-backend '(lesync "http://lesync.info:5984/tzz")
|
||||
;; gnus-sync-newsrc-groups '("nntp" "nnrss"))
|
||||
|
||||
;; What's a LeSync server?
|
||||
|
||||
;; 1. install CouchDB, set up a real server admin user, and create a
|
||||
;; database, e.g. "tzz" and save the URL,
|
||||
;; e.g. http://lesync.info:5984/tzz
|
||||
|
||||
;; 2. run `M-: (gnus-sync-lesync-setup "http://lesync.info:5984/tzz" "tzzadmin" "mypassword" "mysalt" t t)'
|
||||
|
||||
;; (If you run it more than once, you have to remove the entry from
|
||||
;; _users yourself. This is intentional. This sets up a database
|
||||
;; admin for the "tzz" database, distinct from the server admin
|
||||
;; user in (1) above.)
|
||||
|
||||
;; That's it, you can start using http://lesync.info:5984/tzz in your
|
||||
;; gnus-sync-backend as a LeSync backend. Fan fiction about the
|
||||
;; vampire LeSync is welcome.
|
||||
|
||||
;; You may not want to expose a CouchDB install to the Big Bad
|
||||
;; Internet, especially if your love of all things furry would be thus
|
||||
;; revealed. Make sure it's not accessible by unauthorized users and
|
||||
;; guests, at least.
|
||||
|
||||
;; If you want to try it out, I will create a test DB for you under
|
||||
;; http://lesync.info:5984/yourfavoritedbname
|
||||
|
||||
;; TODO:
|
||||
|
||||
;; - after gnus-sync-read, the message counts look wrong until you do
|
||||
;; `g'. So it's not run automatically, you have to call it with M-x
|
||||
;; gnus-sync-read
|
||||
|
||||
;; - use gnus-after-set-mark-hook and gnus-before-update-mark-hook to
|
||||
;; catch the mark updates
|
||||
|
||||
;; - repositioning of groups within topic after a LeSync sync is a
|
||||
;; weird sort of bubble sort ("buttle" sort: the old entry ends up
|
||||
;; at the rear of the list); you will eventually end up with the
|
||||
;; right order after calling `gnus-sync-read' a bunch of times.
|
||||
|
||||
;; - installing topics and groups is inefficient and annoying, lots of
|
||||
;; prompts could be avoided
|
||||
|
||||
;;; Code:
|
||||
|
||||
(eval-when-compile (require 'cl))
|
||||
(require 'json)
|
||||
(require 'gnus)
|
||||
(require 'gnus-start)
|
||||
(require 'gnus-util)
|
||||
|
||||
(defvar gnus-topic-alist) ;; gnus-group.el
|
||||
(autoload 'gnus-group-topic "gnus-topic")
|
||||
|
||||
(defgroup gnus-sync nil
|
||||
"The Gnus synchronization facility."
|
||||
:version "24.1"
|
||||
:group 'gnus)
|
||||
|
||||
(defcustom gnus-sync-newsrc-groups '("nntp" "nnrss")
|
||||
"List of groups to be synchronized in the gnus-newsrc-alist.
|
||||
The group names are matched, they don't have to be fully
|
||||
qualified. Typically you would choose all of these. That's the
|
||||
default because there is no active sync backend by default, so
|
||||
this setting is harmless until the user chooses a sync backend."
|
||||
:group 'gnus-sync
|
||||
:type '(repeat regexp))
|
||||
|
||||
(defcustom gnus-sync-newsrc-offsets '(2 3)
|
||||
"List of per-group data to be synchronized."
|
||||
:group 'gnus-sync
|
||||
:version "24.4"
|
||||
:type '(set (const :tag "Read ranges" 2)
|
||||
(const :tag "Marks" 3)))
|
||||
|
||||
(defcustom gnus-sync-global-vars nil
|
||||
"List of global variables to be synchronized.
|
||||
You may want to sync `gnus-newsrc-last-checked-date' but pretty
|
||||
much any symbol is fair game. You could additionally sync
|
||||
`gnus-newsrc-alist', `gnus-server-alist', `gnus-topic-topology',
|
||||
and `gnus-topic-alist'. Also see `gnus-variable-list'."
|
||||
:group 'gnus-sync
|
||||
:type '(repeat (choice (variable :tag "A known variable")
|
||||
(symbol :tag "Any symbol"))))
|
||||
|
||||
(defcustom gnus-sync-backend nil
|
||||
"The synchronization backend."
|
||||
:group 'gnus-sync
|
||||
:type '(radio (const :format "None" nil)
|
||||
(list :tag "Sync server"
|
||||
(const :format "LeSync Server API" lesync)
|
||||
(string :tag "URL of a CouchDB database for API access"))
|
||||
(string :tag "Sync to a file")))
|
||||
|
||||
(defvar gnus-sync-newsrc-loader nil
|
||||
"Carrier for newsrc data")
|
||||
|
||||
(defcustom gnus-sync-file-encrypt-to nil
|
||||
"If non-nil, set `epa-file-encrypt-to' from this for encrypting the Sync file."
|
||||
:version "24.4"
|
||||
:type '(choice string (repeat string))
|
||||
:group 'gnus-sync)
|
||||
|
||||
(defcustom gnus-sync-lesync-name (system-name)
|
||||
"The LeSync name for this machine."
|
||||
:group 'gnus-sync
|
||||
:version "24.3"
|
||||
:type 'string)
|
||||
|
||||
(defcustom gnus-sync-lesync-install-topics 'ask
|
||||
"Should LeSync install the recorded topics?"
|
||||
:group 'gnus-sync
|
||||
:version "24.3"
|
||||
:type '(choice (const :tag "Never Install" nil)
|
||||
(const :tag "Always Install" t)
|
||||
(const :tag "Ask Me Once" ask)))
|
||||
|
||||
(defvar gnus-sync-lesync-props-hash (make-hash-table :test 'equal)
|
||||
"LeSync props, keyed by group name")
|
||||
|
||||
(defvar gnus-sync-lesync-design-prefix "/_design/lesync"
|
||||
"The LeSync design prefix for CouchDB")
|
||||
|
||||
(defvar gnus-sync-lesync-security-object "/_security"
|
||||
"The LeSync security object for CouchDB")
|
||||
|
||||
(defun gnus-sync-lesync-parse ()
|
||||
"Parse the result of a LeSync request."
|
||||
(goto-char (point-min))
|
||||
(condition-case nil
|
||||
(when (search-forward-regexp "^$" nil t)
|
||||
(json-read))
|
||||
(error
|
||||
(gnus-message
|
||||
1
|
||||
"gnus-sync-lesync-parse: Could not read the LeSync response!")
|
||||
nil)))
|
||||
|
||||
(defun gnus-sync-lesync-call (url method headers &optional kvdata)
|
||||
"Make an access request to URL using KVDATA and METHOD.
|
||||
KVDATA must be an alist."
|
||||
(let ((url-request-method method)
|
||||
(url-request-extra-headers headers)
|
||||
(url-request-data (if kvdata (json-encode kvdata) nil)))
|
||||
(with-current-buffer (url-retrieve-synchronously url)
|
||||
(let ((data (gnus-sync-lesync-parse)))
|
||||
(gnus-message 12 "gnus-sync-lesync-call: %s URL %s sent %S got %S"
|
||||
method url `((headers . ,headers) (data ,kvdata)) data)
|
||||
(kill-buffer (current-buffer))
|
||||
data))))
|
||||
|
||||
(defun gnus-sync-lesync-PUT (url headers &optional data)
|
||||
(gnus-sync-lesync-call url "PUT" headers data))
|
||||
|
||||
(defun gnus-sync-lesync-POST (url headers &optional data)
|
||||
(gnus-sync-lesync-call url "POST" headers data))
|
||||
|
||||
(defun gnus-sync-lesync-GET (url headers &optional data)
|
||||
(gnus-sync-lesync-call url "GET" headers data))
|
||||
|
||||
(defun gnus-sync-lesync-DELETE (url headers &optional data)
|
||||
(gnus-sync-lesync-call url "DELETE" headers data))
|
||||
|
||||
; (gnus-sync-lesync-setup "http://lesync.info:5984/tzz" "tzzadmin" "mypassword" "mysalt" t t)
|
||||
; (gnus-sync-lesync-setup "http://lesync.info:5984/tzz")
|
||||
|
||||
(defun gnus-sync-lesync-setup (url &optional user password salt reader admin)
|
||||
(interactive "sEnter URL to set up: ")
|
||||
"Set up the LeSync database at URL.
|
||||
Install USER as a READER and/or an ADMIN in the security object
|
||||
under \"_security\", and in the CouchDB \"_users\" table using
|
||||
PASSWORD and SALT. Only one USER is thus supported for now.
|
||||
When SALT is nil, a random one will be generated using `random'."
|
||||
(let* ((design-url (concat url gnus-sync-lesync-design-prefix))
|
||||
(security-object (concat url "/_security"))
|
||||
(user-record `((names . [,user]) (roles . [])))
|
||||
(couch-user-name (format "org.couchdb.user:%s" user))
|
||||
(salt (or salt (sha1 (format "%s" (random)))))
|
||||
(couch-user-record
|
||||
`((_id . ,couch-user-name)
|
||||
(type . user)
|
||||
(name . ,(format "%s" user))
|
||||
(roles . [])
|
||||
(salt . ,salt)
|
||||
(password_sha . ,(when password
|
||||
(sha1
|
||||
(format "%s%s" password salt))))))
|
||||
(rev (progn
|
||||
(gnus-sync-lesync-find-prop 'rev design-url design-url)
|
||||
(gnus-sync-lesync-get-prop 'rev design-url)))
|
||||
(latest-func "function(head,req)
|
||||
{
|
||||
var tosend = [];
|
||||
var row;
|
||||
var ftime = (req.query['ftime'] || 0);
|
||||
while (row = getRow())
|
||||
{
|
||||
if (row.value['float-time'] > ftime)
|
||||
{
|
||||
var s = row.value['_id'];
|
||||
if (s) tosend.push('\"'+s.replace('\"', '\\\"')+'\"');
|
||||
}
|
||||
}
|
||||
send('['+tosend.join(',') + ']');
|
||||
}")
|
||||
;; <key>read</key>
|
||||
;; <dict>
|
||||
;; <key>de.alt.fan.ipod</key>
|
||||
;; <array>
|
||||
;; <integer>1</integer>
|
||||
;; <integer>2</integer>
|
||||
;; <dict>
|
||||
;; <key>start</key>
|
||||
;; <integer>100</integer>
|
||||
;; <key>length</key>
|
||||
;; <integer>100</integer>
|
||||
;; </dict>
|
||||
;; </array>
|
||||
;; </dict>
|
||||
(xmlplistread-func "function(head, req) {
|
||||
var row;
|
||||
start({ 'headers': { 'Content-Type': 'text/xml' } });
|
||||
|
||||
send('<dict>');
|
||||
send('<key>read</key>');
|
||||
send('<dict>');
|
||||
while(row = getRow())
|
||||
{
|
||||
var read = row.value.read;
|
||||
if (read && read[0] && read[0] == 'invlist')
|
||||
{
|
||||
send('<key>'+row.key+'</key>');
|
||||
//send('<invlist>'+read+'</invlist>');
|
||||
send('<array>');
|
||||
|
||||
var from = 0;
|
||||
var flip = false;
|
||||
|
||||
for (var i = 1; i < read.length && read[i]; i++)
|
||||
{
|
||||
var cur = read[i];
|
||||
if (flip)
|
||||
{
|
||||
if (from == cur-1)
|
||||
{
|
||||
send('<integer>'+read[i]+'</integer>');
|
||||
}
|
||||
else
|
||||
{
|
||||
send('<dict>');
|
||||
send('<key>start</key>');
|
||||
send('<integer>'+from+'</integer>');
|
||||
send('<key>end</key>');
|
||||
send('<integer>'+(cur-1)+'</integer>');
|
||||
send('</dict>');
|
||||
}
|
||||
|
||||
}
|
||||
flip = ! flip;
|
||||
from = cur;
|
||||
}
|
||||
send('</array>');
|
||||
}
|
||||
}
|
||||
|
||||
send('</dict>');
|
||||
send('</dict>');
|
||||
}
|
||||
")
|
||||
(subs-func "function(doc){emit([doc._id, doc.source], doc._rev);}")
|
||||
(revs-func "function(doc){emit(doc._id, doc._rev);}")
|
||||
(bytimesubs-func "function(doc)
|
||||
{emit([(doc['float-time']||0), doc._id], doc._rev);}")
|
||||
(bytime-func "function(doc)
|
||||
{emit([(doc['float-time']||0), doc._id], doc);}")
|
||||
(groups-func "function(doc){emit(doc._id, doc);}"))
|
||||
(and (if user
|
||||
(and (assq 'ok (gnus-sync-lesync-PUT
|
||||
security-object
|
||||
nil
|
||||
(append (and reader
|
||||
(list `(readers . ,user-record)))
|
||||
(and admin
|
||||
(list `(admins . ,user-record))))))
|
||||
(assq 'ok (gnus-sync-lesync-PUT
|
||||
(concat (file-name-directory url)
|
||||
"_users/"
|
||||
couch-user-name)
|
||||
nil
|
||||
couch-user-record)))
|
||||
t)
|
||||
(assq 'ok (gnus-sync-lesync-PUT
|
||||
design-url
|
||||
nil
|
||||
`(,@(when rev (list (cons '_rev rev)))
|
||||
(lists . ((latest . ,latest-func)
|
||||
(xmlplistread . ,xmlplistread-func)))
|
||||
(views . ((subs . ((map . ,subs-func)))
|
||||
(revs . ((map . ,revs-func)))
|
||||
(bytimesubs . ((map . ,bytimesubs-func)))
|
||||
(bytime . ((map . ,bytime-func)))
|
||||
(groups . ((map . ,groups-func)))))))))))
|
||||
|
||||
(defun gnus-sync-lesync-find-prop (prop url key)
|
||||
"Retrieve a PROPerty of a document KEY at URL.
|
||||
Calls `gnus-sync-lesync-set-prop'.
|
||||
For the 'rev PROP, uses '_rev against the document."
|
||||
(gnus-sync-lesync-set-prop
|
||||
prop key (cdr (assq (if (eq prop 'rev) '_rev prop)
|
||||
(gnus-sync-lesync-GET url nil)))))
|
||||
|
||||
(defun gnus-sync-lesync-set-prop (prop key val)
|
||||
"Update the PROPerty of document KEY at URL to VAL.
|
||||
Updates `gnus-sync-lesync-props-hash'."
|
||||
(puthash (format "%s.%s" key prop) val gnus-sync-lesync-props-hash))
|
||||
|
||||
(defun gnus-sync-lesync-get-prop (prop key)
|
||||
"Get the PROPerty of KEY from `gnus-sync-lesync-props-hash'."
|
||||
(gethash (format "%s.%s" key prop) gnus-sync-lesync-props-hash))
|
||||
|
||||
(defun gnus-sync-deep-print (data)
|
||||
(let* ((print-quoted t)
|
||||
(print-readably t)
|
||||
(print-escape-multibyte nil)
|
||||
(print-escape-nonascii t)
|
||||
(print-length nil)
|
||||
(print-level nil)
|
||||
(print-circle nil)
|
||||
(print-escape-newlines t))
|
||||
(format "%S" data)))
|
||||
|
||||
(defun gnus-sync-newsrc-loader-builder (&optional only-modified)
|
||||
(let* ((entries (cdr gnus-newsrc-alist))
|
||||
entry name ret)
|
||||
(while entries
|
||||
(setq entry (pop entries)
|
||||
name (car entry))
|
||||
(when (gnus-grep-in-list name gnus-sync-newsrc-groups)
|
||||
(if only-modified
|
||||
(when (not (equal (gnus-sync-deep-print entry)
|
||||
(gnus-sync-lesync-get-prop 'checksum name)))
|
||||
(gnus-message 9 "%s: add %s, it's modified"
|
||||
"gnus-sync-newsrc-loader-builder" name)
|
||||
(push entry ret))
|
||||
(push entry ret))))
|
||||
ret))
|
||||
|
||||
; (json-encode (gnus-sync-range2invlist '((1 . 47137) (47139 . 47714) 48129 48211 49231 49281 49342 49473 49475 49502)))
|
||||
(defun gnus-sync-range2invlist (ranges)
|
||||
(append '(invlist)
|
||||
(let ((ranges (delq nil ranges))
|
||||
ret range from to)
|
||||
(while ranges
|
||||
(setq range (pop ranges))
|
||||
(if (atom range)
|
||||
(setq from range
|
||||
to range)
|
||||
(setq from (car range)
|
||||
to (cdr range)))
|
||||
(push from ret)
|
||||
(push (1+ to) ret))
|
||||
(reverse ret))))
|
||||
|
||||
; (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))
|
||||
(defun gnus-sync-invlist2range (inv)
|
||||
(setq inv (append inv nil))
|
||||
(if (equal (format "%s" (car inv)) "invlist")
|
||||
(let ((i (cdr inv))
|
||||
(start 0)
|
||||
ret cur top flip)
|
||||
(while i
|
||||
(setq cur (pop i))
|
||||
(when flip
|
||||
(setq top (1- cur))
|
||||
(if (= start top)
|
||||
(push start ret)
|
||||
(push (cons start top) ret)))
|
||||
(setq flip (not flip))
|
||||
(setq start cur))
|
||||
(reverse ret))
|
||||
inv))
|
||||
|
||||
(defun gnus-sync-position (search list &optional test)
|
||||
"Find the position of SEARCH in LIST using TEST, defaulting to `eq'."
|
||||
(let ((pos 0)
|
||||
(test (or test 'eq)))
|
||||
(while (and list (not (funcall test (car list) search)))
|
||||
(pop list)
|
||||
(incf pos))
|
||||
(if (funcall test (car list) search) pos nil)))
|
||||
|
||||
(defun gnus-sync-topic-group-position (group topic-name)
|
||||
(gnus-sync-position
|
||||
group (cdr (assoc topic-name gnus-topic-alist)) 'equal))
|
||||
|
||||
(defun gnus-sync-fix-topic-group-position (group topic-name position)
|
||||
(unless (equal position (gnus-sync-topic-group-position group topic-name))
|
||||
(let* ((loc "gnus-sync-fix-topic-group-position")
|
||||
(groups (delete group (cdr (assoc topic-name gnus-topic-alist))))
|
||||
(position (min position (1- (length groups))))
|
||||
(old (nth position groups)))
|
||||
(when (and old (not (equal old group)))
|
||||
(setf (nth position groups) group)
|
||||
(setcdr (assoc topic-name gnus-topic-alist)
|
||||
(append groups (list old)))
|
||||
(gnus-message 9 "%s: %s moved to %d, swap with %s"
|
||||
loc group position old)))))
|
||||
|
||||
(defun gnus-sync-lesync-pre-save-group-entry (url nentry &rest passed-props)
|
||||
(let* ((loc "gnus-sync-lesync-save-group-entry")
|
||||
(k (car nentry))
|
||||
(revision (gnus-sync-lesync-get-prop 'rev k))
|
||||
(sname gnus-sync-lesync-name)
|
||||
(topic (gnus-group-topic k))
|
||||
(topic-offset (gnus-sync-topic-group-position k topic))
|
||||
(sources (gnus-sync-lesync-get-prop 'source k)))
|
||||
;; set the revision so we don't have a conflict
|
||||
`(,@(when revision
|
||||
(list (cons '_rev revision)))
|
||||
(_id . ,k)
|
||||
;; the time we saved
|
||||
,@passed-props
|
||||
;; add our name to the sources list for this key
|
||||
(source ,@(if (member gnus-sync-lesync-name sources)
|
||||
sources
|
||||
(cons gnus-sync-lesync-name sources)))
|
||||
,(cons 'level (nth 1 nentry))
|
||||
,@(if topic (list (cons 'topic topic)) nil)
|
||||
,@(if topic-offset (list (cons 'topic-offset topic-offset)) nil)
|
||||
;; the read marks
|
||||
,(cons 'read (gnus-sync-range2invlist (nth 2 nentry)))
|
||||
;; the other marks
|
||||
,@(delq nil (mapcar (lambda (mark-entry)
|
||||
(gnus-message 12 "%s: prep param %s in %s"
|
||||
loc
|
||||
(car mark-entry)
|
||||
(nth 3 nentry))
|
||||
(if (listp (cdr mark-entry))
|
||||
(cons (car mark-entry)
|
||||
(gnus-sync-range2invlist
|
||||
(cdr mark-entry)))
|
||||
(progn ; else this is not a list
|
||||
(gnus-message 9 "%s: non-list param %s in %s"
|
||||
loc
|
||||
(car mark-entry)
|
||||
(nth 3 nentry))
|
||||
nil)))
|
||||
(nth 3 nentry))))))
|
||||
|
||||
(defun gnus-sync-lesync-post-save-group-entry (url entry)
|
||||
(let* ((loc "gnus-sync-lesync-post-save-group-entry")
|
||||
(k (cdr (assq 'id entry))))
|
||||
(cond
|
||||
;; success!
|
||||
((and (assq 'rev entry) (assq 'id entry))
|
||||
(progn
|
||||
(gnus-sync-lesync-set-prop 'rev k (cdr (assq 'rev entry)))
|
||||
(gnus-sync-lesync-set-prop 'checksum
|
||||
k
|
||||
(gnus-sync-deep-print
|
||||
(assoc k gnus-newsrc-alist)))
|
||||
(gnus-message 9 "%s: successfully synced %s to %s"
|
||||
loc k url)))
|
||||
;; specifically check for document conflicts
|
||||
((equal "conflict" (format "%s" (cdr-safe (assq 'error entry))))
|
||||
(gnus-error
|
||||
1
|
||||
"%s: use `%s' to resolve the conflict synchronizing %s to %s: %s"
|
||||
loc "gnus-sync-read" k url (cdr (assq 'reason entry))))
|
||||
;; generic errors
|
||||
((assq 'error entry)
|
||||
(gnus-error 1 "%s: got error while synchronizing %s to %s: %s"
|
||||
loc k url (cdr (assq 'reason entry))))
|
||||
|
||||
(t
|
||||
(gnus-message 2 "%s: unknown sync status after %s to %s: %S"
|
||||
loc k url entry)))
|
||||
(assoc 'error entry)))
|
||||
|
||||
(defun gnus-sync-lesync-groups-builder (url)
|
||||
(let ((u (concat url gnus-sync-lesync-design-prefix "/_view/groups")))
|
||||
(cdr (assq 'rows (gnus-sync-lesync-GET u nil)))))
|
||||
|
||||
(defun gnus-sync-subscribe-group (name)
|
||||
"Subscribe to group NAME. Returns NAME on success, nil otherwise."
|
||||
(gnus-subscribe-newsgroup name))
|
||||
|
||||
(defun gnus-sync-lesync-read-group-entry (url name entry &rest passed-props)
|
||||
"Read ENTRY information for NAME. Returns NAME if successful.
|
||||
Skips entries whose sources don't contain
|
||||
`gnus-sync-lesync-name'. When the alist PASSED-PROPS has a
|
||||
`subscribe-all' element that evaluates to true, we attempt to
|
||||
subscribe to unknown groups. The user is also allowed to delete
|
||||
unwanted groups via the LeSync URL."
|
||||
(let* ((loc "gnus-sync-lesync-read-group-entry")
|
||||
(entry (gnus-sync-lesync-normalize-group-entry entry passed-props))
|
||||
(subscribe-all (cdr (assq 'subscribe-all passed-props)))
|
||||
(sources (cdr (assq 'source entry)))
|
||||
(rev (cdr (assq 'rev entry)))
|
||||
(in-sources (member gnus-sync-lesync-name sources))
|
||||
(known (assoc name gnus-newsrc-alist))
|
||||
cell)
|
||||
(unless known
|
||||
(if (and subscribe-all
|
||||
(y-or-n-p (format "Subscribe to group %s?" name)))
|
||||
(setq known (gnus-sync-subscribe-group name)
|
||||
in-sources t)
|
||||
;; else...
|
||||
(when (y-or-n-p (format "Delete group %s from server?" name))
|
||||
(if (equal name (gnus-sync-lesync-delete-group url name))
|
||||
(gnus-message 1 "%s: removed group %s from server %s"
|
||||
loc name url)
|
||||
(gnus-error 1 "%s: could not remove group %s from server %s"
|
||||
loc name url)))))
|
||||
(when known
|
||||
(unless in-sources
|
||||
(setq in-sources
|
||||
(y-or-n-p
|
||||
(format "Read group %s even though %s is not in sources %S?"
|
||||
name gnus-sync-lesync-name (or sources ""))))))
|
||||
(when rev
|
||||
(gnus-sync-lesync-set-prop 'rev name rev))
|
||||
|
||||
;; if the source matches AND we have this group
|
||||
(if (and known in-sources)
|
||||
(progn
|
||||
(gnus-message 10 "%s: reading LeSync entry %s, sources %S"
|
||||
loc name sources)
|
||||
(while entry
|
||||
(setq cell (pop entry))
|
||||
(let ((k (car cell))
|
||||
(val (cdr cell)))
|
||||
(gnus-sync-lesync-set-prop k name val)))
|
||||
name)
|
||||
;; else...
|
||||
(unless known
|
||||
(gnus-message 5 "%s: ignoring entry %s, it wasn't subscribed. %s"
|
||||
loc name "Call `gnus-sync-read' with C-u to force it."))
|
||||
(unless in-sources
|
||||
(gnus-message 5 "%s: ignoring entry %s, %s not in sources %S"
|
||||
loc name gnus-sync-lesync-name (or sources "")))
|
||||
nil)))
|
||||
|
||||
(declare-function gnus-topic-create-topic "gnus-topic"
|
||||
(topic parent &optional previous full-topic))
|
||||
(declare-function gnus-topic-enter-dribble "gnus-topic" ())
|
||||
|
||||
(defun gnus-sync-lesync-install-group-entry (name)
|
||||
(let* ((master (assoc name gnus-newsrc-alist))
|
||||
(old-topic-name (gnus-group-topic name))
|
||||
(old-topic (assoc old-topic-name gnus-topic-alist))
|
||||
(target-topic-name (gnus-sync-lesync-get-prop 'topic name))
|
||||
(target-topic-offset (gnus-sync-lesync-get-prop 'topic-offset name))
|
||||
(target-topic (assoc target-topic-name gnus-topic-alist))
|
||||
(loc "gnus-sync-lesync-install-group-entry"))
|
||||
(if master
|
||||
(progn
|
||||
(when (eq 'ask gnus-sync-lesync-install-topics)
|
||||
(setq gnus-sync-lesync-install-topics
|
||||
(y-or-n-p "Install topics from LeSync?")))
|
||||
(when (and (eq t gnus-sync-lesync-install-topics)
|
||||
target-topic-name)
|
||||
(if (equal old-topic-name target-topic-name)
|
||||
(gnus-message 12 "%s: %s is already in topic %s"
|
||||
loc name target-topic-name)
|
||||
;; see `gnus-topic-move-group'
|
||||
(when (and old-topic target-topic)
|
||||
(setcdr old-topic (gnus-delete-first name (cdr old-topic)))
|
||||
(gnus-message 5 "%s: removing %s from topic %s"
|
||||
loc name old-topic-name))
|
||||
(unless target-topic
|
||||
(when (y-or-n-p (format "Create missing topic %s?"
|
||||
target-topic-name))
|
||||
(gnus-topic-create-topic target-topic-name nil)
|
||||
(setq target-topic (assoc target-topic-name
|
||||
gnus-topic-alist))))
|
||||
(if target-topic
|
||||
(prog1
|
||||
(nconc target-topic (list name))
|
||||
(gnus-message 5 "%s: adding %s to topic %s"
|
||||
loc name (car target-topic))
|
||||
(gnus-topic-enter-dribble))
|
||||
(gnus-error 2 "%s: LeSync group %s can't go in missing topic %s"
|
||||
loc name target-topic-name)))
|
||||
(when (and target-topic-offset target-topic)
|
||||
(gnus-sync-fix-topic-group-position
|
||||
name target-topic-name target-topic-offset)))
|
||||
;; install the subscription level
|
||||
(when (gnus-sync-lesync-get-prop 'level name)
|
||||
(setf (nth 1 master) (gnus-sync-lesync-get-prop 'level name)))
|
||||
;; install the read and other marks
|
||||
(setf (nth 2 master) (gnus-sync-lesync-get-prop 'read name))
|
||||
(setf (nth 3 master) (gnus-sync-lesync-get-prop 'marks name))
|
||||
(gnus-sync-lesync-set-prop 'checksum
|
||||
name
|
||||
(gnus-sync-deep-print master))
|
||||
nil)
|
||||
(gnus-error 1 "%s: invalid LeSync group %s" loc name)
|
||||
'invalid-name)))
|
||||
|
||||
; (gnus-sync-lesync-delete-group (cdr gnus-sync-backend) "nntp+Gmane:gwene.org.slashdot")
|
||||
|
||||
(defun gnus-sync-lesync-delete-group (url name)
|
||||
"Returns NAME if successful deleting it from URL, an error otherwise."
|
||||
(interactive "sEnter URL to set up: \rsEnter group name: ")
|
||||
(let* ((u (concat (cadr gnus-sync-backend) "/" (url-hexify-string name)))
|
||||
(del (gnus-sync-lesync-DELETE
|
||||
u
|
||||
`(,@(when (gnus-sync-lesync-get-prop 'rev name)
|
||||
(list (cons "If-Match"
|
||||
(gnus-sync-lesync-get-prop 'rev name))))))))
|
||||
(or (cdr (assq 'id del)) del)))
|
||||
|
||||
;;; (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)))
|
||||
|
||||
(defun gnus-sync-lesync-normalize-group-entry (entry &optional passed-props)
|
||||
(let (ret
|
||||
marks
|
||||
cell)
|
||||
(setq entry (append passed-props entry))
|
||||
(while (setq cell (pop entry))
|
||||
(let ((k (car cell))
|
||||
(val (cdr cell)))
|
||||
(cond
|
||||
((eq k 'read)
|
||||
(push (cons k (gnus-sync-invlist2range val)) ret))
|
||||
;; we ignore these parameters
|
||||
((member k '(_id subscribe-all _deleted_conflicts))
|
||||
nil)
|
||||
((eq k '_rev)
|
||||
(push (cons 'rev val) ret))
|
||||
((eq k 'source)
|
||||
(push (cons 'source (append val nil)) ret))
|
||||
((or (eq k 'float-time)
|
||||
(eq k 'level)
|
||||
(eq k 'topic)
|
||||
(eq k 'topic-offset)
|
||||
(eq k 'read-time))
|
||||
(push (cons k val) ret))
|
||||
;;; "How often have I said to you that when you have eliminated the
|
||||
;;; impossible, whatever remains, however improbable, must be the
|
||||
;;; truth?" --Sherlock Holmes
|
||||
;; everything remaining must be a mark
|
||||
(t (push (cons k (gnus-sync-invlist2range val)) marks)))))
|
||||
(cons (cons 'marks marks) ret)))
|
||||
|
||||
(defun gnus-sync-save (&optional force)
|
||||
"Save the Gnus sync data to the backend.
|
||||
With a prefix, FORCE is set and all groups will be saved."
|
||||
(interactive "P")
|
||||
(cond
|
||||
((and (listp gnus-sync-backend)
|
||||
(eq (nth 0 gnus-sync-backend) 'lesync)
|
||||
(stringp (nth 1 gnus-sync-backend)))
|
||||
|
||||
;; refresh the revisions if we're forcing the save
|
||||
(when force
|
||||
(mapc (lambda (entry)
|
||||
(when (and (assq 'key entry)
|
||||
(assq 'value entry))
|
||||
(gnus-sync-lesync-set-prop
|
||||
'rev
|
||||
(cdr (assq 'key entry))
|
||||
(cdr (assq 'value entry)))))
|
||||
;; the revs view is key = name, value = rev
|
||||
(cdr (assq 'rows (gnus-sync-lesync-GET
|
||||
(concat (nth 1 gnus-sync-backend)
|
||||
gnus-sync-lesync-design-prefix
|
||||
"/_view/revs")
|
||||
nil)))))
|
||||
|
||||
(let* ((ftime (float-time))
|
||||
(url (nth 1 gnus-sync-backend))
|
||||
(entries
|
||||
(mapcar (lambda (entry)
|
||||
(gnus-sync-lesync-pre-save-group-entry
|
||||
(cadr gnus-sync-backend)
|
||||
entry
|
||||
(cons 'float-time ftime)))
|
||||
(gnus-sync-newsrc-loader-builder (not force))))
|
||||
;; when there are no entries, there's nothing to save
|
||||
(sync (if entries
|
||||
(gnus-sync-lesync-POST
|
||||
(concat url "/_bulk_docs")
|
||||
'(("Content-Type" . "application/json"))
|
||||
`((docs . ,(vconcat entries nil))))
|
||||
(gnus-message
|
||||
2 "gnus-sync-save: nothing to save to the LeSync backend")
|
||||
nil)))
|
||||
(mapcar (lambda (e) (gnus-sync-lesync-post-save-group-entry url e))
|
||||
sync)))
|
||||
((stringp gnus-sync-backend)
|
||||
(gnus-message 7 "gnus-sync-save: saving to backend %s" gnus-sync-backend)
|
||||
;; populate gnus-sync-newsrc-loader from all but the first dummy
|
||||
;; entry in gnus-newsrc-alist whose group matches any of the
|
||||
;; gnus-sync-newsrc-groups
|
||||
;; TODO: keep the old contents for groups we don't have!
|
||||
(let ((gnus-sync-newsrc-loader
|
||||
(loop for entry in (cdr gnus-newsrc-alist)
|
||||
when (gnus-grep-in-list
|
||||
(car entry) ;the group name
|
||||
gnus-sync-newsrc-groups)
|
||||
collect (cons (car entry)
|
||||
(mapcar (lambda (offset)
|
||||
(cons offset (nth offset entry)))
|
||||
gnus-sync-newsrc-offsets)))))
|
||||
(with-temp-file gnus-sync-backend
|
||||
(progn
|
||||
(let ((coding-system-for-write gnus-ding-file-coding-system)
|
||||
(standard-output (current-buffer)))
|
||||
(when gnus-sync-file-encrypt-to
|
||||
(set (make-local-variable 'epa-file-encrypt-to)
|
||||
gnus-sync-file-encrypt-to))
|
||||
(princ (format ";; -*- mode:emacs-lisp; coding: %s; -*-\n"
|
||||
gnus-ding-file-coding-system))
|
||||
(princ ";; Gnus sync data v. 0.0.1\n")
|
||||
;; TODO: replace with `gnus-sync-deep-print'
|
||||
(let* ((print-quoted t)
|
||||
(print-readably t)
|
||||
(print-escape-multibyte nil)
|
||||
(print-escape-nonascii t)
|
||||
(print-length nil)
|
||||
(print-level nil)
|
||||
(print-circle nil)
|
||||
(print-escape-newlines t)
|
||||
(variables (cons 'gnus-sync-newsrc-loader
|
||||
gnus-sync-global-vars))
|
||||
variable)
|
||||
(while variables
|
||||
(if (and (boundp (setq variable (pop variables)))
|
||||
(symbol-value variable))
|
||||
(progn
|
||||
(princ "\n(setq ")
|
||||
(princ (symbol-name variable))
|
||||
(princ " '")
|
||||
(prin1 (symbol-value variable))
|
||||
(princ ")\n"))
|
||||
(princ "\n;;; skipping empty variable ")
|
||||
(princ (symbol-name variable)))))
|
||||
(gnus-message
|
||||
7
|
||||
"gnus-sync-save: stored variables %s and %d groups in %s"
|
||||
gnus-sync-global-vars
|
||||
(length gnus-sync-newsrc-loader)
|
||||
gnus-sync-backend)
|
||||
|
||||
;; Idea from Dan Christensen <jdc@chow.mat.jhu.edu>
|
||||
;; Save the .eld file with extra line breaks.
|
||||
(gnus-message 8 "gnus-sync-save: adding whitespace to %s"
|
||||
gnus-sync-backend)
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "^(\\|(\\\"" nil t)
|
||||
(replace-match "\n\\&" t))
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward " $" nil t)
|
||||
(replace-match "" t t))))))))
|
||||
;; the pass-through case: gnus-sync-backend is not a known choice
|
||||
(nil)))
|
||||
|
||||
(defun gnus-sync-read (&optional subscribe-all)
|
||||
"Load the Gnus sync data from the backend.
|
||||
With a prefix, SUBSCRIBE-ALL is set and unknown groups will be subscribed."
|
||||
(interactive "P")
|
||||
(when gnus-sync-backend
|
||||
(gnus-message 7 "gnus-sync-read: loading from backend %s" gnus-sync-backend)
|
||||
(cond
|
||||
((and (listp gnus-sync-backend)
|
||||
(eq (nth 0 gnus-sync-backend) 'lesync)
|
||||
(stringp (nth 1 gnus-sync-backend)))
|
||||
(let ((errored nil)
|
||||
name ftime)
|
||||
(mapc (lambda (entry)
|
||||
(setq name (cdr (assq 'id entry)))
|
||||
;; set ftime the FIRST time through this loop, that
|
||||
;; way it reflects the time we FINISHED reading
|
||||
(unless ftime (setq ftime (float-time)))
|
||||
|
||||
(unless errored
|
||||
(setq errored
|
||||
(when (equal name
|
||||
(gnus-sync-lesync-read-group-entry
|
||||
(nth 1 gnus-sync-backend)
|
||||
name
|
||||
(cdr (assq 'value entry))
|
||||
`(read-time ,ftime)
|
||||
`(subscribe-all ,subscribe-all)))
|
||||
(gnus-sync-lesync-install-group-entry
|
||||
(cdr (assq 'id entry)))))))
|
||||
(gnus-sync-lesync-groups-builder (nth 1 gnus-sync-backend)))))
|
||||
|
||||
((stringp gnus-sync-backend)
|
||||
;; read data here...
|
||||
(if (or debug-on-error debug-on-quit)
|
||||
(load gnus-sync-backend nil t)
|
||||
(condition-case var
|
||||
(load gnus-sync-backend nil t)
|
||||
(error
|
||||
(error "Error in %s: %s" gnus-sync-backend (cadr var)))))
|
||||
(let ((valid-count 0)
|
||||
invalid-groups)
|
||||
(dolist (node gnus-sync-newsrc-loader)
|
||||
(if (gnus-gethash (car node) gnus-newsrc-hashtb)
|
||||
(progn
|
||||
(incf valid-count)
|
||||
(loop for store in (cdr node)
|
||||
do (setf (nth (car store)
|
||||
(assoc (car node) gnus-newsrc-alist))
|
||||
(cdr store))))
|
||||
(push (car node) invalid-groups)))
|
||||
(gnus-message
|
||||
7
|
||||
"gnus-sync-read: loaded %d groups (out of %d) from %s"
|
||||
valid-count (length gnus-sync-newsrc-loader)
|
||||
gnus-sync-backend)
|
||||
(when invalid-groups
|
||||
(gnus-message
|
||||
7
|
||||
"gnus-sync-read: skipped %d groups (out of %d) from %s"
|
||||
(length invalid-groups)
|
||||
(length gnus-sync-newsrc-loader)
|
||||
gnus-sync-backend)
|
||||
(gnus-message 9 "gnus-sync-read: skipped groups: %s"
|
||||
(mapconcat 'identity invalid-groups ", ")))))
|
||||
(nil))
|
||||
|
||||
(gnus-message 9 "gnus-sync-read: remaking the newsrc hashtable")
|
||||
(gnus-make-hashtable-from-newsrc-alist)))
|
||||
|
||||
;;;###autoload
|
||||
(defun gnus-sync-initialize ()
|
||||
"Initialize the Gnus sync facility."
|
||||
(interactive)
|
||||
(gnus-message 5 "Initializing the sync facility")
|
||||
(gnus-sync-install-hooks))
|
||||
|
||||
;;;###autoload
|
||||
(defun gnus-sync-install-hooks ()
|
||||
"Install the sync hooks."
|
||||
(interactive)
|
||||
;; (add-hook 'gnus-get-new-news-hook 'gnus-sync-read)
|
||||
;; (add-hook 'gnus-read-newsrc-el-hook 'gnus-sync-read)
|
||||
(add-hook 'gnus-save-newsrc-hook 'gnus-sync-save))
|
||||
|
||||
(defun gnus-sync-unload-hook ()
|
||||
"Uninstall the sync hooks."
|
||||
(interactive)
|
||||
(remove-hook 'gnus-save-newsrc-hook 'gnus-sync-save))
|
||||
|
||||
(add-hook 'gnus-sync-unload-hook 'gnus-sync-unload-hook)
|
||||
|
||||
(when gnus-sync-backend (gnus-sync-initialize))
|
||||
|
||||
(provide 'gnus-sync)
|
||||
|
||||
;;; gnus-sync.el ends here
|
||||
Loading…
Reference in New Issue
Block a user