mirror of
git://git.sv.gnu.org/emacs.git
synced 2025-12-18 11:50:38 -08:00
bc511a64f6
Most of this change is to boilerplate commentary such as license URLs. This change was prompted by ftp://ftp.gnu.org's going-away party, planned for November. Change these FTP URLs to https://ftp.gnu.org instead. Make similar changes for URLs to other organizations moving away from FTP. Also, change HTTP to HTTPS for URLs to gnu.org and fsf.org when this works, as this will further help defend against man-in-the-middle attacks (for this part I omitted the MS-DOS and MS-Windows sources and the test tarballs to keep the workload down). HTTPS is not fully working to lists.gnu.org so I left those URLs alone for now.
495 lines
19 KiB
EmacsLisp
495 lines
19 KiB
EmacsLisp
;;; gnus-cloud.el --- storing and retrieving data via IMAP
|
|
|
|
;; Copyright (C) 2014-2017 Free Software Foundation, Inc.
|
|
|
|
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
|
|
;; Keywords: mail
|
|
|
|
;; 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 <https://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
|
|
;;; Code:
|
|
|
|
(eval-when-compile (require 'cl))
|
|
(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"
|
|
:group 'gnus)
|
|
|
|
(defcustom gnus-cloud-synced-files
|
|
'(;;"~/.authinfo"
|
|
"~/.authinfo.gpg"
|
|
"~/.gnus.el"
|
|
(:directory "~/News" :match ".*.SCORE\\'"))
|
|
"List of file regexps that should be kept up-to-date via the cloud."
|
|
:group 'gnus-cloud
|
|
;; FIXME this type does not match the default. Nor does the documentation.
|
|
:type '(repeat regexp))
|
|
|
|
(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)
|
|
|
|
(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 "Gnus-Cloud-Version %s\n" gnus-cloud-version))
|
|
(insert (gnus-cloud-insert-data elems))
|
|
(buffer-string)))
|
|
|
|
(defun gnus-cloud-insert-data (elems)
|
|
(mm-with-unibyte-buffer
|
|
(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) :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))))))
|
|
(gnus-cloud-encode-data)
|
|
(buffer-string)))
|
|
|
|
(defun gnus-cloud-encode-data ()
|
|
(cond
|
|
((eq gnus-cloud-storage-method 'base64-gzip)
|
|
(progn
|
|
(call-process-region (point-min) (point-max) "gzip"
|
|
t (current-buffer) nil
|
|
"-c")
|
|
(base64-encode-region (point-min) (point-max))))
|
|
|
|
((eq gnus-cloud-storage-method 'base64)
|
|
(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 ()
|
|
(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
|
|
(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))))
|
|
(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)))))))
|
|
|
|
(defun gnus-cloud-parse-version-1 ()
|
|
(let ((elems nil))
|
|
(while (not (eobp))
|
|
(while (and (not (eobp))
|
|
(not (looking-at "(:type")))
|
|
(forward-line 1))
|
|
(unless (eobp)
|
|
(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-all (elems)
|
|
(dolist (elem elems)
|
|
(let ((type (plist-get elem :type)))
|
|
(cond
|
|
((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
|
|
(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
|
|
(insert new-contents)
|
|
(when (file-exists-p file-name)
|
|
(rename-file file-name (car (find-backup-file-name file-name))))
|
|
(write-region (point-min) (point-max) file-name)
|
|
(set-file-times file-name (parse-iso8601-time-string date))))
|
|
|
|
(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)))
|
|
((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)))))
|
|
matched))
|
|
|
|
(defun gnus-cloud-all-files ()
|
|
(let ((files nil))
|
|
(dolist (elem gnus-cloud-synced-files)
|
|
(cond
|
|
((stringp elem)
|
|
(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)))))
|
|
(nreverse files)))
|
|
|
|
(defvar gnus-cloud-file-timestamps nil)
|
|
|
|
(defun gnus-cloud-files-to-upload (&optional full)
|
|
(let ((files nil)
|
|
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))))
|
|
(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 (gnus-cloud-timestamp (nth 5 (file-attributes file))))
|
|
(old (cadr (assoc file gnus-cloud-file-timestamps))))
|
|
(when (or full
|
|
(null old)
|
|
(string< old timestamp))
|
|
timestamp)))
|
|
|
|
(declare-function gnus-activate-group "gnus-start"
|
|
(group &optional scan dont-check method dont-sub-check))
|
|
(declare-function gnus-subscribe-group "gnus-start"
|
|
(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)))
|
|
(unless (or (gnus-active gnus-cloud-group-name)
|
|
(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)))))
|
|
|
|
(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 (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))
|
|
(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)))
|
|
(when old
|
|
(setq gnus-cloud-file-timestamps
|
|
(delq old gnus-cloud-file-timestamps)))
|
|
(push (list file-name (plist-get elem :timestamp))
|
|
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)
|
|
(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))))
|
|
(sort (nreverse headers)
|
|
(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))
|
|
(while (and headers
|
|
(not found))
|
|
(when (string-match "type: :full" (mail-header-subject (car headers)))
|
|
(setq found t))
|
|
(pop headers))
|
|
;; All the chunks that are older than the newest :full chunk can be
|
|
;; deleted.
|
|
(when headers
|
|
(gnus-request-expire-articles
|
|
(mapcar (lambda (h)
|
|
(mail-header-number h))
|
|
(nreverse headers))
|
|
(gnus-group-full-name gnus-cloud-group-name gnus-cloud-method)))))
|
|
|
|
(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)
|
|
(dolist (header (gnus-cloud-available-chunks))
|
|
(when (> (gnus-cloud-chunk-sequence (mail-header-subject header))
|
|
(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 "^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 `(:type :newsrc-data :name ,(gnus-info-group info) :contents ,info :timestamp ,(gnus-cloud-timestamp (current-time)))
|
|
infos)))
|
|
infos))
|
|
|
|
(provide 'gnus-cloud)
|
|
|
|
;;; gnus-cloud.el ends here
|