lisp/gnus/gnus-cloud.el

   1 ;;; gnus-cloud.el --- storing and retrieving data via IMAP
   2
   3 ;; Copyright (C) 2014-2018 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;; Keywords: mail
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; The name gnus-cloud parodizes but otherwise has little to do with
  26 ;; "cloud computing", a misleading term normally best avoided.  See:
  27 ;; https://www.gnu.org/philosophy/words-to-avoid.html#CloudComputing
  28
  29 ;;; Code:
  30
  31 (eval-when-compile (require 'cl))
  32 (require 'parse-time)
  33 (require 'nnimap)
  34
  35 (eval-when-compile (require 'epg)) ;; setf-method for `epg-context-armor'
  36 (autoload 'epg-make-context "epg")
  37 (autoload 'epg-context-set-passphrase-callback "epg")
  38 (autoload 'epg-decrypt-string "epg")
  39 (autoload 'epg-encrypt-string "epg")
  40
  41 (defgroup gnus-cloud nil
  42   "Syncing Gnus data via IMAP."
  43   :version "25.1"
  44   :group 'gnus)
  45
  46 (defcustom gnus-cloud-synced-files
  47   '(;;"~/.authinfo"
  48     "~/.authinfo.gpg"
  49     "~/.gnus.el"
  50     (:directory "~/News" :match ".*.SCORE\\'"))
  51   "List of file regexps that should be kept up-to-date via the cloud."
  52   :group 'gnus-cloud
  53   ;; FIXME this type does not match the default.  Nor does the documentation.
  54   :type '(repeat regexp))
  55
  56 (defcustom gnus-cloud-storage-method (if (featurep 'epg) 'epg 'base64-gzip)
  57   "Storage method for cloud data, defaults to EPG if that's available."
  58   :version "26.1"
  59   :group 'gnus-cloud
  60   :type '(radio (const :tag "No encoding" nil)
  61                 (const :tag "Base64" base64)
  62                 (const :tag "Base64+gzip" base64-gzip)
  63                 (const :tag "EPG" epg)))
  64
  65 (defcustom gnus-cloud-interactive t
  66   "Whether Gnus Cloud changes should be confirmed."
  67   :version "26.1"
  68   :group 'gnus-cloud
  69   :type 'boolean)
  70
  71 (defvar gnus-cloud-group-name "Emacs-Cloud")
  72 (defvar gnus-cloud-covered-servers nil)
  73
  74 (defvar gnus-cloud-version 1)
  75 (defvar gnus-cloud-sequence 1)
  76
  77 (defcustom gnus-cloud-method nil
  78   "The IMAP select method used to store the cloud data.
  79 See also `gnus-server-toggle-cloud-method-server' for an
  80 easy interactive way to set this from the Server buffer."
  81   :group 'gnus-cloud
  82   :type '(radio (const :tag "Not set" nil)
  83                 (string :tag "A Gnus server name as a string")))
  84
  85 (defun gnus-cloud-make-chunk (elems)
  86   (with-temp-buffer
  87     (insert (format "Gnus-Cloud-Version %s\n" gnus-cloud-version))
  88     (insert (gnus-cloud-insert-data elems))
  89     (buffer-string)))
  90
  91 (defun gnus-cloud-insert-data (elems)
  92   (mm-with-unibyte-buffer
  93     (dolist (elem elems)
  94       (cond
  95        ((eq (plist-get elem :type) :file)
  96         (let (length data)
  97           (mm-with-unibyte-buffer
  98             (insert-file-contents-literally (plist-get elem :file-name))
  99             (setq length (buffer-size)
 100                   data (buffer-string)))
 101           (insert (format "(:type :file :file-name %S :timestamp %S :length %d)\n"
 102                           (plist-get elem :file-name)
 103                           (plist-get elem :timestamp)
 104                           length))
 105           (insert data)
 106           (insert "\n")))
 107        ((eq (plist-get elem :type) :newsrc-data)
 108         (let ((print-level nil)
 109               (print-length nil))
 110           (print elem (current-buffer)))
 111         (insert "\n"))
 112        ((eq (plist-get elem :type) :delete)
 113         (insert (format "(:type :delete :file-name %S)\n"
 114                         (plist-get elem :file-name))))))
 115     (gnus-cloud-encode-data)
 116     (buffer-string)))
 117
 118 (defun gnus-cloud-encode-data ()
 119   (cond
 120    ((eq gnus-cloud-storage-method 'base64-gzip)
 121     (progn
 122       (call-process-region (point-min) (point-max) "gzip"
 123                            t (current-buffer) nil
 124                            "-c")
 125       (base64-encode-region (point-min) (point-max))))
 126
 127    ((eq gnus-cloud-storage-method 'base64)
 128     (base64-encode-region (point-min) (point-max)))
 129
 130    ((eq gnus-cloud-storage-method 'epg)
 131     (let ((context (epg-make-context 'OpenPGP))
 132           cipher)
 133       (setf (epg-context-armor context) t)
 134       (setf (epg-context-textmode context) t)
 135       (let ((data (epg-encrypt-string context
 136                                       (buffer-substring-no-properties
 137                                        (point-min)
 138                                        (point-max))
 139                                       nil)))
 140         (delete-region (point-min) (point-max))
 141         (insert data))))
 142
 143    ((null gnus-cloud-storage-method)
 144     (gnus-message 5 "Leaving cloud data plaintext"))
 145    (t (gnus-error 1 "Invalid cloud storage method %S"
 146                   gnus-cloud-storage-method))))
 147
 148 (defun gnus-cloud-decode-data ()
 149   (cond
 150    ((memq gnus-cloud-storage-method '(base64 base64-gzip))
 151     (base64-decode-region (point-min) (point-max)))
 152
 153    ((eq gnus-cloud-storage-method 'base64-gzip)
 154     (call-process-region (point-min) (point-max) "gunzip"
 155                          t (current-buffer) nil
 156                          "-c"))
 157
 158    ((eq gnus-cloud-storage-method 'epg)
 159     (let* ((context (epg-make-context 'OpenPGP))
 160            (data (epg-decrypt-string context (buffer-substring-no-properties
 161                                               (point-min)
 162                                               (point-max)))))
 163       (delete-region (point-min) (point-max))
 164       (insert data)))
 165
 166    ((null gnus-cloud-storage-method)
 167     (gnus-message 5 "Reading cloud data as plaintext"))
 168
 169    (t (gnus-error 1 "Invalid cloud storage method %S"
 170                   gnus-cloud-storage-method))))
 171
 172 (defun gnus-cloud-parse-chunk ()
 173   (save-excursion
 174     (unless (looking-at "Gnus-Cloud-Version \\([0-9]+\\)")
 175       (error "Not a valid Cloud chunk in the current buffer"))
 176     (forward-line 1)
 177     (let ((version (string-to-number (match-string 1)))
 178           (data (buffer-substring (point) (point-max))))
 179       (mm-with-unibyte-buffer
 180         (insert data)
 181         (cond
 182          ((= version 1)
 183           (gnus-cloud-decode-data)
 184           (goto-char (point-min))
 185           (gnus-cloud-parse-version-1))
 186          (t
 187           (error "Unsupported Cloud chunk version %s" version)))))))
 188
 189 (defun gnus-cloud-parse-version-1 ()
 190   (let ((elems nil))
 191     (while (not (eobp))
 192       (while (and (not (eobp))
 193                   (not (looking-at "(:type")))
 194         (forward-line 1))
 195       (unless (eobp)
 196         (let ((spec (ignore-errors (read (current-buffer))))
 197               length)
 198           (when (consp spec)
 199             (cond
 200              ((memq (plist-get spec :type) '(:file :delete))
 201               (setq length (plist-get spec :length))
 202               (push (append spec
 203                             (list
 204                              :contents (buffer-substring (1+ (point))
 205                                                          (+ (point) 1 length))))
 206                     elems)
 207               (goto-char (+ (point) 1 length)))
 208              ((memq (plist-get spec :type) '(:newsrc-data))
 209               (push spec elems)))))))
 210     (nreverse elems)))
 211
 212 (defun gnus-cloud-update-all (elems)
 213   (dolist (elem elems)
 214     (let ((type (plist-get elem :type)))
 215       (cond
 216        ((eq type :newsrc-data)
 217         (gnus-cloud-update-newsrc-data (plist-get elem :name) elem))
 218        ((memq type '(:delete :file))
 219         (gnus-cloud-update-file elem type))
 220        (t
 221         (gnus-message 1 "Unknown type %s; ignoring" type))))))
 222
 223 (defun gnus-cloud-update-newsrc-data (group elem &optional force-older)
 224   "Update the newsrc data for GROUP from ELEM.
 225 Use old data if FORCE-OLDER is not nil."
 226   (let* ((contents (plist-get elem :contents))
 227          (date (or (plist-get elem :timestamp) "0"))
 228          (now (gnus-cloud-timestamp (current-time)))
 229          (newer (string-lessp date now))
 230          (group-info (gnus-get-info group)))
 231     (if (and contents
 232              (stringp (nth 0 contents))
 233              (integerp (nth 1 contents)))
 234         (if group-info
 235             (if (equal (format "%S" group-info)
 236                        (format "%S" contents))
 237                 (gnus-message 3 "Skipping cloud update of group %s, the info is the same" group)
 238               (if (and newer (not force-older))
 239                 (gnus-message 3 "Skipping outdated cloud info for group %s, the info is from %s (now is %s)" group date now)
 240                 (when (or (not gnus-cloud-interactive)
 241                           (gnus-y-or-n-p
 242                            (format "%s has older different info in the cloud as of %s, update it here? "
 243                                    group date))))
 244                 (gnus-message 2 "Installing cloud update of group %s" group)
 245                 (gnus-set-info group contents)
 246                 (gnus-group-update-group group)))
 247           (gnus-error 1 "Sorry, group %s is not subscribed" group))
 248       (gnus-error 1 "Sorry, could not update newsrc for group %s (invalid data %S)"
 249                   group elem))))
 250
 251 (defun gnus-cloud-update-file (elem op)
 252   "Apply Gnus Cloud data ELEM and operation OP to a file."
 253   (let* ((file-name (plist-get elem :file-name))
 254          (date (plist-get elem :timestamp))
 255          (contents (plist-get elem :contents))
 256          (exists (file-exists-p file-name)))
 257     (if (gnus-cloud-file-covered-p file-name)
 258         (cond
 259          ((eq op :delete)
 260           (if (and exists
 261                    ;; prompt only if the file exists already
 262                    (or (not gnus-cloud-interactive)
 263                        (gnus-y-or-n-p (format "%s has been deleted as of %s, delete it locally? "
 264                                               file-name date))))
 265               (rename-file file-name (car (find-backup-file-name file-name)))
 266             (gnus-message 3 "%s was already deleted before the cloud got it" file-name)))
 267          ((eq op :file)
 268           (when (or (not exists)
 269                     (and exists
 270                          (mm-with-unibyte-buffer
 271                            (insert-file-contents-literally file-name)
 272                            (not (equal (buffer-string) contents)))
 273                          ;; prompt only if the file exists already
 274                          (or (not gnus-cloud-interactive)
 275                              (gnus-y-or-n-p (format "%s has updated contents as of %s, update it? "
 276                                                     file-name date)))))
 277             (gnus-cloud-replace-file file-name date contents))))
 278       (gnus-message 2 "%s isn't covered by the cloud; ignoring" file-name))))
 279
 280 (defun gnus-cloud-replace-file (file-name date new-contents)
 281   (mm-with-unibyte-buffer
 282     (insert new-contents)
 283     (when (file-exists-p file-name)
 284       (rename-file file-name (car (find-backup-file-name file-name))))
 285     (write-region (point-min) (point-max) file-name)
 286     (set-file-times file-name (parse-iso8601-time-string date))))
 287
 288 (defun gnus-cloud-file-covered-p (file-name)
 289   (let ((matched nil))
 290     (dolist (elem gnus-cloud-synced-files)
 291       (cond
 292        ((stringp elem)
 293         (when (equal elem file-name)
 294           (setq matched t)))
 295        ((consp elem)
 296         (when (and (equal (directory-file-name (plist-get elem :directory))
 297                           (directory-file-name (file-name-directory file-name)))
 298                    (string-match (plist-get elem :match)
 299                                  (file-name-nondirectory file-name)))
 300           (setq matched t)))))
 301     matched))
 302
 303 (defun gnus-cloud-all-files ()
 304   (let ((files nil))
 305     (dolist (elem gnus-cloud-synced-files)
 306       (cond
 307        ((stringp elem)
 308         (push elem files))
 309        ((consp elem)
 310         (dolist (file (directory-files (plist-get elem :directory)
 311                                        nil
 312                                        (plist-get elem :match)))
 313           (push (format "%s/%s"
 314                         (directory-file-name (plist-get elem :directory))
 315                         file)
 316                 files)))))
 317     (nreverse files)))
 318
 319 (defvar gnus-cloud-file-timestamps nil)
 320
 321 (defun gnus-cloud-files-to-upload (&optional full)
 322   (let ((files nil)
 323         timestamp)
 324     (dolist (file (gnus-cloud-all-files))
 325       (if (file-exists-p file)
 326           (when (setq timestamp (gnus-cloud-file-new-p file full))
 327             (push `(:type :file :file-name ,file :timestamp ,timestamp) files))
 328         (when (assoc file gnus-cloud-file-timestamps)
 329           (push `(:type :delete :file-name ,file) files))))
 330     (nreverse files)))
 331
 332 (defun gnus-cloud-timestamp (time)
 333   "Return a general timestamp string for TIME."
 334   (format-time-string "%FT%T%z" time))
 335
 336 (defun gnus-cloud-file-new-p (file full)
 337   (let ((timestamp (gnus-cloud-timestamp (nth 5 (file-attributes file))))
 338         (old (cadr (assoc file gnus-cloud-file-timestamps))))
 339     (when (or full
 340               (null old)
 341               (string< old timestamp))
 342       timestamp)))
 343
 344 (declare-function gnus-activate-group "gnus-start"
 345                   (group &optional scan dont-check method dont-sub-check))
 346 (declare-function gnus-subscribe-group "gnus-start"
 347                   (group &optional previous method))
 348
 349 (defun gnus-cloud-ensure-cloud-group ()
 350   (let ((method (if (stringp gnus-cloud-method)
 351                     (gnus-server-to-method gnus-cloud-method)
 352                   gnus-cloud-method)))
 353     (unless (or (gnus-active gnus-cloud-group-name)
 354                 (gnus-activate-group gnus-cloud-group-name nil nil
 355                                      gnus-cloud-method))
 356       (and (gnus-request-create-group gnus-cloud-group-name gnus-cloud-method)
 357            (gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method)
 358            (gnus-subscribe-group gnus-cloud-group-name)))))
 359
 360 (defun gnus-cloud-upload-all-data ()
 361   "Upload all data (newsrc and files) to the Gnus Cloud."
 362   (interactive)
 363   (gnus-cloud-upload-data t))
 364
 365 (defun gnus-cloud-upload-data (&optional full)
 366   "Upload data (newsrc and files) to the Gnus Cloud.
 367 When FULL is t, upload everything, not just a difference from the last full."
 368   (interactive)
 369   (gnus-cloud-ensure-cloud-group)
 370   (with-temp-buffer
 371     (let ((elems (append
 372                   (gnus-cloud-files-to-upload full)
 373                   (gnus-cloud-collect-full-newsrc)))
 374           (group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method)))
 375       (insert (format "Subject: (sequence: %s type: %s storage-method: %s)\n"
 376                       (or gnus-cloud-sequence "UNKNOWN")
 377                       (if full :full :partial)
 378                       gnus-cloud-storage-method))
 379       (insert "From: nobody@gnus.cloud.invalid\n")
 380       (insert "\n")
 381       (insert (gnus-cloud-make-chunk elems))
 382       (if (gnus-request-accept-article gnus-cloud-group-name gnus-cloud-method
 383                                        t t)
 384           (progn
 385             (setq gnus-cloud-sequence (1+ (or gnus-cloud-sequence 0)))
 386             (gnus-cloud-add-timestamps elems)
 387             (gnus-message 3 "Uploaded Gnus Cloud data successfully to %s" group)
 388             (gnus-group-refresh-group group))
 389         (gnus-error 2 "Failed to upload Gnus Cloud data to %s" group)))))
 390
 391 (defun gnus-cloud-add-timestamps (elems)
 392   (dolist (elem elems)
 393     (let* ((file-name (plist-get elem :file-name))
 394            (old (assoc file-name gnus-cloud-file-timestamps)))
 395       (when old
 396         (setq gnus-cloud-file-timestamps
 397               (delq old gnus-cloud-file-timestamps)))
 398       (push (list file-name (plist-get elem :timestamp))
 399             gnus-cloud-file-timestamps))))
 400
 401 (defun gnus-cloud-available-chunks ()
 402   (gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method)
 403   (let* ((group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method))
 404          (active (gnus-active group))
 405          headers head)
 406     (when (gnus-retrieve-headers (gnus-uncompress-range active) group)
 407       (with-current-buffer nntp-server-buffer
 408         (goto-char (point-min))
 409         (while (and (not (eobp))
 410                     (setq head (nnheader-parse-head)))
 411           (push head headers))))
 412     (sort (nreverse headers)
 413           (lambda (h1 h2)
 414             (> (gnus-cloud-chunk-sequence (mail-header-subject h1))
 415                (gnus-cloud-chunk-sequence (mail-header-subject h2)))))))
 416
 417 (defun gnus-cloud-chunk-sequence (string)
 418   (if (string-match "sequence: \\([0-9]+\\)" string)
 419       (string-to-number (match-string 1 string))
 420     0))
 421
 422 ;; TODO: use this
 423 (defun gnus-cloud-prune-old-chunks (headers)
 424   (let ((headers (reverse headers))
 425         (found nil))
 426   (while (and headers
 427               (not found))
 428     (when (string-match "type: :full" (mail-header-subject (car headers)))
 429       (setq found t))
 430     (pop headers))
 431   ;; All the chunks that are older than the newest :full chunk can be
 432   ;; deleted.
 433   (when headers
 434     (gnus-request-expire-articles
 435      (mapcar (lambda (h)
 436                (mail-header-number h))
 437              (nreverse headers))
 438      (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method)))))
 439
 440 (defun gnus-cloud-download-all-data ()
 441   "Download the Gnus Cloud data and install it.
 442 Starts at `gnus-cloud-sequence' in the sequence."
 443   (interactive)
 444   (gnus-cloud-download-data t))
 445
 446 (defun gnus-cloud-download-data (&optional update sequence-override)
 447   "Download the Gnus Cloud data and install it if UPDATE is t.
 448 When SEQUENCE-OVERRIDE is given, start at that sequence number
 449 instead of `gnus-cloud-sequence'.
 450
 451 When UPDATE is t, returns the result of calling `gnus-cloud-update-all'.
 452 Otherwise, returns the Gnus Cloud data chunks."
 453   (let ((articles nil)
 454         chunks)
 455     (dolist (header (gnus-cloud-available-chunks))
 456       (when (> (gnus-cloud-chunk-sequence (mail-header-subject header))
 457                (or sequence-override gnus-cloud-sequence -1))
 458
 459         (if (string-match (format "storage-method: %s" gnus-cloud-storage-method)
 460                           (mail-header-subject header))
 461             (push (mail-header-number header) articles)
 462           (gnus-message 1 "Skipping article %s because it didn't match the Gnus Cloud method %s: %s"
 463                         (mail-header-number header)
 464                         gnus-cloud-storage-method
 465                         (mail-header-subject header)))))
 466     (when articles
 467       (nnimap-request-articles (nreverse articles) gnus-cloud-group-name)
 468       (with-current-buffer nntp-server-buffer
 469         (goto-char (point-min))
 470         (while (re-search-forward "^Gnus-Cloud-Version " nil t)
 471           (beginning-of-line)
 472           (push (gnus-cloud-parse-chunk) chunks)
 473           (forward-line 1))))
 474     (if update
 475         (mapcar #'gnus-cloud-update-all chunks)
 476       chunks)))
 477
 478 (defun gnus-cloud-server-p (server)
 479   (member server gnus-cloud-covered-servers))
 480
 481 (defun gnus-cloud-host-server-p (server)
 482   (equal gnus-cloud-method server))
 483
 484 (defun gnus-cloud-host-acceptable-method-p (server)
 485   (eq (car-safe (gnus-server-to-method server)) 'nnimap))
 486
 487 (defun gnus-cloud-collect-full-newsrc ()
 488   "Collect all the Gnus newsrc data in a portable format."
 489   (let ((infos nil))
 490     (dolist (info (cdr gnus-newsrc-alist))
 491       (when (gnus-cloud-server-p
 492              (gnus-method-to-server
 493               (gnus-find-method-for-group (gnus-info-group info))))
 494
 495         (push `(:type :newsrc-data :name ,(gnus-info-group info) :contents ,info :timestamp ,(gnus-cloud-timestamp (current-time)))
 496               infos)))
 497     infos))
 498
 499 (provide 'gnus-cloud)
 500
 501 ;;; gnus-cloud.el ends here