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 (gnus-cloud-encode-data)
79 (defun gnus-cloud-encode-data ()
80 (call-process-region (point-min) (point-max) "gzip"
81 t (current-buffer) nil
83 (base64-encode-region (point-min) (point-max)))
85 (defun gnus-cloud-decode-data ()
86 (base64-decode-region (point-min) (point-max))
87 (call-process-region (point-min) (point-max) "gunzip"
88 t (current-buffer) nil
91 (defun gnus-cloud-parse-chunk ()
93 (goto-char (point-min))
94 (unless (looking-at "Version \\([0-9]+\\)")
95 (error "Not a valid Cloud chunk in the current buffer"))
97 (let ((version (string-to-number (match-string 1)))
98 (data (buffer-substring (point) (point-max))))
99 (mm-with-unibyte-buffer
103 (gnus-cloud-decode-data)
104 (gnus-cloud-parse-version-1))
106 (error "Unsupported Cloud chunk version %s" version)))))))
108 (defun gnus-cloud-parse-version-1 ()
111 (while (and (not (eobp))
112 (not (looking-at "(:file\\|(:data")))
115 (let ((spec (ignore-errors (read (current-buffer))))
117 (when (and (consp spec)
118 (or (eq (car spec) :file)
119 (eq (car spec) :data)))
120 (setq length (car (last spec)))
121 (push (append (butlast spec)
123 (buffer-substring (1+ (point))
124 (+ (point) 1 length))))
126 (goto-char (+ (point) 1 length))))))
129 (defun gnus-cloud-update-data (elems)
132 ((eq (car elem) :data)
134 ((eq (car elem) :file)
135 (unless (= (length elem) 4)
136 (error "Invalid length of a file spec: %s" (length elem)))
137 (gnus-cloud-update-file (cdr elem)))
139 (error "Unknown type %s" (car elem))))))
141 (defun gnus-cloud-update-file (elem)
142 (let ((file-name (pop elem))
144 (contents (pop elem)))
145 (unless (gnus-cloud-file-covered-p file-name)
146 (message "%s isn't covered by the cloud; ignoring" file-name))
147 (when (or (not (file-exists-p file-name))
148 (and (file-exists-p file-name)
149 (mm-with-unibyte-buffer
150 (insert-file-contents-literally file-name)
151 (not (equal (buffer-string) contents)))))
152 (gnus-cloud-replace-file file-name date contents))))
154 (defun gnus-cloud-replace-file (file-name date new-contents)
155 (mm-with-unibyte-buffer
156 (insert new-contents)
157 (when (file-exists-p file-name)
158 (let ((backup (car (find-backup-file-name file-name))))
159 (rename-file file-name backup)))
160 (write-region (point-min) (point-max) file-name)))
162 (defun gnus-cloud-file-covered-p (file-name)
164 (dolist (elem gnus-cloud-synced-files)
167 (when (equal elem file-name)
170 (when (and (equal (directory-file-name (plist-get elem :directory))
171 (directory-file-name (file-name-directory file-name)))
172 (string-match (plist-get elem :match)
173 (file-name-nondirectory file-name)))
177 (provide 'gnus-cloud)
179 ;;; gnus-cloud.el ends here