lisp/gnus/gnus-cloud.el

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