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-group-name "*Emacs Cloud*")
45 (defvar gnus-cloud-version 1)
46 (defvar gnus-cloud-sequence 1)
48 (defvar gnus-cloud-method nil
49 "The IMAP select method used to store the cloud data.")
51 (defun gnus-cloud-make-chunk (elems)
53 (insert (format "Version %s\n" gnus-cloud-version))
54 (insert (gnus-cloud-insert-data elems))
57 (defun gnus-cloud-insert-data (elems)
58 (mm-with-unibyte-buffer
61 ((eq (plist-get elem :type) :file)
63 (mm-with-unibyte-buffer
64 (insert-file-contents-literally (plist-get elem :file-name))
65 (setq length (buffer-size)
66 data (buffer-string)))
67 (insert (format "(:type :file :file-name %S :timestamp %S :length %d)\n"
68 (plist-get elem :file-name)
69 (plist-get elem :timestamp)
73 ((eq (plist-get elem :type) :data)
74 (insert (format "(:type :data :name %S :length %d)\n"
75 (plist-get elem :name)
76 (with-current-buffer (plist-get elem :buffer)
78 (insert-buffer-substring (plist-get elem :buffer))
80 ((eq (plist-get elem :type) :delete)
81 (insert (format "(:type :delete :file-name %S)\n"
82 (plist-get elem :file-name))))))
83 (gnus-cloud-encode-data)
86 (defun gnus-cloud-encode-data ()
87 (call-process-region (point-min) (point-max) "gzip"
88 t (current-buffer) nil
90 (base64-encode-region (point-min) (point-max)))
92 (defun gnus-cloud-decode-data ()
93 (base64-decode-region (point-min) (point-max))
94 (call-process-region (point-min) (point-max) "gunzip"
95 t (current-buffer) nil
98 (defun gnus-cloud-parse-chunk ()
100 (goto-char (point-min))
101 (unless (looking-at "Version \\([0-9]+\\)")
102 (error "Not a valid Cloud chunk in the current buffer"))
104 (let ((version (string-to-number (match-string 1)))
105 (data (buffer-substring (point) (point-max))))
106 (mm-with-unibyte-buffer
110 (gnus-cloud-decode-data)
111 (goto-char (point-min))
112 (gnus-cloud-parse-version-1))
114 (error "Unsupported Cloud chunk version %s" version)))))))
116 (defun gnus-cloud-parse-version-1 ()
119 (while (and (not (eobp))
120 (not (looking-at "(:type")))
123 (let ((spec (ignore-errors (read (current-buffer))))
125 (when (and (consp spec)
126 (memq (getf spec :type) '(:file :data :deleta)))
127 (setq length (plist-get spec :length))
130 :contents (buffer-substring (1+ (point))
131 (+ (point) 1 length))))
133 (goto-char (+ (point) 1 length))))))
136 (defun gnus-cloud-update-data (elems)
138 (let ((type (plist-get elem :type)))
143 (gnus-cloud-delete-file (plist-get elem :file-name))
146 (gnus-cloud-update-file elem))
148 (message "Unknown type %s; ignoring" type))))))
150 (defun gnus-cloud-update-file (elem)
151 (let ((file-name (plist-get elem :file-name))
152 (date (plist-get elem :timestamp))
153 (contents (plist-get elem :contents)))
154 (unless (gnus-cloud-file-covered-p file-name)
155 (message "%s isn't covered by the cloud; ignoring" file-name))
156 (when (or (not (file-exists-p file-name))
157 (and (file-exists-p file-name)
158 (mm-with-unibyte-buffer
159 (insert-file-contents-literally file-name)
160 (not (equal (buffer-string) contents)))))
161 (gnus-cloud-replace-file file-name date contents))))
163 (defun gnus-cloud-replace-file (file-name date new-contents)
164 (mm-with-unibyte-buffer
165 (insert new-contents)
166 (when (file-exists-p file-name)
167 (rename-file file-name (car (find-backup-file-name file-name))))
168 (write-region (point-min) (point-max) file-name)
169 (set-file-times file-name (parse-iso8601-time-string date))))
171 (defun gnus-cloud-delete-file (file-name)
172 (unless (gnus-cloud-file-covered-p file-name)
173 (message "%s isn't covered by the cloud; ignoring" file-name))
174 (when (file-exists-p file-name)
175 (rename-file file-name (car (find-backup-file-name file-name)))))
177 (defun gnus-cloud-file-covered-p (file-name)
179 (dolist (elem gnus-cloud-synced-files)
182 (when (equal elem file-name)
185 (when (and (equal (directory-file-name (plist-get elem :directory))
186 (directory-file-name (file-name-directory file-name)))
187 (string-match (plist-get elem :match)
188 (file-name-nondirectory file-name)))
192 (defun gnus-cloud-all-files ()
194 (dolist (elem gnus-cloud-synced-files)
199 (dolist (file (directory-files (plist-get elem :directory)
201 (plist-get elem :match)))
202 (push (format "%s/%s"
203 (directory-file-name (plist-get elem :directory))
208 (defvar gnus-cloud-file-timestamps nil)
210 (defun gnus-cloud-files-to-upload (&optional full)
213 (dolist (file (gnus-cloud-all-files))
214 (if (file-exists-p file)
215 (when (setq timestamp (gnus-cloud-file-new-p file full))
216 (push `(:type :file :file-name ,file :timestamp ,timestamp) files))
217 (when (assoc file gnus-cloud-file-timestamps)
218 (push `(:type :delete :file-name ,file) files))))
221 (defun gnus-cloud-file-new-p (file full)
222 (let ((timestamp (format-time-string
223 "%FT%T%z" (nth 5 (file-attributes file))))
224 (old (cadr (assoc file gnus-cloud-file-timestamps))))
227 (string< old timestamp))
230 (defun gnus-cloud-ensure-cloud-group ()
231 (let ((method (if (stringp gnus-cloud-method)
232 (gnus-server-to-method gnus-cloud-method)
234 (unless (or (gnus-active gnus-cloud-group-name)
235 (gnus-activate-group gnus-cloud-group-name nil nil
237 (and (gnus-request-create-group gnus-cloud-group-name gnus-cloud-method)
238 (gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method)
239 (gnus-subscribe-group gnus-cloud-group-name)))))
241 (defun gnus-cloud-upload-data (&optional full)
242 (gnus-cloud-ensure-cloud-group)
244 (let ((elems (gnus-cloud-files-to-upload full)))
245 (insert (format "Subject: (sequence: %d type: %s)\n"
247 (if full :full :partial)))
248 (insert "From: nobody@invalid.com\n")
250 (insert (gnus-cloud-make-chunk elems))
251 (when (gnus-request-accept-article gnus-cloud-group-name gnus-cloud-method
253 (setq gnus-cloud-sequence (1+ gnus-cloud-sequence))
254 (gnus-cloud-add-timestamps elems)))))
256 (defun gnus-cloud-add-timestamps (elems)
258 (let* ((file-name (plist-get elem :file-name))
259 (old (assoc file-name gnus-cloud-file-timestamps)))
261 (setq gnus-cloud-file-timestamps
262 (delq old gnus-cloud-file-timestamps)))
263 (push (list file-name (plist-get elem :timestamp))
264 gnus-cloud-file-timestamps))))
266 (defun gnus-cloud-available-chunks ()
267 (gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method)
268 (let* ((group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method))
269 (active (gnus-active group))
271 (when (gnus-retrieve-headers (gnus-uncompress-range active) group)
272 (with-current-buffer nntp-server-buffer
273 (goto-char (point-min))
274 (while (and (not (eobp))
275 (setq head (nnheader-parse-head)))
276 (push head headers))))
279 (defun gnus-cloud-chunk-sequence (string)
280 (if (string-match "sequence: \\([0-9]+\\)" string)
281 (string-to-number (match-string 1 string))
284 (defun gnus-cloud-prune-old-chunks (headers)
286 (sort (reverse headers)
288 (> (gnus-cloud-chunk-sequence (mail-header-subject h1))
289 (gnus-cloud-chunk-sequence (mail-header-subject h2))))))
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 (provide 'gnus-cloud)
307 ;;; gnus-cloud.el ends here