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))
29 (defgroup gnus-cloud nil
30 "Syncing Gnus data via IMAP."
33 (defcustom gnus-cloud-synced-files
37 (:directory "~/News" :match ".*.SCORE\\'"))
38 "List of file regexps that should be kept up-to-date via the cloud."
40 :type '(repeat regexp))
42 (defvar gnus-cloud-version 1)
44 (defvar gnus-cloud-method nil
45 "The IMAP select method used to store the cloud data.")
47 (defun gnus-cloud-make-chunk (elems)
49 (insert (format "Version %s\n" gnus-cloud-version))
50 (insert (gnus-cloud-insert-data elems))
53 (defun gnus-cloud-insert-data (elems)
54 (mm-with-unibyte-buffer
57 ((eq (car elem) :file)
59 (mm-with-unibyte-buffer
60 (insert-file-contents-literally (cadr elem))
61 (setq length (buffer-size)
62 data (buffer-string)))
63 (insert (format "(:file %S %S %d)\n"
66 "%FT%T%z" (nth 5 (file-attributes (cadr elem))))
70 ((eq (car elem) :buffer)
71 (insert (format "(:data %S %d)\n" (cadr elem)
72 (with-current-buffer (caddr elem)
74 (insert-buffer-substring (caddr elem))
76 ((eq (car elem) :delete)
77 (insert (format ("(:delete %S)\n") (cadr elem))))))
78 (gnus-cloud-encode-data)
81 (defun gnus-cloud-encode-data ()
82 (call-process-region (point-min) (point-max) "gzip"
83 t (current-buffer) nil
85 (base64-encode-region (point-min) (point-max)))
87 (defun gnus-cloud-decode-data ()
88 (base64-decode-region (point-min) (point-max))
89 (call-process-region (point-min) (point-max) "gunzip"
90 t (current-buffer) nil
93 (defun gnus-cloud-parse-chunk ()
95 (goto-char (point-min))
96 (unless (looking-at "Version \\([0-9]+\\)")
97 (error "Not a valid Cloud chunk in the current buffer"))
99 (let ((version (string-to-number (match-string 1)))
100 (data (buffer-substring (point) (point-max))))
101 (mm-with-unibyte-buffer
105 (gnus-cloud-decode-data)
106 (gnus-cloud-parse-version-1))
108 (error "Unsupported Cloud chunk version %s" version)))))))
110 (defun gnus-cloud-parse-version-1 ()
113 (while (and (not (eobp))
114 (not (looking-at "(:file\\|(:data\\|(:delete")))
117 (let ((spec (ignore-errors (read (current-buffer))))
119 (when (and (consp spec)
120 (or (eq (car spec) :file)
121 (eq (car spec) :data)
122 (eq (car spec) :delete)))
123 (setq length (car (last spec)))
124 (push (append (butlast spec)
126 (buffer-substring (1+ (point))
127 (+ (point) 1 length))))
129 (goto-char (+ (point) 1 length))))))
132 (defun gnus-cloud-update-data (elems)
135 ((eq (car elem) :data)
137 ((eq (car elem) :delete)
138 (gnus-cloud-delete-file (cadr elem))
140 ((eq (car elem) :file)
141 (unless (= (length elem) 4)
142 (error "Invalid length of a file spec: %s" (length elem)))
143 (gnus-cloud-update-file (cdr elem)))
145 (error "Unknown type %s" (car elem))))))
147 (defun gnus-cloud-update-file (elem)
148 (let ((file-name (pop elem))
150 (contents (pop elem)))
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 (expand-file-name file (plist-get elem :directory))
203 (defvar gnus-cloud-file-timestamps nil)
205 (defun gnus-cloud-files-to-upload (&optional full)
207 (dolist (file (gnus-cloud-all-files))
208 (if (file-exists-p file)
210 (gnus-cloud-file-new-p file))
211 (push `(:file ,file) files))
212 (when (assoc file gnus-cloud-file-timestamps)
213 (push `(:delete ,file) files))))
216 (defun gnus-cloud-file-new-p (file)
217 (let ((timestamp (format-time-string
218 "%FT%T%z" (nth 5 (file-attributes file))))
219 (old (cadr (assoc file gnus-cloud-file-timestamps))))
221 (string< old timestamp))))
223 (provide 'gnus-cloud)
225 ;;; gnus-cloud.el ends here