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))
31 (defgroup gnus-cloud nil
32 "Syncing Gnus data via IMAP."
35 (defcustom gnus-cloud-synced-files
39 (:directory "~/News" :match ".*.SCORE\\'"))
40 "List of file regexps that should be kept up-to-date via the cloud."
42 :type '(repeat regexp))
44 (defvar gnus-cloud-group-name "*Emacs Cloud*")
46 (defvar gnus-cloud-version 1)
47 (defvar gnus-cloud-sequence 1)
49 (defvar gnus-cloud-method nil
50 "The IMAP select method used to store the cloud data.")
52 (defun gnus-cloud-make-chunk (elems)
54 (insert (format "Version %s\n" gnus-cloud-version))
55 (insert (gnus-cloud-insert-data elems))
58 (defun gnus-cloud-insert-data (elems)
59 (mm-with-unibyte-buffer
62 ((eq (plist-get elem :type) :file)
64 (mm-with-unibyte-buffer
65 (insert-file-contents-literally (plist-get elem :file-name))
66 (setq length (buffer-size)
67 data (buffer-string)))
68 (insert (format "(:type :file :file-name %S :timestamp %S :length %d)\n"
69 (plist-get elem :file-name)
70 (plist-get elem :timestamp)
74 ((eq (plist-get elem :type) :data)
75 (insert (format "(:type :data :name %S :length %d)\n"
76 (plist-get elem :name)
77 (with-current-buffer (plist-get elem :buffer)
79 (insert-buffer-substring (plist-get elem :buffer))
81 ((eq (plist-get elem :type) :delete)
82 (insert (format "(:type :delete :file-name %S)\n"
83 (plist-get elem :file-name))))))
84 (gnus-cloud-encode-data)
87 (defun gnus-cloud-encode-data ()
88 (call-process-region (point-min) (point-max) "gzip"
89 t (current-buffer) nil
91 (base64-encode-region (point-min) (point-max)))
93 (defun gnus-cloud-decode-data ()
94 (base64-decode-region (point-min) (point-max))
95 (call-process-region (point-min) (point-max) "gunzip"
96 t (current-buffer) nil
99 (defun gnus-cloud-parse-chunk ()
101 (goto-char (point-min))
102 (unless (looking-at "Version \\([0-9]+\\)")
103 (error "Not a valid Cloud chunk in the current buffer"))
105 (let ((version (string-to-number (match-string 1)))
106 (data (buffer-substring (point) (point-max))))
107 (mm-with-unibyte-buffer
111 (gnus-cloud-decode-data)
112 (goto-char (point-min))
113 (gnus-cloud-parse-version-1))
115 (error "Unsupported Cloud chunk version %s" version)))))))
117 (defun gnus-cloud-parse-version-1 ()
120 (while (and (not (eobp))
121 (not (looking-at "(:type")))
124 (let ((spec (ignore-errors (read (current-buffer))))
126 (when (and (consp spec)
127 (memq (getf spec :type) '(:file :data :deleta)))
128 (setq length (plist-get spec :length))
131 :contents (buffer-substring (1+ (point))
132 (+ (point) 1 length))))
134 (goto-char (+ (point) 1 length))))))
137 (defun gnus-cloud-update-data (elems)
139 (let ((type (plist-get elem :type)))
144 (gnus-cloud-delete-file (plist-get elem :file-name))
147 (gnus-cloud-update-file elem))
149 (message "Unknown type %s; ignoring" type))))))
151 (defun gnus-cloud-update-file (elem)
152 (let ((file-name (plist-get elem :file-name))
153 (date (plist-get elem :timestamp))
154 (contents (plist-get elem :contents)))
155 (unless (gnus-cloud-file-covered-p file-name)
156 (message "%s isn't covered by the cloud; ignoring" file-name))
157 (when (or (not (file-exists-p file-name))
158 (and (file-exists-p file-name)
159 (mm-with-unibyte-buffer
160 (insert-file-contents-literally file-name)
161 (not (equal (buffer-string) contents)))))
162 (gnus-cloud-replace-file file-name date contents))))
164 (defun gnus-cloud-replace-file (file-name date new-contents)
165 (mm-with-unibyte-buffer
166 (insert new-contents)
167 (when (file-exists-p file-name)
168 (rename-file file-name (car (find-backup-file-name file-name))))
169 (write-region (point-min) (point-max) file-name)
170 (set-file-times file-name (parse-iso8601-time-string date))))
172 (defun gnus-cloud-delete-file (file-name)
173 (unless (gnus-cloud-file-covered-p file-name)
174 (message "%s isn't covered by the cloud; ignoring" file-name))
175 (when (file-exists-p file-name)
176 (rename-file file-name (car (find-backup-file-name file-name)))))
178 (defun gnus-cloud-file-covered-p (file-name)
180 (dolist (elem gnus-cloud-synced-files)
183 (when (equal elem file-name)
186 (when (and (equal (directory-file-name (plist-get elem :directory))
187 (directory-file-name (file-name-directory file-name)))
188 (string-match (plist-get elem :match)
189 (file-name-nondirectory file-name)))
193 (defun gnus-cloud-all-files ()
195 (dolist (elem gnus-cloud-synced-files)
200 (dolist (file (directory-files (plist-get elem :directory)
202 (plist-get elem :match)))
203 (push (format "%s/%s"
204 (directory-file-name (plist-get elem :directory))
209 (defvar gnus-cloud-file-timestamps nil)
211 (defun gnus-cloud-files-to-upload (&optional full)
214 (dolist (file (gnus-cloud-all-files))
215 (if (file-exists-p file)
216 (when (setq timestamp (gnus-cloud-file-new-p file full))
217 (push `(:type :file :file-name ,file :timestamp ,timestamp) files))
218 (when (assoc file gnus-cloud-file-timestamps)
219 (push `(:type :delete :file-name ,file) files))))
222 (defun gnus-cloud-file-new-p (file full)
223 (let ((timestamp (format-time-string
224 "%FT%T%z" (nth 5 (file-attributes file))))
225 (old (cadr (assoc file gnus-cloud-file-timestamps))))
228 (string< old timestamp))
231 (defun gnus-cloud-ensure-cloud-group ()
232 (let ((method (if (stringp gnus-cloud-method)
233 (gnus-server-to-method gnus-cloud-method)
235 (unless (or (gnus-active gnus-cloud-group-name)
236 (gnus-activate-group gnus-cloud-group-name nil nil
238 (and (gnus-request-create-group gnus-cloud-group-name gnus-cloud-method)
239 (gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method)
240 (gnus-subscribe-group gnus-cloud-group-name)))))
242 (defun gnus-cloud-upload-data (&optional full)
243 (gnus-cloud-ensure-cloud-group)
245 (let ((elems (gnus-cloud-files-to-upload full)))
246 (insert (format "Subject: (sequence: %d type: %s)\n"
248 (if full :full :partial)))
249 (insert "From: nobody@invalid.com\n")
251 (insert (gnus-cloud-make-chunk elems))
252 (when (gnus-request-accept-article gnus-cloud-group-name gnus-cloud-method
254 (setq gnus-cloud-sequence (1+ gnus-cloud-sequence))
255 (gnus-cloud-add-timestamps elems)))))
257 (defun gnus-cloud-add-timestamps (elems)
259 (let* ((file-name (plist-get elem :file-name))
260 (old (assoc file-name gnus-cloud-file-timestamps)))
262 (setq gnus-cloud-file-timestamps
263 (delq old gnus-cloud-file-timestamps)))
264 (push (list file-name (plist-get elem :timestamp))
265 gnus-cloud-file-timestamps))))
267 (defun gnus-cloud-available-chunks ()
268 (gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method)
269 (let* ((group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method))
270 (active (gnus-active group))
272 (when (gnus-retrieve-headers (gnus-uncompress-range active) group)
273 (with-current-buffer nntp-server-buffer
274 (goto-char (point-min))
275 (while (and (not (eobp))
276 (setq head (nnheader-parse-head)))
277 (push head headers))))
278 (sort (nreverse headers)
280 (> (gnus-cloud-chunk-sequence (mail-header-subject h1))
281 (gnus-cloud-chunk-sequence (mail-header-subject h2)))))))
283 (defun gnus-cloud-chunk-sequence (string)
284 (if (string-match "sequence: \\([0-9]+\\)" string)
285 (string-to-number (match-string 1 string))
288 (defun gnus-cloud-prune-old-chunks (headers)
289 (let ((headers (reverse headers))
293 (when (string-match "type: :full" (mail-header-subject (car headers)))
296 ;; All the chunks that are older than the newest :full chunk can be
299 (gnus-request-expire-articles
301 (mail-header-number h))
303 (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method)))))
305 (defun gnus-cloud-download-data ()
308 (dolist (header (gnus-cloud-available-chunks))
309 (when (> (gnus-cloud-chunk-sequence (mail-header-subject header))
311 (push (mail-header-number header) articles)))
313 (nnimap-request-articles (nreverse articles) gnus-cloud-group-name)
314 (with-current-buffer nntp-server-buffer
315 (goto-char (point-min))
316 (while (re-search-forward "^Version " nil t)
318 (push (gnus-cloud-parse-chunk) chunks)
319 (forward-line 1))))))
321 (provide 'gnus-cloud)
323 ;;; gnus-cloud.el ends here