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*")
45 (defvar gnus-cloud-covered-servers nil
)
47 (defvar gnus-cloud-version
1)
48 (defvar gnus-cloud-sequence
1)
50 (defvar gnus-cloud-method nil
51 "The IMAP select method used to store the cloud data.")
53 (defun gnus-cloud-make-chunk (elems)
55 (insert (format "Version %s\n" gnus-cloud-version
))
56 (insert (gnus-cloud-insert-data elems
))
59 (defun gnus-cloud-insert-data (elems)
60 (mm-with-unibyte-buffer
63 ((eq (plist-get elem
:type
) :file
)
65 (mm-with-unibyte-buffer
66 (insert-file-contents-literally (plist-get elem
:file-name
))
67 (setq length
(buffer-size)
68 data
(buffer-string)))
69 (insert (format "(:type :file :file-name %S :timestamp %S :length %d)\n"
70 (plist-get elem
:file-name
)
71 (plist-get elem
:timestamp
)
75 ((eq (plist-get elem
:type
) :data
)
76 (insert (format "(:type :data :name %S :length %d)\n"
77 (plist-get elem
:name
)
78 (with-current-buffer (plist-get elem
:buffer
)
80 (insert-buffer-substring (plist-get elem
:buffer
))
82 ((eq (plist-get elem
:type
) :delete
)
83 (insert (format "(:type :delete :file-name %S)\n"
84 (plist-get elem
:file-name
))))))
85 (gnus-cloud-encode-data)
88 (defun gnus-cloud-encode-data ()
89 (call-process-region (point-min) (point-max) "gzip"
90 t
(current-buffer) nil
92 (base64-encode-region (point-min) (point-max)))
94 (defun gnus-cloud-decode-data ()
95 (base64-decode-region (point-min) (point-max))
96 (call-process-region (point-min) (point-max) "gunzip"
97 t
(current-buffer) nil
100 (defun gnus-cloud-parse-chunk ()
102 (goto-char (point-min))
103 (unless (looking-at "Version \\([0-9]+\\)")
104 (error "Not a valid Cloud chunk in the current buffer"))
106 (let ((version (string-to-number (match-string 1)))
107 (data (buffer-substring (point) (point-max))))
108 (mm-with-unibyte-buffer
112 (gnus-cloud-decode-data)
113 (goto-char (point-min))
114 (gnus-cloud-parse-version-1))
116 (error "Unsupported Cloud chunk version %s" version
)))))))
118 (defun gnus-cloud-parse-version-1 ()
121 (while (and (not (eobp))
122 (not (looking-at "(:type")))
125 (let ((spec (ignore-errors (read (current-buffer))))
127 (when (and (consp spec
)
128 (memq (plist-get spec
:type
) '(:file
:data
:deleta
)))
129 (setq length
(plist-get spec
:length
))
132 :contents
(buffer-substring (1+ (point))
133 (+ (point) 1 length
))))
135 (goto-char (+ (point) 1 length
))))))
138 (defun gnus-cloud-update-data (elems)
140 (let ((type (plist-get elem
:type
)))
145 (gnus-cloud-delete-file (plist-get elem
:file-name
))
148 (gnus-cloud-update-file elem
))
150 (message "Unknown type %s; ignoring" type
))))))
152 (defun gnus-cloud-update-file (elem)
153 (let ((file-name (plist-get elem
:file-name
))
154 (date (plist-get elem
:timestamp
))
155 (contents (plist-get elem
:contents
)))
156 (unless (gnus-cloud-file-covered-p file-name
)
157 (message "%s isn't covered by the cloud; ignoring" file-name
))
158 (when (or (not (file-exists-p file-name
))
159 (and (file-exists-p file-name
)
160 (mm-with-unibyte-buffer
161 (insert-file-contents-literally file-name
)
162 (not (equal (buffer-string) contents
)))))
163 (gnus-cloud-replace-file file-name date contents
))))
165 (defun gnus-cloud-replace-file (file-name date new-contents
)
166 (mm-with-unibyte-buffer
167 (insert new-contents
)
168 (when (file-exists-p file-name
)
169 (rename-file file-name
(car (find-backup-file-name file-name
))))
170 (write-region (point-min) (point-max) file-name
)
171 (set-file-times file-name
(parse-iso8601-time-string date
))))
173 (defun gnus-cloud-delete-file (file-name)
174 (unless (gnus-cloud-file-covered-p file-name
)
175 (message "%s isn't covered by the cloud; ignoring" file-name
))
176 (when (file-exists-p file-name
)
177 (rename-file file-name
(car (find-backup-file-name file-name
)))))
179 (defun gnus-cloud-file-covered-p (file-name)
181 (dolist (elem gnus-cloud-synced-files
)
184 (when (equal elem file-name
)
187 (when (and (equal (directory-file-name (plist-get elem
:directory
))
188 (directory-file-name (file-name-directory file-name
)))
189 (string-match (plist-get elem
:match
)
190 (file-name-nondirectory file-name
)))
194 (defun gnus-cloud-all-files ()
196 (dolist (elem gnus-cloud-synced-files
)
201 (dolist (file (directory-files (plist-get elem
:directory
)
203 (plist-get elem
:match
)))
204 (push (format "%s/%s"
205 (directory-file-name (plist-get elem
:directory
))
210 (defvar gnus-cloud-file-timestamps nil
)
212 (defun gnus-cloud-files-to-upload (&optional full
)
215 (dolist (file (gnus-cloud-all-files))
216 (if (file-exists-p file
)
217 (when (setq timestamp
(gnus-cloud-file-new-p file full
))
218 (push `(:type
:file
:file-name
,file
:timestamp
,timestamp
) files
))
219 (when (assoc file gnus-cloud-file-timestamps
)
220 (push `(:type
:delete
:file-name
,file
) files
))))
223 (defun gnus-cloud-file-new-p (file full
)
224 (let ((timestamp (format-time-string
225 "%FT%T%z" (nth 5 (file-attributes file
))))
226 (old (cadr (assoc file gnus-cloud-file-timestamps
))))
229 (string< old timestamp
))
232 (declare-function gnus-activate-group
"gnus-start"
233 (group &optional scan dont-check method dont-sub-check
))
234 (declare-function gnus-subscribe-group
"gnus-start"
235 (group &optional previous method
))
237 (defun gnus-cloud-ensure-cloud-group ()
238 (let ((method (if (stringp gnus-cloud-method
)
239 (gnus-server-to-method gnus-cloud-method
)
241 (unless (or (gnus-active gnus-cloud-group-name
)
242 (gnus-activate-group gnus-cloud-group-name nil nil
244 (and (gnus-request-create-group gnus-cloud-group-name gnus-cloud-method
)
245 (gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method
)
246 (gnus-subscribe-group gnus-cloud-group-name
)))))
248 (defun gnus-cloud-upload-data (&optional full
)
249 (gnus-cloud-ensure-cloud-group)
251 (let ((elems (gnus-cloud-files-to-upload full
)))
252 (insert (format "Subject: (sequence: %d type: %s)\n"
254 (if full
:full
:partial
)))
255 (insert "From: nobody@invalid.com\n")
257 (insert (gnus-cloud-make-chunk elems
))
258 (when (gnus-request-accept-article gnus-cloud-group-name gnus-cloud-method
260 (setq gnus-cloud-sequence
(1+ gnus-cloud-sequence
))
261 (gnus-cloud-add-timestamps elems
)))))
263 (defun gnus-cloud-add-timestamps (elems)
265 (let* ((file-name (plist-get elem
:file-name
))
266 (old (assoc file-name gnus-cloud-file-timestamps
)))
268 (setq gnus-cloud-file-timestamps
269 (delq old gnus-cloud-file-timestamps
)))
270 (push (list file-name
(plist-get elem
:timestamp
))
271 gnus-cloud-file-timestamps
))))
273 (defun gnus-cloud-available-chunks ()
274 (gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method
)
275 (let* ((group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method
))
276 (active (gnus-active group
))
278 (when (gnus-retrieve-headers (gnus-uncompress-range active
) group
)
279 (with-current-buffer nntp-server-buffer
280 (goto-char (point-min))
281 (while (and (not (eobp))
282 (setq head
(nnheader-parse-head)))
283 (push head headers
))))
284 (sort (nreverse headers
)
286 (> (gnus-cloud-chunk-sequence (mail-header-subject h1
))
287 (gnus-cloud-chunk-sequence (mail-header-subject h2
)))))))
289 (defun gnus-cloud-chunk-sequence (string)
290 (if (string-match "sequence: \\([0-9]+\\)" string
)
291 (string-to-number (match-string 1 string
))
294 (defun gnus-cloud-prune-old-chunks (headers)
295 (let ((headers (reverse headers
))
299 (when (string-match "type: :full" (mail-header-subject (car headers
)))
302 ;; All the chunks that are older than the newest :full chunk can be
305 (gnus-request-expire-articles
307 (mail-header-number h
))
309 (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method
)))))
311 (defun gnus-cloud-download-data ()
314 (dolist (header (gnus-cloud-available-chunks))
315 (when (> (gnus-cloud-chunk-sequence (mail-header-subject header
))
317 (push (mail-header-number header
) articles
)))
319 (nnimap-request-articles (nreverse articles
) gnus-cloud-group-name
)
320 (with-current-buffer nntp-server-buffer
321 (goto-char (point-min))
322 (while (re-search-forward "^Version " nil t
)
324 (push (gnus-cloud-parse-chunk) chunks
)
325 (forward-line 1))))))
327 (defun gnus-cloud-server-p (server)
328 (member server gnus-cloud-covered-servers
))
330 (provide 'gnus-cloud
)
332 ;;; gnus-cloud.el ends here