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))
30 (defgroup gnus-cloud nil
31 "Syncing Gnus data via IMAP."
34 (defcustom gnus-cloud-synced-files
38 (:directory "~/News" :match ".*.SCORE\\'"))
39 "List of file regexps that should be kept up-to-date via the cloud."
41 :type '(repeat regexp))
43 (defvar gnus-cloud-version 1)
45 (defvar gnus-cloud-method nil
46 "The IMAP select method used to store the cloud data.")
48 (defun gnus-cloud-make-chunk (elems)
50 (insert (format "Version %s\n" gnus-cloud-version))
51 (insert (gnus-cloud-insert-data elems))
54 (defun gnus-cloud-insert-data (elems)
55 (mm-with-unibyte-buffer
58 ((eq (plist-get elem :type) :file)
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)
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)
75 (insert-buffer-substring (plist-get elem :buffer))
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)
83 (defun gnus-cloud-encode-data ()
84 (call-process-region (point-min) (point-max) "gzip"
85 t (current-buffer) nil
87 (base64-encode-region (point-min) (point-max)))
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
95 (defun gnus-cloud-parse-chunk ()
97 (goto-char (point-min))
98 (unless (looking-at "Version \\([0-9]+\\)")
99 (error "Not a valid Cloud chunk in the current buffer"))
101 (let ((version (string-to-number (match-string 1)))
102 (data (buffer-substring (point) (point-max))))
103 (mm-with-unibyte-buffer
107 (gnus-cloud-decode-data)
108 (goto-char (point-min))
109 (gnus-cloud-parse-version-1))
111 (error "Unsupported Cloud chunk version %s" version)))))))
113 (defun gnus-cloud-parse-version-1 ()
116 (while (and (not (eobp))
117 (not (looking-at "(:type")))
120 (let ((spec (ignore-errors (read (current-buffer))))
122 (when (and (consp spec)
123 (memq (getf spec :type) '(:file :data :deleta)))
124 (setq length (plist-get spec :length))
127 :contents (buffer-substring (1+ (point))
128 (+ (point) 1 length))))
130 (goto-char (+ (point) 1 length))))))
133 (defun gnus-cloud-update-data (elems)
135 (let ((type (plist-get elem :type)))
140 (gnus-cloud-delete-file (plist-get elem :file-name))
143 (gnus-cloud-update-file elem))
145 (message "Unknown type %s; ignoring" type))))))
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))))
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))))
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)))))
174 (defun gnus-cloud-file-covered-p (file-name)
176 (dolist (elem gnus-cloud-synced-files)
179 (when (equal elem file-name)
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)))
189 (defun gnus-cloud-all-files ()
191 (dolist (elem gnus-cloud-synced-files)
196 (dolist (file (directory-files (plist-get elem :directory)
198 (plist-get elem :match)))
199 (push (format "%s/%s"
200 (directory-file-name (plist-get elem :directory))
205 (defvar gnus-cloud-file-timestamps nil)
207 (defun gnus-cloud-files-to-upload (&optional full)
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))))
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))))
224 (string< old timestamp))
227 (provide 'gnus-cloud)
229 ;;; gnus-cloud.el ends here