Skip to content

Instantly share code, notes, and snippets.

@steinarb

steinarb/0001-Gnus-Emacs-Cloud-fixes-and-refactoring.patch

Last active June 21, 2016 15:27
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save steinarb/ddc774659e05cabeec7267d556ca423e to your computer and use it in GitHub Desktop.
Save steinarb/ddc774659e05cabeec7267d556ca423e to your computer and use it in GitHub Desktop.
Download ZIP
gnus-cloud changes made to gnus in the emacs repository
Raw
0001-Gnus-Emacs-Cloud-fixes-and-refactoring.patch
From 743e6b6ceee7eee1fbeb01e4ecc4e39e636c20d8 Mon Sep 17 00:00:00 2001
From: Ted Zlatanov <tzz@lifelogs.com>
Date: Wed, 15 Jun 2016 14:36:24 -0400
Subject: [PATCH] Gnus/Emacs Cloud fixes and refactoring
* add storage method and minor cleanups
* whitespace cleanups
* get upload/download and EPG working
---
lisp/gnus/gnus-cloud.el | 374 ++++++++++++--------
lisp/gnus/gnus-srvr.el | 39 ++-
lisp/gnus/gnus-sync.el | 896 ------------------------------------------------
3 files changed, 259 insertions(+), 1050 deletions(-)
delete mode 100644 lisp/gnus/gnus-sync.el
diff --git a/lisp/gnus/gnus-cloud.el b/lisp/gnus/gnus-cloud.el
index a6a0f64..dac8d42 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,7 +49,15 @@
;; 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 '(choice (const :tag "No encoding" nil)
+ (const :tag "Base64" base64)
+ (const :tag "Base64+gzip" base64-gzip)
+ (const :tag "EPG" epg)))
+
+(defvar gnus-cloud-group-name "Emacs-Cloud")
(defvar gnus-cloud-covered-servers nil)
(defvar gnus-cloud-version 1)
@@ -54,7 +68,7 @@
(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 +77,151 @@
(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")))
+ (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"))
+ (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"))
((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 (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))))))
(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))
+ (gnus-cloud-update-data 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-data (elem)
+ (gnus-error 1 "TODO: update newsrc data"))
-(defun gnus-cloud-update-file (elem)
+(defun gnus-cloud-update-file (elem op)
(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))))
+ (date (plist-get elem :timestamp))
+ (contents (plist-get elem :contents)))
+ (if (gnus-cloud-file-covered-p file-name)
+ (cond
+ ((eq op :delete)
+ (if (file-exists-p file-name)
+ (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 (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 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 +231,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 +251,112 @@
(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-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))))
+ "%FT%T%z" (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-data (&optional full)
(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 (gnus-cloud-files-to-upload full))
+ (group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method)))
+ (insert (format "Subject: (sequence: %d type: %s storage-method: %s)\n"
+ gnus-cloud-sequence
+ (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+ gnus-cloud-sequence))
+ (gnus-cloud-add-timestamps elems)
+ (gnus-message 3 "Uploaded Emacs Cloud data successfully to %s" group))
+ (gnus-error 2 "Failed to upload Emacs 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,36 +365,55 @@
(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-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))
+
+ (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
+ (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-collect-full-newsrc ()
(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 info infos)))
))
(provide 'gnus-cloud)
diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el
index aa76a5f..4f463f8 100644
--- a/lisp/gnus/gnus-srvr.el
+++ b/lisp/gnus/gnus-srvr.el
@@ -140,7 +140,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 +188,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 +207,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 +260,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 +316,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 +1146,19 @@ 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 (eq (car-safe (gnus-server-to-method server)) 'nnimap)
+ (error "The server under point is not IMAP, so it can't host the Emacs Cloud"))
+
+ (setq gnus-cloud-method server)
+ (gnus-message 1 "Uploading all data to Emacs Cloud with %S" gnus-cloud-method)
+ (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 249eb08..0000000
--- 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 <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
--
2.1.4
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment