1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
|
;;; gnus-cloud.el --- storing and retrieving data via IMAP -*- lexical-binding: t; -*-
;; Copyright (C) 2014-2025 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: mail
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; The name gnus-cloud parodizes but otherwise has little to do with
;; "cloud computing", a misleading term normally best avoided. See:
;; https://www.gnu.org/philosophy/words-to-avoid.html#CloudComputing
;;; Code:
(require 'parse-time)
(require 'nnimap)
(require 'range)
(eval-when-compile (require 'epg)) ;; setf-method for `epg-context-armor'
(autoload 'epg-make-context "epg")
(autoload 'epg-context-set-passphrase-callback "epg")
(autoload 'epg-decrypt-string "epg")
(autoload 'epg-encrypt-string "epg")
(defgroup gnus-cloud nil
"Syncing Gnus data via IMAP."
:version "25.1"
:group 'gnus)
(defcustom gnus-cloud-synced-files
'(;;"~/.authinfo"
"~/.authinfo.gpg"
"~/.gnus.el"
(:directory "~/News" :match ".*.SCORE\\'"))
"List of files that should be kept up-to-date via the cloud.
Each element may be either a string or a property list.
The latter should have a :directory element whose value is a string,
and a :match element whose value is a regular expression to match
against the basename of files in said directory."
:type '(repeat (choice (string :tag "File")
(plist :tag "Property list"))))
(defcustom gnus-cloud-storage-method (if (featurep 'epg) 'epg 'base64-gzip)
"Storage method for cloud data, defaults to EPG if that's available."
:version "26.1"
:type '(radio (const :tag "No encoding" nil)
(const :tag "Base64" base64)
(const :tag "Base64+gzip" base64-gzip)
(const :tag "EPG" epg)))
(defcustom gnus-cloud-interactive t
"Whether Gnus Cloud changes should be confirmed."
:version "26.1"
:type 'boolean)
(defvar gnus-cloud-group-name "Emacs-Cloud")
(defvar gnus-cloud-covered-servers nil)
(defvar gnus-cloud-version 1)
(defvar gnus-cloud-sequence 1)
(defcustom gnus-cloud-method nil
"The IMAP select method used to store the cloud data.
See also `gnus-server-set-cloud-method-server' for an
easy interactive way to set this from the Server buffer."
:type '(radio (const :tag "Not set" nil)
(string :tag "A Gnus server name as a string")))
(defun gnus-cloud-make-chunk (elems)
(with-temp-buffer
(set-buffer-multibyte nil)
(insert (format "Gnus-Cloud-Version %s\n" gnus-cloud-version))
(insert (gnus-cloud-insert-data elems))
(buffer-string)))
(defun gnus-cloud-insert-data (elems)
(mm-with-unibyte-buffer
(dolist (elem elems)
(cond
((eq (plist-get elem :type) :file)
(let (length data)
(mm-with-unibyte-buffer
(insert-file-contents-literally (plist-get elem :file-name))
(setq length (buffer-size)
data (buffer-string)))
(insert (format "(:type :file :file-name %S :timestamp %S :length %d)\n"
(plist-get elem :file-name)
(plist-get elem :timestamp)
length))
(insert data)
(insert "\n")))
((eq (plist-get elem :type) :newsrc-data)
(let ((print-level nil)
(print-length nil))
(print elem (current-buffer)))
(insert "\n"))
((eq (plist-get elem :type) :delete)
(insert (format "(:type :delete :file-name %S)\n"
(plist-get elem :file-name))))))
(gnus-cloud-encode-data)
(buffer-string)))
(defun gnus-cloud-encode-data ()
(cond
((eq gnus-cloud-storage-method 'base64-gzip)
(progn
(call-process-region (point-min) (point-max) "gzip"
t (current-buffer) nil
"-c")
(base64-encode-region (point-min) (point-max))))
((eq gnus-cloud-storage-method 'base64)
(base64-encode-region (point-min) (point-max)))
((eq gnus-cloud-storage-method 'epg)
(let ((context (epg-make-context 'OpenPGP))
) ;; cipher
(setf (epg-context-armor context) t)
(setf (epg-context-textmode context) t)
(let ((data (epg-encrypt-string context
(buffer-substring-no-properties
(point-min)
(point-max))
nil)))
(delete-region (point-min) (point-max))
(insert data))))
((null gnus-cloud-storage-method)
(gnus-message 5 "Leaving cloud data plaintext"))
(t (gnus-error 1 "Invalid cloud storage method %S"
gnus-cloud-storage-method))))
(defun gnus-cloud-decode-data ()
(cond
;; FIXME: Duplicated value in ‘cond’: base64-gzip.
((memq gnus-cloud-storage-method '(base64 base64-gzip))
(base64-decode-region (point-min) (point-max)))
((eq gnus-cloud-storage-method 'base64-gzip)
(call-process-region (point-min) (point-max) "gunzip"
t (current-buffer) nil
"-c"))
((eq gnus-cloud-storage-method 'epg)
(let* ((context (epg-make-context 'OpenPGP))
(data (epg-decrypt-string context (buffer-substring-no-properties
(point-min)
(point-max)))))
(delete-region (point-min) (point-max))
(insert data)))
((null gnus-cloud-storage-method)
(gnus-message 5 "Reading cloud data as plaintext"))
(t (gnus-error 1 "Invalid cloud storage method %S"
gnus-cloud-storage-method))))
(defun gnus-cloud-parse-chunk ()
(save-excursion
(unless (looking-at "Gnus-Cloud-Version \\([0-9]+\\)")
(error "Not a valid Cloud chunk in the current buffer"))
(forward-line 1)
(let ((version (string-to-number (match-string 1)))
(data (buffer-substring (point) (point-max))))
(mm-with-unibyte-buffer
(insert data)
(cond
((= version 1)
(gnus-cloud-decode-data)
(goto-char (point-min))
(gnus-cloud-parse-version-1))
(t
(error "Unsupported Cloud chunk version %s" version)))))))
(defun gnus-cloud-parse-version-1 ()
(let ((elems nil))
(while (not (eobp))
(while (and (not (eobp))
(not (looking-at "(:type")))
(forward-line 1))
(unless (eobp)
(let ((spec (ignore-errors (read (current-buffer))))
length)
(when (consp spec)
(cond
((memq (plist-get spec :type) '(:file :delete))
(setq length (plist-get spec :length))
(push (append spec
(list
:contents (buffer-substring (1+ (point))
(+ (point) 1 length))))
elems)
(goto-char (+ (point) 1 length)))
((memq (plist-get spec :type) '(:newsrc-data))
(push spec elems)))))))
(nreverse elems)))
(defun gnus-cloud-update-all (elems)
(dolist (elem elems)
(let ((type (plist-get elem :type)))
(cond
((eq type :newsrc-data)
(gnus-cloud-update-newsrc-data (plist-get elem :name) elem))
((memq type '(:delete :file))
(gnus-cloud-update-file elem type))
(t
(gnus-message 1 "Unknown type %s; ignoring" type))))))
(defun gnus-cloud-update-newsrc-data (group elem)
"Update the newsrc data for GROUP from ELEM."
(let* ((contents (plist-get elem :contents))
(date (or (plist-get elem :timestamp) "0"))
(group-info (gnus-get-info group)))
(if (and contents
(stringp (nth 0 contents))
(integerp (nth 1 contents)))
(if group-info
(if (equal (format "%S" group-info)
(format "%S" contents))
(gnus-message 3 "Skipping cloud update of group %s, the info is the same" group)
(when (or (not gnus-cloud-interactive)
(gnus-y-or-n-p
(format "%s has different info in the cloud from %s, update it here? "
group date)))
(gnus-message 2 "Installing cloud update of group %s" group)
(gnus-set-info group contents)
(gnus-group-update-group group)))
(gnus-error 1 "Sorry, group %s is not subscribed" group))
(gnus-error 1 "Sorry, could not update newsrc for group %s (invalid data %S)"
group elem))))
(defun gnus-cloud-update-file (elem op)
"Apply Gnus Cloud data ELEM and operation OP to a file."
(let* ((file-name (plist-get elem :file-name))
(date (plist-get elem :timestamp))
(contents (plist-get elem :contents))
(exists (file-exists-p file-name)))
(if (gnus-cloud-file-covered-p file-name)
(cond
((eq op :delete)
(if (and exists
;; prompt only if the file exists already
(or (not gnus-cloud-interactive)
(gnus-y-or-n-p (format "%s has been deleted as of %s, delete it locally? "
file-name date))))
(rename-file file-name (car (find-backup-file-name file-name)))
(gnus-message 3 "%s was already deleted before the cloud got it" file-name)))
((eq op :file)
(when (or (not exists)
(and exists
(mm-with-unibyte-buffer
(insert-file-contents-literally file-name)
(not (equal (buffer-string) contents)))
;; prompt only if the file exists already
(or (not gnus-cloud-interactive)
(gnus-y-or-n-p (format "%s has updated contents as of %s, update it? "
file-name date)))))
(gnus-cloud-replace-file file-name date contents))))
(gnus-message 2 "%s isn't covered by the cloud; ignoring" file-name))))
(defun gnus-cloud-replace-file (file-name date new-contents)
(mm-with-unibyte-buffer
(insert new-contents)
(when (file-exists-p file-name)
(rename-file file-name (car (find-backup-file-name file-name))))
(write-region (point-min) (point-max) file-name nil nil nil 'excl)
(set-file-times file-name (parse-iso8601-time-string date) 'nofollow)))
(defun gnus-cloud-file-covered-p (file-name)
(let ((matched nil))
(dolist (elem gnus-cloud-synced-files)
(cond
((stringp elem)
;; This seems fragile. String comparison, with no
;; expand-file-name to resolve ~, etc.
(when (equal elem file-name)
(setq matched t)))
((consp elem)
(when (and (equal (directory-file-name (plist-get elem :directory))
(directory-file-name (file-name-directory file-name)))
(string-match (plist-get elem :match)
(file-name-nondirectory file-name)))
(setq matched t)))))
matched))
(defun gnus-cloud-all-files ()
(let ((files nil))
(dolist (elem gnus-cloud-synced-files)
(cond
((stringp elem)
(push elem files))
((consp elem)
(dolist (file (directory-files (plist-get elem :directory)
nil
(plist-get elem :match)))
(push (format "%s/%s"
(directory-file-name (plist-get elem :directory))
file)
files)))))
(nreverse files)))
(defvar gnus-cloud-file-timestamps nil)
(defun gnus-cloud-files-to-upload (&optional full)
(let ((files nil)
timestamp)
(dolist (file (gnus-cloud-all-files))
(if (file-exists-p file)
(when (setq timestamp (gnus-cloud-file-new-p file full))
(push `(:type :file :file-name ,file :timestamp ,timestamp) files))
(when (assoc file gnus-cloud-file-timestamps)
(push `(:type :delete :file-name ,file) files))))
(nreverse files)))
(defun gnus-cloud-timestamp (time)
"Return a general timestamp string for TIME."
(format-time-string "%FT%T%z" time))
(defun gnus-cloud-file-new-p (file full)
(let ((timestamp (gnus-cloud-timestamp (file-attribute-modification-time
(file-attributes file))))
(old (cadr (assoc file gnus-cloud-file-timestamps))))
(when (or full
(null old)
(string< old timestamp))
timestamp)))
(declare-function gnus-activate-group "gnus-start"
(group &optional scan dont-check method dont-sub-check))
(declare-function gnus-subscribe-group "gnus-start"
(group &optional previous method))
(defun gnus-cloud-ensure-cloud-group ()
;; (let ((method (if (stringp gnus-cloud-method)
;; (gnus-server-to-method gnus-cloud-method)
;; gnus-cloud-method)))
(unless (or (gnus-active gnus-cloud-group-name)
(gnus-activate-group gnus-cloud-group-name nil nil
gnus-cloud-method))
(and (gnus-request-create-group gnus-cloud-group-name gnus-cloud-method)
(gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method)
(gnus-subscribe-group gnus-cloud-group-name)))) ;; )
(defun gnus-cloud-upload-all-data ()
"Upload all data (newsrc and files) to the Gnus Cloud."
(interactive)
(gnus-cloud-upload-data t))
(autoload 'gnus-group-refresh-group "gnus-group")
(defun gnus-cloud-upload-data (&optional full)
"Upload data (newsrc and files) to the Gnus Cloud.
When FULL is t, upload everything, not just a difference from the last full."
(interactive)
(gnus-cloud-ensure-cloud-group)
(with-temp-buffer
(let ((elems (append
(gnus-cloud-files-to-upload full)
(gnus-cloud-collect-full-newsrc)))
(group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method)))
(setq gnus-cloud-sequence (1+ (or gnus-cloud-sequence 0)))
(insert (format "Subject: (sequence: %s type: %s storage-method: %s)\n"
gnus-cloud-sequence
(if full :full :partial)
gnus-cloud-storage-method))
(insert "From: nobody@gnus.cloud.invalid\n")
(insert "\n")
(insert (gnus-cloud-make-chunk elems))
(if (gnus-request-accept-article gnus-cloud-group-name gnus-cloud-method
t t)
(progn
(gnus-cloud-add-timestamps elems)
(gnus-message 3 "Uploaded Gnus Cloud data successfully to %s" group)
(gnus-group-refresh-group group))
(gnus-error 2 "Failed to upload Gnus Cloud data to %s" group)))))
(defvar gnus-alter-header-function)
(defun gnus-cloud-add-timestamps (elems)
(dolist (elem elems)
(let* ((file-name (plist-get elem :file-name))
(old (assoc file-name gnus-cloud-file-timestamps)))
(when old
(setq gnus-cloud-file-timestamps
(delq old gnus-cloud-file-timestamps)))
(push (list file-name (plist-get elem :timestamp))
gnus-cloud-file-timestamps))))
(defun gnus-cloud-available-chunks ()
(gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method)
(let* ((group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method))
(active (gnus-active group))
headers head)
(when (gnus-retrieve-headers (range-uncompress active) group)
(with-current-buffer nntp-server-buffer
(goto-char (point-min))
(while (setq head (nnheader-parse-head))
(when gnus-alter-header-function
(funcall gnus-alter-header-function head))
(push head headers))))
(sort (nreverse headers)
(lambda (h1 h2)
(> (gnus-cloud-chunk-sequence (mail-header-subject h1))
(gnus-cloud-chunk-sequence (mail-header-subject h2)))))))
(defun gnus-cloud-chunk-sequence (string)
(if (string-match "sequence: \\([0-9]+\\)" string)
(string-to-number (match-string 1 string))
0))
;; TODO: use this
(defun gnus-cloud-prune-old-chunks (headers)
(let ((headers (reverse headers))
(found nil))
(while (and headers
(not found))
(when (string-match "type: :full" (mail-header-subject (car headers)))
(setq found t))
(pop headers))
;; All the chunks that are older than the newest :full chunk can be
;; deleted.
(when headers
(gnus-request-expire-articles
(mapcar (lambda (h)
(mail-header-number h))
(nreverse headers))
(gnus-group-full-name gnus-cloud-group-name gnus-cloud-method)))))
(defun gnus-cloud-download-all-data ()
"Download the Gnus Cloud data and install it.
Starts at `gnus-cloud-sequence' in the sequence."
(interactive)
(gnus-cloud-download-data t))
(defun gnus-cloud-download-data (&optional update sequence-override)
"Download the Gnus Cloud data and install it if UPDATE is t.
When SEQUENCE-OVERRIDE is given, start at that sequence number
instead of `gnus-cloud-sequence'.
When UPDATE is t, returns the result of calling `gnus-cloud-update-all'.
Otherwise, returns the Gnus Cloud data chunks."
(let ((articles nil)
(highest-sequence-seen gnus-cloud-sequence)
chunks)
(dolist (header (gnus-cloud-available-chunks))
(let ((this-sequence (gnus-cloud-chunk-sequence (mail-header-subject header))))
(when (> this-sequence (or sequence-override gnus-cloud-sequence -1))
(if (string-match (format "storage-method: %s" gnus-cloud-storage-method)
(mail-header-subject header))
(progn
(push (mail-header-number header) articles)
(setq highest-sequence-seen (max highest-sequence-seen this-sequence)))
(gnus-message 1 "Skipping article %s because it didn't match the Gnus Cloud method %s: %s"
(mail-header-number header)
gnus-cloud-storage-method
(mail-header-subject header))))))
(when articles
(nnimap-request-articles (nreverse articles) gnus-cloud-group-name)
(with-current-buffer nntp-server-buffer
(goto-char (point-min))
(while (re-search-forward "^Gnus-Cloud-Version " nil t)
(beginning-of-line)
(push (gnus-cloud-parse-chunk) chunks)
(forward-line 1))))
(if update
(prog1 (mapcar #'gnus-cloud-update-all chunks)
(setq gnus-cloud-sequence highest-sequence-seen))
chunks)))
(defun gnus-cloud-server-p (server)
(member server gnus-cloud-covered-servers))
(defun gnus-cloud-host-server-p (server)
(equal gnus-cloud-method server))
(defun gnus-cloud-host-acceptable-method-p (server)
(eq (car-safe (gnus-server-to-method server)) 'nnimap))
(defun gnus-cloud-collect-full-newsrc ()
"Collect all the Gnus newsrc data in a portable format."
(let ((infos nil))
(dolist (info (cdr gnus-newsrc-alist))
(when (gnus-cloud-server-p
(gnus-method-to-server
(gnus-find-method-for-group (gnus-info-group info))))
(push `(:type :newsrc-data :name ,(gnus-info-group info) :contents ,info :timestamp ,(gnus-cloud-timestamp nil))
infos)))
infos))
(provide 'gnus-cloud)
;;; gnus-cloud.el ends here
|
