1 ;;; gnus-cloud.el --- storing and retrieving data via IMAP
3 ;; Copyright (C) 2014-2018 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 <https://www.gnu.org/licenses/>.
25 ;; The name gnus-cloud parodizes but otherwise has little to do with
26 ;; "cloud computing", a misleading term normally best avoided. See:
27 ;; https://www.gnu.org/philosophy/words-to-avoid.html#CloudComputing
31 (eval-when-compile (require 'cl
))
35 (eval-when-compile (require 'epg
)) ;; setf-method for `epg-context-armor'
36 (autoload 'epg-make-context
"epg")
37 (autoload 'epg-context-set-passphrase-callback
"epg")
38 (autoload 'epg-decrypt-string
"epg")
39 (autoload 'epg-encrypt-string
"epg")
41 (defgroup gnus-cloud nil
42 "Syncing Gnus data via IMAP."
46 (defcustom gnus-cloud-synced-files
50 (:directory
"~/News" :match
".*.SCORE\\'"))
51 "List of file regexps that should be kept up-to-date via the cloud."
53 ;; FIXME this type does not match the default. Nor does the documentation.
54 :type
'(repeat regexp
))
56 (defcustom gnus-cloud-storage-method
(if (featurep 'epg
) 'epg
'base64-gzip
)
57 "Storage method for cloud data, defaults to EPG if that's available."
60 :type
'(radio (const :tag
"No encoding" nil
)
61 (const :tag
"Base64" base64
)
62 (const :tag
"Base64+gzip" base64-gzip
)
63 (const :tag
"EPG" epg
)))
65 (defcustom gnus-cloud-interactive t
66 "Whether Gnus Cloud changes should be confirmed."
71 (defvar gnus-cloud-group-name
"Emacs-Cloud")
72 (defvar gnus-cloud-covered-servers nil
)
74 (defvar gnus-cloud-version
1)
75 (defvar gnus-cloud-sequence
1)
77 (defcustom gnus-cloud-method nil
78 "The IMAP select method used to store the cloud data.
79 See also `gnus-server-set-cloud-method-server' for an
80 easy interactive way to set this from the Server buffer."
82 :type
'(radio (const :tag
"Not set" nil
)
83 (string :tag
"A Gnus server name as a string")))
85 (defun gnus-cloud-make-chunk (elems)
87 (insert (format "Gnus-Cloud-Version %s\n" gnus-cloud-version
))
88 (insert (gnus-cloud-insert-data elems
))
91 (defun gnus-cloud-insert-data (elems)
92 (mm-with-unibyte-buffer
95 ((eq (plist-get elem
:type
) :file
)
97 (mm-with-unibyte-buffer
98 (insert-file-contents-literally (plist-get elem
:file-name
))
99 (setq length
(buffer-size)
100 data
(buffer-string)))
101 (insert (format "(:type :file :file-name %S :timestamp %S :length %d)\n"
102 (plist-get elem
:file-name
)
103 (plist-get elem
:timestamp
)
107 ((eq (plist-get elem
:type
) :newsrc-data
)
108 (let ((print-level nil
)
110 (print elem
(current-buffer)))
112 ((eq (plist-get elem
:type
) :delete
)
113 (insert (format "(:type :delete :file-name %S)\n"
114 (plist-get elem
:file-name
))))))
115 (gnus-cloud-encode-data)
118 (defun gnus-cloud-encode-data ()
120 ((eq gnus-cloud-storage-method
'base64-gzip
)
122 (call-process-region (point-min) (point-max) "gzip"
123 t
(current-buffer) nil
125 (base64-encode-region (point-min) (point-max))))
127 ((eq gnus-cloud-storage-method
'base64
)
128 (base64-encode-region (point-min) (point-max)))
130 ((eq gnus-cloud-storage-method
'epg
)
131 (let ((context (epg-make-context 'OpenPGP
))
133 (setf (epg-context-armor context
) t
)
134 (setf (epg-context-textmode context
) t
)
135 (let ((data (epg-encrypt-string context
136 (buffer-substring-no-properties
140 (delete-region (point-min) (point-max))
143 ((null gnus-cloud-storage-method
)
144 (gnus-message 5 "Leaving cloud data plaintext"))
145 (t (gnus-error 1 "Invalid cloud storage method %S"
146 gnus-cloud-storage-method
))))
148 (defun gnus-cloud-decode-data ()
150 ((memq gnus-cloud-storage-method
'(base64 base64-gzip
))
151 (base64-decode-region (point-min) (point-max)))
153 ((eq gnus-cloud-storage-method
'base64-gzip
)
154 (call-process-region (point-min) (point-max) "gunzip"
155 t
(current-buffer) nil
158 ((eq gnus-cloud-storage-method
'epg
)
159 (let* ((context (epg-make-context 'OpenPGP
))
160 (data (epg-decrypt-string context
(buffer-substring-no-properties
163 (delete-region (point-min) (point-max))
166 ((null gnus-cloud-storage-method
)
167 (gnus-message 5 "Reading cloud data as plaintext"))
169 (t (gnus-error 1 "Invalid cloud storage method %S"
170 gnus-cloud-storage-method
))))
172 (defun gnus-cloud-parse-chunk ()
174 (unless (looking-at "Gnus-Cloud-Version \\([0-9]+\\)")
175 (error "Not a valid Cloud chunk in the current buffer"))
177 (let ((version (string-to-number (match-string 1)))
178 (data (buffer-substring (point) (point-max))))
179 (mm-with-unibyte-buffer
183 (gnus-cloud-decode-data)
184 (goto-char (point-min))
185 (gnus-cloud-parse-version-1))
187 (error "Unsupported Cloud chunk version %s" version
)))))))
189 (defun gnus-cloud-parse-version-1 ()
192 (while (and (not (eobp))
193 (not (looking-at "(:type")))
196 (let ((spec (ignore-errors (read (current-buffer))))
200 ((memq (plist-get spec
:type
) '(:file
:delete
))
201 (setq length
(plist-get spec
:length
))
204 :contents
(buffer-substring (1+ (point))
205 (+ (point) 1 length
))))
207 (goto-char (+ (point) 1 length
)))
208 ((memq (plist-get spec
:type
) '(:newsrc-data
))
209 (push spec elems
)))))))
212 (defun gnus-cloud-update-all (elems)
214 (let ((type (plist-get elem
:type
)))
216 ((eq type
:newsrc-data
)
217 (gnus-cloud-update-newsrc-data (plist-get elem
:name
) elem
))
218 ((memq type
'(:delete
:file
))
219 (gnus-cloud-update-file elem type
))
221 (gnus-message 1 "Unknown type %s; ignoring" type
))))))
223 (defun gnus-cloud-update-newsrc-data (group elem
&optional force-older
)
224 "Update the newsrc data for GROUP from ELEM.
225 Use old data if FORCE-OLDER is not nil."
226 (let* ((contents (plist-get elem
:contents
))
227 (date (or (plist-get elem
:timestamp
) "0"))
228 (now (gnus-cloud-timestamp nil
))
229 (newer (string-lessp date now
))
230 (group-info (gnus-get-info group
)))
232 (stringp (nth 0 contents
))
233 (integerp (nth 1 contents
)))
235 (if (equal (format "%S" group-info
)
236 (format "%S" contents
))
237 (gnus-message 3 "Skipping cloud update of group %s, the info is the same" group
)
238 (if (and newer
(not force-older
))
239 (gnus-message 3 "Skipping outdated cloud info for group %s, the info is from %s (now is %s)" group date now
)
240 (when (or (not gnus-cloud-interactive
)
242 (format "%s has older different info in the cloud as of %s, update it here? "
244 (gnus-message 2 "Installing cloud update of group %s" group
)
245 (gnus-set-info group contents
)
246 (gnus-group-update-group group
)))
247 (gnus-error 1 "Sorry, group %s is not subscribed" group
))
248 (gnus-error 1 "Sorry, could not update newsrc for group %s (invalid data %S)"
251 (defun gnus-cloud-update-file (elem op
)
252 "Apply Gnus Cloud data ELEM and operation OP to a file."
253 (let* ((file-name (plist-get elem
:file-name
))
254 (date (plist-get elem
:timestamp
))
255 (contents (plist-get elem
:contents
))
256 (exists (file-exists-p file-name
)))
257 (if (gnus-cloud-file-covered-p file-name
)
261 ;; prompt only if the file exists already
262 (or (not gnus-cloud-interactive
)
263 (gnus-y-or-n-p (format "%s has been deleted as of %s, delete it locally? "
265 (rename-file file-name
(car (find-backup-file-name file-name
)))
266 (gnus-message 3 "%s was already deleted before the cloud got it" file-name
)))
268 (when (or (not exists
)
270 (mm-with-unibyte-buffer
271 (insert-file-contents-literally file-name
)
272 (not (equal (buffer-string) contents
)))
273 ;; prompt only if the file exists already
274 (or (not gnus-cloud-interactive
)
275 (gnus-y-or-n-p (format "%s has updated contents as of %s, update it? "
277 (gnus-cloud-replace-file file-name date contents
))))
278 (gnus-message 2 "%s isn't covered by the cloud; ignoring" file-name
))))
280 (defun gnus-cloud-replace-file (file-name date new-contents
)
281 (mm-with-unibyte-buffer
282 (insert new-contents
)
283 (when (file-exists-p file-name
)
284 (rename-file file-name
(car (find-backup-file-name file-name
))))
285 (write-region (point-min) (point-max) file-name
)
286 (set-file-times file-name
(parse-iso8601-time-string date
))))
288 (defun gnus-cloud-file-covered-p (file-name)
290 (dolist (elem gnus-cloud-synced-files
)
293 (when (equal elem file-name
)
296 (when (and (equal (directory-file-name (plist-get elem
:directory
))
297 (directory-file-name (file-name-directory file-name
)))
298 (string-match (plist-get elem
:match
)
299 (file-name-nondirectory file-name
)))
303 (defun gnus-cloud-all-files ()
305 (dolist (elem gnus-cloud-synced-files
)
310 (dolist (file (directory-files (plist-get elem
:directory
)
312 (plist-get elem
:match
)))
313 (push (format "%s/%s"
314 (directory-file-name (plist-get elem
:directory
))
319 (defvar gnus-cloud-file-timestamps nil
)
321 (defun gnus-cloud-files-to-upload (&optional full
)
324 (dolist (file (gnus-cloud-all-files))
325 (if (file-exists-p file
)
326 (when (setq timestamp
(gnus-cloud-file-new-p file full
))
327 (push `(:type
:file
:file-name
,file
:timestamp
,timestamp
) files
))
328 (when (assoc file gnus-cloud-file-timestamps
)
329 (push `(:type
:delete
:file-name
,file
) files
))))
332 (defun gnus-cloud-timestamp (time)
333 "Return a general timestamp string for TIME."
334 (format-time-string "%FT%T%z" time
))
336 (defun gnus-cloud-file-new-p (file full
)
337 (let ((timestamp (gnus-cloud-timestamp (nth 5 (file-attributes file
))))
338 (old (cadr (assoc file gnus-cloud-file-timestamps
))))
341 (string< old timestamp
))
344 (declare-function gnus-activate-group
"gnus-start"
345 (group &optional scan dont-check method dont-sub-check
))
346 (declare-function gnus-subscribe-group
"gnus-start"
347 (group &optional previous method
))
349 (defun gnus-cloud-ensure-cloud-group ()
350 (let ((method (if (stringp gnus-cloud-method
)
351 (gnus-server-to-method gnus-cloud-method
)
353 (unless (or (gnus-active gnus-cloud-group-name
)
354 (gnus-activate-group gnus-cloud-group-name nil nil
356 (and (gnus-request-create-group gnus-cloud-group-name gnus-cloud-method
)
357 (gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method
)
358 (gnus-subscribe-group gnus-cloud-group-name
)))))
360 (defun gnus-cloud-upload-all-data ()
361 "Upload all data (newsrc and files) to the Gnus Cloud."
363 (gnus-cloud-upload-data t
))
365 (autoload 'gnus-group-refresh-group
"gnus-group")
367 (defun gnus-cloud-upload-data (&optional full
)
368 "Upload data (newsrc and files) to the Gnus Cloud.
369 When FULL is t, upload everything, not just a difference from the last full."
371 (gnus-cloud-ensure-cloud-group)
374 (gnus-cloud-files-to-upload full
)
375 (gnus-cloud-collect-full-newsrc)))
376 (group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method
)))
377 (insert (format "Subject: (sequence: %s type: %s storage-method: %s)\n"
378 (or gnus-cloud-sequence
"UNKNOWN")
379 (if full
:full
:partial
)
380 gnus-cloud-storage-method
))
381 (insert "From: nobody@gnus.cloud.invalid\n")
383 (insert (gnus-cloud-make-chunk elems
))
384 (if (gnus-request-accept-article gnus-cloud-group-name gnus-cloud-method
387 (setq gnus-cloud-sequence
(1+ (or gnus-cloud-sequence
0)))
388 (gnus-cloud-add-timestamps elems
)
389 (gnus-message 3 "Uploaded Gnus Cloud data successfully to %s" group
)
390 (gnus-group-refresh-group group
))
391 (gnus-error 2 "Failed to upload Gnus Cloud data to %s" group
)))))
393 (defun gnus-cloud-add-timestamps (elems)
395 (let* ((file-name (plist-get elem
:file-name
))
396 (old (assoc file-name gnus-cloud-file-timestamps
)))
398 (setq gnus-cloud-file-timestamps
399 (delq old gnus-cloud-file-timestamps
)))
400 (push (list file-name
(plist-get elem
:timestamp
))
401 gnus-cloud-file-timestamps
))))
403 (defun gnus-cloud-available-chunks ()
404 (gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method
)
405 (let* ((group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method
))
406 (active (gnus-active group
))
408 (when (gnus-retrieve-headers (gnus-uncompress-range active
) group
)
409 (with-current-buffer nntp-server-buffer
410 (goto-char (point-min))
411 (while (and (not (eobp))
412 (setq head
(nnheader-parse-head)))
413 (push head headers
))))
414 (sort (nreverse headers
)
416 (> (gnus-cloud-chunk-sequence (mail-header-subject h1
))
417 (gnus-cloud-chunk-sequence (mail-header-subject h2
)))))))
419 (defun gnus-cloud-chunk-sequence (string)
420 (if (string-match "sequence: \\([0-9]+\\)" string
)
421 (string-to-number (match-string 1 string
))
425 (defun gnus-cloud-prune-old-chunks (headers)
426 (let ((headers (reverse headers
))
430 (when (string-match "type: :full" (mail-header-subject (car headers
)))
433 ;; All the chunks that are older than the newest :full chunk can be
436 (gnus-request-expire-articles
438 (mail-header-number h
))
440 (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method
)))))
442 (defun gnus-cloud-download-all-data ()
443 "Download the Gnus Cloud data and install it.
444 Starts at `gnus-cloud-sequence' in the sequence."
446 (gnus-cloud-download-data t
))
448 (defun gnus-cloud-download-data (&optional update sequence-override
)
449 "Download the Gnus Cloud data and install it if UPDATE is t.
450 When SEQUENCE-OVERRIDE is given, start at that sequence number
451 instead of `gnus-cloud-sequence'.
453 When UPDATE is t, returns the result of calling `gnus-cloud-update-all'.
454 Otherwise, returns the Gnus Cloud data chunks."
457 (dolist (header (gnus-cloud-available-chunks))
458 (when (> (gnus-cloud-chunk-sequence (mail-header-subject header
))
459 (or sequence-override gnus-cloud-sequence -
1))
461 (if (string-match (format "storage-method: %s" gnus-cloud-storage-method
)
462 (mail-header-subject header
))
463 (push (mail-header-number header
) articles
)
464 (gnus-message 1 "Skipping article %s because it didn't match the Gnus Cloud method %s: %s"
465 (mail-header-number header
)
466 gnus-cloud-storage-method
467 (mail-header-subject header
)))))
469 (nnimap-request-articles (nreverse articles
) gnus-cloud-group-name
)
470 (with-current-buffer nntp-server-buffer
471 (goto-char (point-min))
472 (while (re-search-forward "^Gnus-Cloud-Version " nil t
)
474 (push (gnus-cloud-parse-chunk) chunks
)
477 (mapcar #'gnus-cloud-update-all chunks
)
480 (defun gnus-cloud-server-p (server)
481 (member server gnus-cloud-covered-servers
))
483 (defun gnus-cloud-host-server-p (server)
484 (equal gnus-cloud-method server
))
486 (defun gnus-cloud-host-acceptable-method-p (server)
487 (eq (car-safe (gnus-server-to-method server
)) 'nnimap
))
489 (defun gnus-cloud-collect-full-newsrc ()
490 "Collect all the Gnus newsrc data in a portable format."
492 (dolist (info (cdr gnus-newsrc-alist
))
493 (when (gnus-cloud-server-p
494 (gnus-method-to-server
495 (gnus-find-method-for-group (gnus-info-group info
))))
497 (push `(:type
:newsrc-data
:name
,(gnus-info-group info
) :contents
,info
:timestamp
,(gnus-cloud-timestamp nil
))
501 (provide 'gnus-cloud
)
503 ;;; gnus-cloud.el ends here