(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"
;; 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)))
(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
(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 ()
(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))
(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)