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-group-name "*Emacs Cloud*")
  44
  45 (defvar gnus-cloud-version 1)
  46 (defvar gnus-cloud-sequence 1)
  47
  48 (defvar gnus-cloud-method nil
  49   "The IMAP select method used to store the cloud data.")
  50
  51 (defun gnus-cloud-make-chunk (elems)
  52   (with-temp-buffer
  53     (insert (format "Version %s\n" gnus-cloud-version))
  54     (insert (gnus-cloud-insert-data elems))
  55     (buffer-string)))
  56
  57 (defun gnus-cloud-insert-data (elems)
  58   (mm-with-unibyte-buffer
  59     (dolist (elem elems)
  60       (cond
  61        ((eq (plist-get elem :type) :file)
  62         (let (length data)
  63           (mm-with-unibyte-buffer
  64             (insert-file-contents-literally (plist-get elem :file-name))
  65             (setq length (buffer-size)
  66                   data (buffer-string)))
  67           (insert (format "(:type :file :file-name %S :timestamp %S :length %d)\n"
  68                           (plist-get elem :file-name)
  69                           (plist-get elem :timestamp)
  70                           length))
  71           (insert data)
  72           (insert "\n")))
  73        ((eq (plist-get elem :type) :data)
  74         (insert (format "(:type :data :name %S :length %d)\n"
  75                         (plist-get elem :name)
  76                         (with-current-buffer (plist-get elem :buffer)
  77                           (buffer-size))))
  78         (insert-buffer-substring (plist-get elem :buffer))
  79         (insert "\n"))
  80        ((eq (plist-get elem :type) :delete)
  81         (insert (format "(:type :delete :file-name %S)\n"
  82                         (plist-get elem :file-name))))))
  83     (gnus-cloud-encode-data)
  84     (buffer-string)))
  85
  86 (defun gnus-cloud-encode-data ()
  87   (call-process-region (point-min) (point-max) "gzip"
  88                        t (current-buffer) nil
  89                        "-c")
  90   (base64-encode-region (point-min) (point-max)))
  91
  92 (defun gnus-cloud-decode-data ()
  93   (base64-decode-region (point-min) (point-max))
  94   (call-process-region (point-min) (point-max) "gunzip"
  95                        t (current-buffer) nil
  96                        "-c"))
  97
  98 (defun gnus-cloud-parse-chunk ()
  99   (save-excursion
 100     (goto-char (point-min))
 101     (unless (looking-at "Version \\([0-9]+\\)")
 102       (error "Not a valid Cloud chunk in the current buffer"))
 103     (forward-line 1)
 104     (let ((version (string-to-number (match-string 1)))
 105           (data (buffer-substring (point) (point-max))))
 106       (mm-with-unibyte-buffer
 107         (insert data)
 108         (cond
 109          ((= version 1)
 110           (gnus-cloud-decode-data)
 111           (goto-char (point-min))
 112           (gnus-cloud-parse-version-1))
 113          (t
 114           (error "Unsupported Cloud chunk version %s" version)))))))
 115
 116 (defun gnus-cloud-parse-version-1 ()
 117   (let ((elems nil))
 118     (while (not (eobp))
 119       (while (and (not (eobp))
 120                   (not (looking-at "(:type")))
 121         (forward-line 1))
 122       (unless (eobp)
 123         (let ((spec (ignore-errors (read (current-buffer))))
 124               length)
 125           (when (and (consp spec)
 126                      (memq (getf spec :type) '(:file :data :deleta)))
 127             (setq length (plist-get spec :length))
 128             (push (append spec
 129                           (list
 130                            :contents (buffer-substring (1+ (point))
 131                                                        (+ (point) 1 length))))
 132                   elems)
 133             (goto-char (+ (point) 1 length))))))
 134     (nreverse elems)))
 135
 136 (defun gnus-cloud-update-data (elems)
 137   (dolist (elem elems)
 138     (let ((type (plist-get elem :type)))
 139       (cond
 140        ((eq type :data)
 141         )
 142        ((eq type :delete)
 143         (gnus-cloud-delete-file (plist-get elem :file-name))
 144         )
 145        ((eq type :file)
 146         (gnus-cloud-update-file elem))
 147        (t
 148         (message "Unknown type %s; ignoring" type))))))
 149
 150 (defun gnus-cloud-update-file (elem)
 151   (let ((file-name (plist-get elem :file-name))
 152         (date (plist-get elem :timestamp))
 153         (contents (plist-get elem :contents)))
 154     (unless (gnus-cloud-file-covered-p file-name)
 155       (message "%s isn't covered by the cloud; ignoring" file-name))
 156     (when (or (not (file-exists-p file-name))
 157               (and (file-exists-p file-name)
 158                    (mm-with-unibyte-buffer
 159                      (insert-file-contents-literally file-name)
 160                      (not (equal (buffer-string) contents)))))
 161       (gnus-cloud-replace-file file-name date contents))))
 162
 163 (defun gnus-cloud-replace-file (file-name date new-contents)
 164   (mm-with-unibyte-buffer
 165     (insert new-contents)
 166     (when (file-exists-p file-name)
 167       (rename-file file-name (car (find-backup-file-name file-name))))
 168     (write-region (point-min) (point-max) file-name)
 169     (set-file-times file-name (parse-iso8601-time-string date))))
 170
 171 (defun gnus-cloud-delete-file (file-name)
 172   (unless (gnus-cloud-file-covered-p file-name)
 173     (message "%s isn't covered by the cloud; ignoring" file-name))
 174   (when (file-exists-p file-name)
 175     (rename-file file-name (car (find-backup-file-name file-name)))))
 176
 177 (defun gnus-cloud-file-covered-p (file-name)
 178   (let ((matched nil))
 179     (dolist (elem gnus-cloud-synced-files)
 180       (cond
 181        ((stringp elem)
 182         (when (equal elem file-name)
 183           (setq matched t)))
 184        ((consp elem)
 185         (when (and (equal (directory-file-name (plist-get elem :directory))
 186                           (directory-file-name (file-name-directory file-name)))
 187                    (string-match (plist-get elem :match)
 188                                  (file-name-nondirectory file-name)))
 189           (setq matched t)))))
 190     matched))
 191
 192 (defun gnus-cloud-all-files ()
 193   (let ((files nil))
 194     (dolist (elem gnus-cloud-synced-files)
 195       (cond
 196        ((stringp elem)
 197         (push elem files))
 198        ((consp elem)
 199         (dolist (file (directory-files (plist-get elem :directory)
 200                                        nil
 201                                        (plist-get elem :match)))
 202           (push (format "%s/%s"
 203                         (directory-file-name (plist-get elem :directory))
 204                         file)
 205                 files)))))
 206     (nreverse files)))
 207
 208 (defvar gnus-cloud-file-timestamps nil)
 209
 210 (defun gnus-cloud-files-to-upload (&optional full)
 211   (let ((files nil)
 212         timestamp)
 213     (dolist (file (gnus-cloud-all-files))
 214       (if (file-exists-p file)
 215           (when (setq timestamp (gnus-cloud-file-new-p file full))
 216             (push `(:type :file :file-name ,file :timestamp ,timestamp) files))
 217         (when (assoc file gnus-cloud-file-timestamps)
 218           (push `(:type :delete :file-name ,file) files))))
 219     (nreverse files)))
 220
 221 (defun gnus-cloud-file-new-p (file full)
 222   (let ((timestamp (format-time-string
 223                     "%FT%T%z" (nth 5 (file-attributes file))))
 224         (old (cadr (assoc file gnus-cloud-file-timestamps))))
 225     (when (or full
 226               (null old)
 227               (string< old timestamp))
 228       timestamp)))
 229
 230 (defun gnus-cloud-ensure-cloud-group ()
 231   (let ((method (if (stringp gnus-cloud-method)
 232                     (gnus-server-to-method gnus-cloud-method)
 233                   gnus-cloud-method)))
 234     (unless (or (gnus-active gnus-cloud-group-name)
 235                 (gnus-activate-group gnus-cloud-group-name nil nil
 236                                      gnus-cloud-method))
 237       (and (gnus-request-create-group gnus-cloud-group-name gnus-cloud-method)
 238            (gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method)
 239            (gnus-subscribe-group gnus-cloud-group-name)))))
 240
 241 (defun gnus-cloud-upload-data ()
 242   (gnus-cloud-ensure-cloud-group)
 243   (with-temp-buffer
 244     (let* ((full t)
 245            (elems (gnus-cloud-files-to-upload full)))
 246       (insert (format "Subject: (sequence: %d type: %s)\n"
 247                       gnus-cloud-sequence
 248                       (if full :full :partial)))
 249       (insert "From: nobody@invalid.com\n")
 250       (insert "\n")
 251       (insert (gnus-cloud-make-chunk elems))
 252       (gnus-request-accept-article gnus-cloud-group-name gnus-cloud-method
 253                                    t t))))
 254
 255 (defun gnus-cloud-available-chunks ()
 256   (gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method)
 257   (let* ((group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method))
 258          (active (gnus-active group))
 259          headers head)
 260     (when (gnus-retrieve-headers (gnus-uncompress-range active) group)
 261       (with-current-buffer nntp-server-buffer
 262         (goto-char (point-min))
 263         (while (and (not (eobp))
 264                     (setq head (nnheader-parse-head)))
 265           (push head headers))))
 266     (nreverse headers)))
 267
 268 (defun gnus-cloud-chunk-sequence (string)
 269   (if (string-match "sequence: \\([0-9]+\\)" string)
 270       (string-to-number (match-string 1 string))
 271     0))
 272
 273 (defun gnus-cloud-prune-old-chunks (headers)
 274   (let ((headers
 275          (sort (reverse headers)
 276                (lambda (h1 h2)
 277                  (> (gnus-cloud-chunk-sequence (mail-header-subject h1))
 278                     (gnus-cloud-chunk-sequence (mail-header-subject h2))))))
 279         (found nil))
 280   (while (and headers
 281               (not found))
 282     (when (string-match "type: :full" (mail-header-subject (car headers)))
 283       (setq found t))
 284     (pop headers))
 285   ;; All the chunks that are older than the newest :full chunk can be
 286   ;; deleted.
 287   (when headers
 288     (gnus-request-expire-articles
 289      (mapcar (lambda (h)
 290                (mail-header-number h))
 291              (nreverse headers))
 292      (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method)))))
 293
 294 (provide 'gnus-cloud)
 295
 296 ;;; gnus-cloud.el ends here