From: Ted Zlatanov Date: Mon, 11 Jul 2016 15:01:26 +0000 (-0400) Subject: Bring the Gnus Cloud package into working order. X-Git-Tag: emacs-26.0.90~1840^2~32 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=30b3a842ec87d27cfe003b6d4323689d48b3fcd2;p=emacs.git 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. --- diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi index df673fc099f..2473d26cc15 100644 --- a/doc/misc/gnus.texi +++ b/doc/misc/gnus.texi @@ -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 diff --git a/lisp/gnus/gnus-cloud.el b/lisp/gnus/gnus-cloud.el index a6a0f64603d..22086b1f36e 100644 --- a/lisp/gnus/gnus-cloud.el +++ b/lisp/gnus/gnus-cloud.el @@ -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)))))) - -(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)))) + (gnus-message 1 "Unknown type %s; ignoring" type)))))) + +(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) diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index 813d9b6ced5..828805384ca 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -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 diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el index aa76a5f35f5..66fb9ee1b59 100644 --- a/lisp/gnus/gnus-srvr.el +++ b/lisp/gnus/gnus-srvr.el @@ -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 diff --git a/lisp/gnus/gnus-sync.el b/lisp/gnus/gnus-sync.el deleted file mode 100644 index 249eb087b0b..00000000000 --- a/lisp/gnus/gnus-sync.el +++ /dev/null @@ -1,896 +0,0 @@ -;;; gnus-sync.el --- synchronization facility for Gnus - -;; Copyright (C) 2010-2016 Free Software Foundation, Inc. - -;; Author: Ted Zlatanov -;; 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 . - -;;; 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(',') + ']'); -}") -;; read -;; -;; de.alt.fan.ipod -;; -;; 1 -;; 2 -;; -;; start -;; 100 -;; length -;; 100 -;; -;; -;; - (xmlplistread-func "function(head, req) { - var row; - start({ 'headers': { 'Content-Type': 'text/xml' } }); - - send(''); - send('read'); - send(''); - while(row = getRow()) - { - var read = row.value.read; - if (read && read[0] && read[0] == 'invlist') - { - send(''+row.key+''); - //send(''+read+''); - send(''); - - 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(''+read[i]+''); - } - else - { - send(''); - send('start'); - send(''+from+''); - send('end'); - send(''+(cur-1)+''); - send(''); - } - - } - flip = ! flip; - from = cur; - } - send(''); - } - } - - send(''); - send(''); -} -") - (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 - ;; 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