Update copyright year to 2016
[gnus] / lisp / gnus-cloud.el
1 ;;; gnus-cloud.el --- storing and retrieving data via IMAP
2
3 ;; Copyright (C) 2014-2016 Free Software Foundation, Inc.
4
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6 ;; Keywords: mail
7
8 ;; This file is part of GNU Emacs.
9
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.
14
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.
19
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/>.
22
23 ;;; Commentary:
24
25 ;;; Code:
26
27 (eval-when-compile (require 'cl))
28 (require 'parse-time)
29 (require 'nnimap)
30
31 (defgroup gnus-cloud nil
32   "Syncing Gnus data via IMAP."
33   :version "25.1"
34   :group 'gnus)
35
36 (defcustom gnus-cloud-synced-files
37   '(;;"~/.authinfo"
38     "~/.authinfo.gpg"
39     "~/.gnus.el"
40     (:directory "~/News" :match ".*.SCORE\\'"))
41   "List of file regexps that should be kept up-to-date via the cloud."
42   :group 'gnus-cloud
43   ;; FIXME this type does not match the default.  Nor does the documentation.
44   :type '(repeat regexp))
45
46 (defvar gnus-cloud-group-name "*Emacs Cloud*")
47 (defvar gnus-cloud-covered-servers nil)
48
49 (defvar gnus-cloud-version 1)
50 (defvar gnus-cloud-sequence 1)
51
52 (defvar gnus-cloud-method nil
53   "The IMAP select method used to store the cloud data.")
54
55 (defun gnus-cloud-make-chunk (elems)
56   (with-temp-buffer
57     (insert (format "Version %s\n" gnus-cloud-version))
58     (insert (gnus-cloud-insert-data elems))
59     (buffer-string)))
60
61 (defun gnus-cloud-insert-data (elems)
62   (mm-with-unibyte-buffer
63     (dolist (elem elems)
64       (cond
65        ((eq (plist-get elem :type) :file)
66         (let (length data)
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)
74                           length))
75           (insert data)
76           (insert "\n")))
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)
81                           (buffer-size))))
82         (insert-buffer-substring (plist-get elem :buffer))
83         (insert "\n"))
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)
88     (buffer-string)))
89
90 (defun gnus-cloud-encode-data ()
91   (call-process-region (point-min) (point-max) "gzip"
92                        t (current-buffer) nil
93                        "-c")
94   (base64-encode-region (point-min) (point-max)))
95
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
100                        "-c"))
101
102 (defun gnus-cloud-parse-chunk ()
103   (save-excursion
104     (goto-char (point-min))
105     (unless (looking-at "Version \\([0-9]+\\)")
106       (error "Not a valid Cloud chunk in the current buffer"))
107     (forward-line 1)
108     (let ((version (string-to-number (match-string 1)))
109           (data (buffer-substring (point) (point-max))))
110       (mm-with-unibyte-buffer
111         (insert data)
112         (cond
113          ((= version 1)
114           (gnus-cloud-decode-data)
115           (goto-char (point-min))
116           (gnus-cloud-parse-version-1))
117          (t
118           (error "Unsupported Cloud chunk version %s" version)))))))
119
120 (defun gnus-cloud-parse-version-1 ()
121   (let ((elems nil))
122     (while (not (eobp))
123       (while (and (not (eobp))
124                   (not (looking-at "(:type")))
125         (forward-line 1))
126       (unless (eobp)
127         (let ((spec (ignore-errors (read (current-buffer))))
128               length)
129           (when (and (consp spec)
130                      (memq (plist-get spec :type) '(:file :data :delete)))
131             (setq length (plist-get spec :length))
132             (push (append spec
133                           (list
134                            :contents (buffer-substring (1+ (point))
135                                                        (+ (point) 1 length))))
136                   elems)
137             (goto-char (+ (point) 1 length))))))
138     (nreverse elems)))
139
140 (defun gnus-cloud-update-data (elems)
141   (dolist (elem elems)
142     (let ((type (plist-get elem :type)))
143       (cond
144        ((eq type :data)
145         )
146        ((eq type :delete)
147         (gnus-cloud-delete-file (plist-get elem :file-name))
148         )
149        ((eq type :file)
150         (gnus-cloud-update-file elem))
151        (t
152         (message "Unknown type %s; ignoring" type))))))
153
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))))
166
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))))
174
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)))))
180
181 (defun gnus-cloud-file-covered-p (file-name)
182   (let ((matched nil))
183     (dolist (elem gnus-cloud-synced-files)
184       (cond
185        ((stringp elem)
186         (when (equal elem file-name)
187           (setq matched t)))
188        ((consp elem)
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)))
193           (setq matched t)))))
194     matched))
195
196 (defun gnus-cloud-all-files ()
197   (let ((files nil))
198     (dolist (elem gnus-cloud-synced-files)
199       (cond
200        ((stringp elem)
201         (push elem files))
202        ((consp elem)
203         (dolist (file (directory-files (plist-get elem :directory)
204                                        nil
205                                        (plist-get elem :match)))
206           (push (format "%s/%s"
207                         (directory-file-name (plist-get elem :directory))
208                         file)
209                 files)))))
210     (nreverse files)))
211
212 (defvar gnus-cloud-file-timestamps nil)
213
214 (defun gnus-cloud-files-to-upload (&optional full)
215   (let ((files nil)
216         timestamp)
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))))
223     (nreverse files)))
224
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))))
229     (when (or full
230               (null old)
231               (string< old timestamp))
232       timestamp)))
233
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))
238
239 (defun gnus-cloud-ensure-cloud-group ()
240   (let ((method (if (stringp gnus-cloud-method)
241                     (gnus-server-to-method gnus-cloud-method)
242                   gnus-cloud-method)))
243     (unless (or (gnus-active gnus-cloud-group-name)
244                 (gnus-activate-group gnus-cloud-group-name nil nil
245                                      gnus-cloud-method))
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)))))
249
250 (defun gnus-cloud-upload-data (&optional full)
251   (gnus-cloud-ensure-cloud-group)
252   (with-temp-buffer
253     (let ((elems (gnus-cloud-files-to-upload full)))
254       (insert (format "Subject: (sequence: %d type: %s)\n"
255                       gnus-cloud-sequence
256                       (if full :full :partial)))
257       (insert "From: nobody@invalid.com\n")
258       (insert "\n")
259       (insert (gnus-cloud-make-chunk elems))
260       (when (gnus-request-accept-article gnus-cloud-group-name gnus-cloud-method
261                                          t t)
262         (setq gnus-cloud-sequence (1+ gnus-cloud-sequence))
263         (gnus-cloud-add-timestamps elems)))))
264
265 (defun gnus-cloud-add-timestamps (elems)
266   (dolist (elem elems)
267     (let* ((file-name (plist-get elem :file-name))
268            (old (assoc file-name gnus-cloud-file-timestamps)))
269       (when old
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))))
274
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))
279          headers head)
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)
287           (lambda (h1 h2)
288             (> (gnus-cloud-chunk-sequence (mail-header-subject h1))
289                (gnus-cloud-chunk-sequence (mail-header-subject h2)))))))
290
291 (defun gnus-cloud-chunk-sequence (string)
292   (if (string-match "sequence: \\([0-9]+\\)" string)
293       (string-to-number (match-string 1 string))
294     0))
295
296 (defun gnus-cloud-prune-old-chunks (headers)
297   (let ((headers (reverse headers))
298         (found nil))
299   (while (and headers
300               (not found))
301     (when (string-match "type: :full" (mail-header-subject (car headers)))
302       (setq found t))
303     (pop headers))
304   ;; All the chunks that are older than the newest :full chunk can be
305   ;; deleted.
306   (when headers
307     (gnus-request-expire-articles
308      (mapcar (lambda (h)
309                (mail-header-number h))
310              (nreverse headers))
311      (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method)))))
312
313 (defun gnus-cloud-download-data ()
314   (let ((articles nil)
315         chunks)
316     (dolist (header (gnus-cloud-available-chunks))
317       (when (> (gnus-cloud-chunk-sequence (mail-header-subject header))
318                gnus-cloud-sequence)
319         (push (mail-header-number header) articles)))
320     (when 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)
325           (beginning-of-line)
326           (push (gnus-cloud-parse-chunk) chunks)
327           (forward-line 1))))))
328
329 (defun gnus-cloud-server-p (server)
330   (member server gnus-cloud-covered-servers))
331
332 (defun gnus-cloud-collect-full-newsrc ()
333   (let ((infos nil))
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))))
338         (push info infos)))
339     ))
340
341 (provide 'gnus-cloud)
342
343 ;;; gnus-cloud.el ends here