511 lines
20 KiB
EmacsLisp
511 lines
20 KiB
EmacsLisp
;;; gnus-cloud.el --- storing and retrieving data via IMAP -*- lexical-binding: t; -*-
|
||
|
||
;; Copyright (C) 2014-2024 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:
|
||
|
||
;; The name gnus-cloud parodizes but otherwise has little to do with
|
||
;; "cloud computing", a misleading term normally best avoided. See:
|
||
;; https://www.gnu.org/philosophy/words-to-avoid.html#CloudComputing
|
||
|
||
;;; Code:
|
||
|
||
(require 'parse-time)
|
||
(require 'nnimap)
|
||
(require 'range)
|
||
|
||
(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 files that should be kept up-to-date via the cloud.
|
||
Each element may be either a string or a property list.
|
||
The latter should have a :directory element whose value is a string,
|
||
and a :match element whose value is a regular expression to match
|
||
against the basename of files in said directory."
|
||
:type '(repeat (choice (string :tag "File")
|
||
(plist :tag "Property list"))))
|
||
|
||
(defcustom gnus-cloud-storage-method (if (featurep 'epg) 'epg 'base64-gzip)
|
||
"Storage method for cloud data, defaults to EPG if that's available."
|
||
:version "26.1"
|
||
: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."
|
||
:version "26.1"
|
||
: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-set-cloud-method-server' for an
|
||
easy interactive way to set this from the Server buffer."
|
||
: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
|
||
(set-buffer-multibyte nil)
|
||
(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
|
||
;; FIXME: Duplicated value in ‘cond’: base64-gzip.
|
||
((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)
|
||
"Update the newsrc data for GROUP from ELEM."
|
||
(let* ((contents (plist-get elem :contents))
|
||
(date (or (plist-get elem :timestamp) "0"))
|
||
(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)
|
||
(when (or (not gnus-cloud-interactive)
|
||
(gnus-y-or-n-p
|
||
(format "%s has different info in the cloud from %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 nil nil nil 'excl)
|
||
(set-file-times file-name (parse-iso8601-time-string date) 'nofollow)))
|
||
|
||
(defun gnus-cloud-file-covered-p (file-name)
|
||
(let ((matched nil))
|
||
(dolist (elem gnus-cloud-synced-files)
|
||
(cond
|
||
((stringp elem)
|
||
;; This seems fragile. String comparison, with no
|
||
;; expand-file-name to resolve ~, etc.
|
||
(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 (file-attribute-modification-time
|
||
(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))
|
||
|
||
(autoload 'gnus-group-refresh-group "gnus-group")
|
||
|
||
(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)))
|
||
(setq gnus-cloud-sequence (1+ (or gnus-cloud-sequence 0)))
|
||
(insert (format "Subject: (sequence: %s 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))
|
||
(if (gnus-request-accept-article gnus-cloud-group-name gnus-cloud-method
|
||
t t)
|
||
(progn
|
||
(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)))))
|
||
|
||
(defvar gnus-alter-header-function)
|
||
|
||
(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 (range-uncompress active) group)
|
||
(with-current-buffer nntp-server-buffer
|
||
(goto-char (point-min))
|
||
(while (setq head (nnheader-parse-head))
|
||
(when gnus-alter-header-function
|
||
(funcall gnus-alter-header-function 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)
|
||
(highest-sequence-seen gnus-cloud-sequence)
|
||
chunks)
|
||
(dolist (header (gnus-cloud-available-chunks))
|
||
(let ((this-sequence (gnus-cloud-chunk-sequence (mail-header-subject header))))
|
||
(when (> this-sequence (or sequence-override gnus-cloud-sequence -1))
|
||
|
||
(if (string-match (format "storage-method: %s" gnus-cloud-storage-method)
|
||
(mail-header-subject header))
|
||
(progn
|
||
(push (mail-header-number header) articles)
|
||
(setq highest-sequence-seen (max highest-sequence-seen this-sequence)))
|
||
(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
|
||
(prog1 (mapcar #'gnus-cloud-update-all chunks)
|
||
(setq gnus-cloud-sequence highest-sequence-seen))
|
||
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 nil))
|
||
infos)))
|
||
infos))
|
||
|
||
(provide 'gnus-cloud)
|
||
|
||
;;; gnus-cloud.el ends here
|