1 ;;; gnus-cloud.el --- storing and retrieving data via IMAP
3 ;; Copyright (C) 2014 Free Software Foundation, Inc.
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
8 ;; This file is part of GNU Emacs.
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.
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.
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/>.
27 (eval-when-compile (require 'cl))
29 (defgroup gnus-cloud nil
30 "Syncing Gnus data via IMAP."
33 (defcustom gnus-cloud-synced-files '("~/\\.authinfo"
37 "List of file regexps that should be kept up-to-date via the cloud."
39 :type '(repeat regexp))
41 (defvar gnus-cloud-version 1)
43 (defvar gnus-cloud-method nil
44 "The IMAP select method used to store the cloud data.")
46 (defun gnus-cloud-make-chunk (elems)
48 (insert (format "Version %s\n" gnus-cloud-version))
49 (insert (gnus-cloud-insert-data elems))
52 (defun gnus-cloud-insert-data (elems)
53 (mm-with-unibyte-buffer
56 ((eq (car elem) :file)
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"
65 "%FT%T%z" (nth 5 (file-attributes (cadr elem))))
69 ((eq (car elem) :buffer)
70 (insert (format "(:data %S %d)\n" (cadr elem)
71 (with-current-buffer (caddr elem)
73 (insert-buffer-substring (caddr elem))
75 (gnus-cloud-encode-data)
78 (defun gnus-cloud-encode-data ()
79 (call-process-region (point-min) (point-max) "gzip"
80 t (current-buffer) nil
82 (base64-encode-region (point-min) (point-max)))
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
90 (defun gnus-cloud-parse-chunk ()
92 (goto-char (point-min))
93 (unless (looking-at "Version \\([0-9]+\\)")
94 (error "Not a valid Cloud chunk in the current buffer"))
96 (let ((version (string-to-number (match-string 1)))
97 (data (buffer-substring (point) (point-max))))
98 (mm-with-unibyte-buffer
102 (gnus-cloud-decode-data)
103 (gnus-cloud-parse-version-1))
105 (error "Unsupported Cloud chunk version %s" version)))))))
107 (defun gnus-cloud-parse-version-1 ()
110 (while (and (not (eobp))
111 (not (looking-at "(:file\\|(:data")))
114 (let ((spec (ignore-errors (read (current-buffer))))
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)
122 (buffer-substring (1+ (point))
123 (+ (point) 1 length))))
125 (goto-char (+ (point) 1 length))))))
128 (defun gnus-cloud-update-data (elems)
131 ((eq (car elem) :data)
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)))
138 (error "Unknown type %s" (car elem))))))
140 (defun gnus-cloud-update-file (elem)
141 (let ((file-name (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)
151 (equal (buffer-string (point-min) (point-max))
153 (gnus-cloud-replace-file file-name date contents))))
155 (defun gnus-cloud-replace-file (file-name date new-contents)
156 (mm-with-unibyte-buffer
157 (insert new-contents)
158 (when (file-exists-p file-name)
159 (let ((backup (car (find-backup-file-name file-name))))
160 (rename-file file-name backup)))
161 (write-region (point-min) (point-max) file-name)))
163 (defun gnus-cloud-file-covered-p (file-name)
165 (dolist (regexp gnus-cloud-synced-files)
166 (when (string-match regexp file-name)
170 (provide 'gnus-cloud)
172 ;;; gnus-cloud.el ends here