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
  29 (defgroup gnus-cloud nil
  30   "Syncing Gnus data via IMAP."
  31   :group 'gnus)
  32
  33 (defcustom gnus-cloud-synced-files '("~/\\.authinfo"
  34                                      "~/\\.authinfo\\.gpg"
  35                                      "~/\\.gnus\\.el"
  36                                      "~/News/.*.SCORE")
  37   "List of file regexps that should be kept up-to-date via the cloud."
  38   :group 'gnus-cloud
  39   :type '(repeat regexp))
  40
  41 (defvar gnus-cloud-version 1)
  42
  43 (defvar gnus-cloud-method nil
  44   "The IMAP select method used to store the cloud data.")
  45
  46 (defun gnus-cloud-make-chunk (elems)
  47   (with-temp-buffer
  48     (insert (format "Version %s\n" gnus-cloud-version))
  49     (insert (gnus-cloud-insert-data elems))
  50     (buffer-string)))
  51
  52 (defun gnus-cloud-insert-data (elems)
  53   (mm-with-unibyte-buffer
  54     (dolist (elem elems)
  55       (cond
  56        ((eq (car elem) :file)
  57         (let (length data)
  58           (mm-with-unibyte-buffer
  59             (insert-file-contents-literally (cadr elem))
  60             (setq length (buffer-size)
  61                   data (buffer-string)))
  62           (insert (format "(:file %S %S %d)\n"
  63                           (cadr elem)
  64                           (format-time-string
  65                            "%FT%T%z" (nth 5 (file-attributes (cadr elem))))
  66                           length))
  67           (insert data)
  68           (insert "\n")))
  69        ((eq (car elem) :buffer)
  70         (insert (format "(:data %S %d)\n" (cadr elem)
  71                         (with-current-buffer (caddr elem)
  72                           (buffer-size))))
  73         (insert-buffer-substring (caddr elem))
  74         (insert "\n"))))
  75     (gnus-cloud-encode-data)
  76     (buffer-string)))
  77
  78 (defun gnus-cloud-encode-data ()
  79   (call-process-region (point-min) (point-max) "gzip"
  80                        t (current-buffer) nil
  81                        "-c")
  82   (base64-encode-region (point-min) (point-max)))
  83
  84 (defun gnus-cloud-decode-data ()
  85   (base64-decode-region (point-min) (point-max))
  86   (call-process-region (point-min) (point-max) "gunzip"
  87                        t (current-buffer) nil
  88                        "-c"))
  89
  90 (defun gnus-cloud-parse-chunk ()
  91   (save-excursion
  92     (goto-char (point-min))
  93     (unless (looking-at "Version \\([0-9]+\\)")
  94       (error "Not a valid Cloud chunk in the current buffer"))
  95     (forward-line 1)
  96     (let ((version (string-to-number (match-string 1)))
  97           (data (buffer-substring (point) (point-max))))
  98       (mm-with-unibyte-buffer
  99         (insert data)
 100         (cond
 101          ((= version 1)
 102           (gnus-cloud-decode-data)
 103           (gnus-cloud-parse-version-1))
 104          (t
 105           (error "Unsupported Cloud chunk version %s" version)))))))
 106
 107 (defun gnus-cloud-parse-version-1 ()
 108   (let ((elems nil))
 109     (while (not (eobp))
 110       (while (and (not (eobp))
 111                   (not (looking-at "(:file\\|(:data")))
 112         (forward-line 1))
 113       (unless (eobp)
 114         (let ((spec (ignore-errors (read (current-buffer))))
 115               length)
 116           (when (and (consp spec)
 117                      (or (eq (car spec) :file)
 118                          (eq (car spec) :data)))
 119             (setq length (car (last spec)))
 120             (push (append (butlast spec)
 121                           (list
 122                            (buffer-substring (1+ (point))
 123                                              (+ (point) 1 length))))
 124                   elems)
 125             (goto-char (+ (point) 1 length))))))
 126     (nreverse elems)))
 127
 128 (defun gnus-cloud-update-data (elems)
 129   (dolist (elem elems)
 130     (cond
 131      ((eq (car elem) :data)
 132       )
 133      ((eq (car elem) :file)
 134       (unless (= (length elem) 4)
 135         (error "Invalid length of a file spec: %s" (length elem)))
 136       (gnus-cloud-update-file (cdr elem)))
 137      (t
 138       (error "Unknown type %s" (car elem))))))
 139
 140 (defun gnus-cloud-update-file (elem)
 141   (let ((file-name (pop elem))
 142         (date (pop elem))
 143         (contents (pop elem)))
 144     (unless (gnus-cloud-file-covered-p file-name)
 145       (message "%s isn't covered by the cloud; ignoring" file-name))
 146     (when (or (not (file-exists-p file-name))
 147               (and (file-exists-p file-name)
 148                    (mm-with-unibyte-buffer
 149                      (insert-file-contents-literally file-name)
 150                      (not (equal (buffer-string) contents)))))
 151       (gnus-cloud-replace-file file-name date contents))))
 152
 153 (defun gnus-cloud-replace-file (file-name date new-contents)
 154   (mm-with-unibyte-buffer
 155     (insert new-contents)
 156     (when (file-exists-p file-name)
 157       (let ((backup (car (find-backup-file-name file-name))))
 158         (rename-file file-name backup)))
 159     (write-region (point-min) (point-max) file-name)))
 160
 161 (defun gnus-cloud-file-covered-p (file-name)
 162   (let ((matched nil))
 163     (dolist (regexp gnus-cloud-synced-files)
 164       (when (string-match regexp file-name)
 165         (setq matched t)))
 166     matched))
 167
 168 (provide 'gnus-cloud)
 169
 170 ;;; gnus-cloud.el ends here