cgit.sxemacs.org Git - gnus/blob - lisp/gnus-cloud.el

   1 ;;; gnus-cloud.el --- storing and retrieving data via IMAP
   2
   3 ;; Copyright (C) 2014 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
  30 (defgroup gnus-cloud nil
  31   "Syncing Gnus data via IMAP."
  32   :group 'gnus)
  33
  34 (defcustom gnus-cloud-synced-files
  35   '("~/.authinfo"
  36     "~/.authinfo.gpg"
  37     "~/.gnus.el"
  38     (:directory "~/News" :match ".*.SCORE\\'"))
  39   "List of file regexps that should be kept up-to-date via the cloud."
  40   :group 'gnus-cloud
  41   :type '(repeat regexp))
  42
  43 (defvar gnus-cloud-version 1)
  44
  45 (defvar gnus-cloud-method nil
  46   "The IMAP select method used to store the cloud data.")
  47
  48 (defun gnus-cloud-make-chunk (elems)
  49   (with-temp-buffer
  50     (insert (format "Version %s\n" gnus-cloud-version))
  51     (insert (gnus-cloud-insert-data elems))
  52     (buffer-string)))
  53
  54 (defun gnus-cloud-insert-data (elems)
  55   (mm-with-unibyte-buffer
  56     (dolist (elem elems)
  57       (cond
  58        ((eq (plist-get elem :type) :file)
  59         (let (length data)
  60           (mm-with-unibyte-buffer
  61             (insert-file-contents-literally (plist-get elem :file-name))
  62             (setq length (buffer-size)
  63                   data (buffer-string)))
  64           (insert (format "(:type :file :file-name %S :timestamp %S :length %d)\n"
  65                           (plist-get elem :file-name)
  66                           (plist-get elem :timestamp)
  67                           length))
  68           (insert data)
  69           (insert "\n")))
  70        ((eq (plist-get elem :type) :data)
  71         (insert (format "(:type :data :name %S :length %d)\n"
  72                         (plist-get elem :name)
  73                         (with-current-buffer (plist-get elem :buffer)
  74                           (buffer-size))))
  75         (insert-buffer-substring (plist-get elem :buffer))
  76         (insert "\n"))
  77        ((eq (plist-get elem :type) :delete)
  78         (insert (format "(:type :delete :file-name %S)\n"
  79                         (plist-get elem :file-name))))))
  80     (gnus-cloud-encode-data)
  81     (buffer-string)))
  82
  83 (defun gnus-cloud-encode-data ()
  84   (call-process-region (point-min) (point-max) "gzip"
  85                        t (current-buffer) nil
  86                        "-c")
  87   (base64-encode-region (point-min) (point-max)))
  88
  89 (defun gnus-cloud-decode-data ()
  90   (base64-decode-region (point-min) (point-max))
  91   (call-process-region (point-min) (point-max) "gunzip"
  92                        t (current-buffer) nil
  93                        "-c"))
  94
  95 (defun gnus-cloud-parse-chunk ()
  96   (save-excursion
  97     (goto-char (point-min))
  98     (unless (looking-at "Version \\([0-9]+\\)")
  99       (error "Not a valid Cloud chunk in the current buffer"))
 100     (forward-line 1)
 101     (let ((version (string-to-number (match-string 1)))
 102           (data (buffer-substring (point) (point-max))))
 103       (mm-with-unibyte-buffer
 104         (insert data)
 105         (cond
 106          ((= version 1)
 107           (gnus-cloud-decode-data)
 108           (goto-char (point-min))
 109           (gnus-cloud-parse-version-1))
 110          (t
 111           (error "Unsupported Cloud chunk version %s" version)))))))
 112
 113 (defun gnus-cloud-parse-version-1 ()
 114   (let ((elems nil))
 115     (while (not (eobp))
 116       (while (and (not (eobp))
 117                   (not (looking-at "(:type")))
 118         (forward-line 1))
 119       (unless (eobp)
 120         (let ((spec (ignore-errors (read (current-buffer))))
 121               length)
 122           (when (and (consp spec)
 123                      (memq (getf spec :type) '(:file :data :deleta)))
 124             (setq length (plist-get spec :length))
 125             (push (append spec
 126                           (list
 127                            :contents (buffer-substring (1+ (point))
 128                                                        (+ (point) 1 length))))
 129                   elems)
 130             (goto-char (+ (point) 1 length))))))
 131     (nreverse elems)))
 132
 133 (defun gnus-cloud-update-data (elems)
 134   (dolist (elem elems)
 135     (let ((type (plist-get elem :type)))
 136       (cond
 137        ((eq type :data)
 138         )
 139        ((eq type :delete)
 140         (gnus-cloud-delete-file (plist-get elem :file-name))
 141         )
 142        ((eq type :file)
 143         (gnus-cloud-update-file elem))
 144        (t
 145         (message "Unknown type %s; ignoring" type))))))
 146
 147 (defun gnus-cloud-update-file (elem)
 148   (let ((file-name (plist-get elem :file-name))
 149         (date (plist-get elem :timestamp))
 150         (contents (plist-get elem :contents)))
 151     (unless (gnus-cloud-file-covered-p file-name)
 152       (message "%s isn't covered by the cloud; ignoring" file-name))
 153     (when (or (not (file-exists-p file-name))
 154               (and (file-exists-p file-name)
 155                    (mm-with-unibyte-buffer
 156                      (insert-file-contents-literally file-name)
 157                      (not (equal (buffer-string) contents)))))
 158       (gnus-cloud-replace-file file-name date contents))))
 159
 160 (defun gnus-cloud-replace-file (file-name date new-contents)
 161   (mm-with-unibyte-buffer
 162     (insert new-contents)
 163     (when (file-exists-p file-name)
 164       (rename-file file-name (car (find-backup-file-name file-name))))
 165     (write-region (point-min) (point-max) file-name)
 166     (set-file-times file-name (parse-iso8601-time-string date))))
 167
 168 (defun gnus-cloud-delete-file (file-name)
 169   (unless (gnus-cloud-file-covered-p file-name)
 170     (message "%s isn't covered by the cloud; ignoring" file-name))
 171   (when (file-exists-p file-name)
 172     (rename-file file-name (car (find-backup-file-name file-name)))))
 173
 174 (defun gnus-cloud-file-covered-p (file-name)
 175   (let ((matched nil))
 176     (dolist (elem gnus-cloud-synced-files)
 177       (cond
 178        ((stringp elem)
 179         (when (equal elem file-name)
 180           (setq matched t)))
 181        ((consp elem)
 182         (when (and (equal (directory-file-name (plist-get elem :directory))
 183                           (directory-file-name (file-name-directory file-name)))
 184                    (string-match (plist-get elem :match)
 185                                  (file-name-nondirectory file-name)))
 186           (setq matched t)))))
 187     matched))
 188
 189 (defun gnus-cloud-all-files ()
 190   (let ((files nil))
 191     (dolist (elem gnus-cloud-synced-files)
 192       (cond
 193        ((stringp elem)
 194         (push elem files))
 195        ((consp elem)
 196         (dolist (file (directory-files (plist-get elem :directory)
 197                                        nil
 198                                        (plist-get elem :match)))
 199           (push (format "%s/%s"
 200                         (directory-file-name (plist-get elem :directory))
 201                         file)
 202                 files)))))
 203     (nreverse files)))
 204
 205 (defvar gnus-cloud-file-timestamps nil)
 206
 207 (defun gnus-cloud-files-to-upload (&optional full)
 208   (let ((files nil)
 209         timestamp)
 210     (dolist (file (gnus-cloud-all-files))
 211       (if (file-exists-p file)
 212           (when (setq timestamp (gnus-cloud-file-new-p file full))
 213             (push `(:type :file :file-name ,file :timestamp ,timestamp) files))
 214         (when (assoc file gnus-cloud-file-timestamps)
 215           (push `(:type :delete :file-name ,file) files))))
 216     (nreverse files)))
 217
 218 (defun gnus-cloud-file-new-p (file full)
 219   (let ((timestamp (format-time-string
 220                     "%FT%T%z" (nth 5 (file-attributes file))))
 221         (old (cadr (assoc file gnus-cloud-file-timestamps))))
 222     (when (or full
 223               (null old)
 224               (string< old timestamp))
 225       timestamp)))
 226
 227 (provide 'gnus-cloud)
 228
 229 ;;; gnus-cloud.el ends here