code.delx.au - gnu-emacs/blob - lisp/gnus/gnus-cloud.el

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