1 ;;; gnus-cloud.el --- storing and retrieving data via IMAP
3 ;; Copyright (C) 2014-2015 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."
36 (defcustom gnus-cloud-synced-files
40 (:directory "~/News" :match ".*.SCORE\\'"))
41 "List of file regexps that should be kept up-to-date via the cloud."
43 ;; FIXME this type does not match the default. Nor does the documentation.
44 :type '(repeat regexp))
46 (defvar gnus-cloud-group-name "*Emacs Cloud*")
47 (defvar gnus-cloud-covered-servers nil)
49 (defvar gnus-cloud-version 1)
50 (defvar gnus-cloud-sequence 1)
52 (defvar gnus-cloud-method nil
53 "The IMAP select method used to store the cloud data.")
55 (defun gnus-cloud-make-chunk (elems)
57 (insert (format "Version %s\n" gnus-cloud-version))
58 (insert (gnus-cloud-insert-data elems))
61 (defun gnus-cloud-insert-data (elems)
62 (mm-with-unibyte-buffer
65 ((eq (plist-get elem :type) :file)
67 (mm-with-unibyte-buffer
68 (insert-file-contents-literally (plist-get elem :file-name))
69 (setq length (buffer-size)
70 data (buffer-string)))
71 (insert (format "(:type :file :file-name %S :timestamp %S :length %d)\n"
72 (plist-get elem :file-name)
73 (plist-get elem :timestamp)
77 ((eq (plist-get elem :type) :data)
78 (insert (format "(:type :data :name %S :length %d)\n"
79 (plist-get elem :name)
80 (with-current-buffer (plist-get elem :buffer)
82 (insert-buffer-substring (plist-get elem :buffer))
84 ((eq (plist-get elem :type) :delete)
85 (insert (format "(:type :delete :file-name %S)\n"
86 (plist-get elem :file-name))))))
87 (gnus-cloud-encode-data)
90 (defun gnus-cloud-encode-data ()
91 (call-process-region (point-min) (point-max) "gzip"
92 t (current-buffer) nil
94 (base64-encode-region (point-min) (point-max)))
96 (defun gnus-cloud-decode-data ()
97 (base64-decode-region (point-min) (point-max))
98 (call-process-region (point-min) (point-max) "gunzip"
99 t (current-buffer) nil
102 (defun gnus-cloud-parse-chunk ()
104 (goto-char (point-min))
105 (unless (looking-at "Version \\([0-9]+\\)")
106 (error "Not a valid Cloud chunk in the current buffer"))
108 (let ((version (string-to-number (match-string 1)))
109 (data (buffer-substring (point) (point-max))))
110 (mm-with-unibyte-buffer
114 (gnus-cloud-decode-data)
115 (goto-char (point-min))
116 (gnus-cloud-parse-version-1))
118 (error "Unsupported Cloud chunk version %s" version)))))))
120 (defun gnus-cloud-parse-version-1 ()
123 (while (and (not (eobp))
124 (not (looking-at "(:type")))
127 (let ((spec (ignore-errors (read (current-buffer))))
129 (when (and (consp spec)
130 (memq (plist-get spec :type) '(:file :data :delete)))
131 (setq length (plist-get spec :length))
134 :contents (buffer-substring (1+ (point))
135 (+ (point) 1 length))))
137 (goto-char (+ (point) 1 length))))))
140 (defun gnus-cloud-update-data (elems)
142 (let ((type (plist-get elem :type)))
147 (gnus-cloud-delete-file (plist-get elem :file-name))
150 (gnus-cloud-update-file elem))
152 (message "Unknown type %s; ignoring" type))))))
154 (defun gnus-cloud-update-file (elem)
155 (let ((file-name (plist-get elem :file-name))
156 (date (plist-get elem :timestamp))
157 (contents (plist-get elem :contents)))
158 (unless (gnus-cloud-file-covered-p file-name)
159 (message "%s isn't covered by the cloud; ignoring" file-name))
160 (when (or (not (file-exists-p file-name))
161 (and (file-exists-p file-name)
162 (mm-with-unibyte-buffer
163 (insert-file-contents-literally file-name)
164 (not (equal (buffer-string) contents)))))
165 (gnus-cloud-replace-file file-name date contents))))
167 (defun gnus-cloud-replace-file (file-name date new-contents)
168 (mm-with-unibyte-buffer
169 (insert new-contents)
170 (when (file-exists-p file-name)
171 (rename-file file-name (car (find-backup-file-name file-name))))
172 (write-region (point-min) (point-max) file-name)
173 (set-file-times file-name (parse-iso8601-time-string date))))
175 (defun gnus-cloud-delete-file (file-name)
176 (unless (gnus-cloud-file-covered-p file-name)
177 (message "%s isn't covered by the cloud; ignoring" file-name))
178 (when (file-exists-p file-name)
179 (rename-file file-name (car (find-backup-file-name file-name)))))
181 (defun gnus-cloud-file-covered-p (file-name)
183 (dolist (elem gnus-cloud-synced-files)
186 (when (equal elem file-name)
189 (when (and (equal (directory-file-name (plist-get elem :directory))
190 (directory-file-name (file-name-directory file-name)))
191 (string-match (plist-get elem :match)
192 (file-name-nondirectory file-name)))
196 (defun gnus-cloud-all-files ()
198 (dolist (elem gnus-cloud-synced-files)
203 (dolist (file (directory-files (plist-get elem :directory)
205 (plist-get elem :match)))
206 (push (format "%s/%s"
207 (directory-file-name (plist-get elem :directory))
212 (defvar gnus-cloud-file-timestamps nil)
214 (defun gnus-cloud-files-to-upload (&optional full)
217 (dolist (file (gnus-cloud-all-files))
218 (if (file-exists-p file)
219 (when (setq timestamp (gnus-cloud-file-new-p file full))
220 (push `(:type :file :file-name ,file :timestamp ,timestamp) files))
221 (when (assoc file gnus-cloud-file-timestamps)
222 (push `(:type :delete :file-name ,file) files))))
225 (defun gnus-cloud-file-new-p (file full)
226 (let ((timestamp (format-time-string
227 "%FT%T%z" (nth 5 (file-attributes file))))
228 (old (cadr (assoc file gnus-cloud-file-timestamps))))
231 (string< old timestamp))
234 (declare-function gnus-activate-group "gnus-start"
235 (group &optional scan dont-check method dont-sub-check))
236 (declare-function gnus-subscribe-group "gnus-start"
237 (group &optional previous method))
239 (defun gnus-cloud-ensure-cloud-group ()
240 (let ((method (if (stringp gnus-cloud-method)
241 (gnus-server-to-method gnus-cloud-method)
243 (unless (or (gnus-active gnus-cloud-group-name)
244 (gnus-activate-group gnus-cloud-group-name nil nil
246 (and (gnus-request-create-group gnus-cloud-group-name gnus-cloud-method)
247 (gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method)
248 (gnus-subscribe-group gnus-cloud-group-name)))))
250 (defun gnus-cloud-upload-data (&optional full)
251 (gnus-cloud-ensure-cloud-group)
253 (let ((elems (gnus-cloud-files-to-upload full)))
254 (insert (format "Subject: (sequence: %d type: %s)\n"
256 (if full :full :partial)))
257 (insert "From: nobody@invalid.com\n")
259 (insert (gnus-cloud-make-chunk elems))
260 (when (gnus-request-accept-article gnus-cloud-group-name gnus-cloud-method
262 (setq gnus-cloud-sequence (1+ gnus-cloud-sequence))
263 (gnus-cloud-add-timestamps elems)))))
265 (defun gnus-cloud-add-timestamps (elems)
267 (let* ((file-name (plist-get elem :file-name))
268 (old (assoc file-name gnus-cloud-file-timestamps)))
270 (setq gnus-cloud-file-timestamps
271 (delq old gnus-cloud-file-timestamps)))
272 (push (list file-name (plist-get elem :timestamp))
273 gnus-cloud-file-timestamps))))
275 (defun gnus-cloud-available-chunks ()
276 (gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method)
277 (let* ((group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method))
278 (active (gnus-active group))
280 (when (gnus-retrieve-headers (gnus-uncompress-range active) group)
281 (with-current-buffer nntp-server-buffer
282 (goto-char (point-min))
283 (while (and (not (eobp))
284 (setq head (nnheader-parse-head)))
285 (push head headers))))
286 (sort (nreverse headers)
288 (> (gnus-cloud-chunk-sequence (mail-header-subject h1))
289 (gnus-cloud-chunk-sequence (mail-header-subject h2)))))))
291 (defun gnus-cloud-chunk-sequence (string)
292 (if (string-match "sequence: \\([0-9]+\\)" string)
293 (string-to-number (match-string 1 string))
296 (defun gnus-cloud-prune-old-chunks (headers)
297 (let ((headers (reverse headers))
301 (when (string-match "type: :full" (mail-header-subject (car headers)))
304 ;; All the chunks that are older than the newest :full chunk can be
307 (gnus-request-expire-articles
309 (mail-header-number h))
311 (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method)))))
313 (defun gnus-cloud-download-data ()
316 (dolist (header (gnus-cloud-available-chunks))
317 (when (> (gnus-cloud-chunk-sequence (mail-header-subject header))
319 (push (mail-header-number header) articles)))
321 (nnimap-request-articles (nreverse articles) gnus-cloud-group-name)
322 (with-current-buffer nntp-server-buffer
323 (goto-char (point-min))
324 (while (re-search-forward "^Version " nil t)
326 (push (gnus-cloud-parse-chunk) chunks)
327 (forward-line 1))))))
329 (defun gnus-cloud-server-p (server)
330 (member server gnus-cloud-covered-servers))
332 (defun gnus-cloud-collect-full-newsrc ()
334 (dolist (info (cdr gnus-newsrc-alist))
335 (when (gnus-cloud-server-p
336 (gnus-method-to-server
337 (gnus-find-method-for-group (gnus-info-group info))))
341 (provide 'gnus-cloud)
343 ;;; gnus-cloud.el ends here