[Emacs-diffs] scratch/gnus-cloud 4b12554 4/4: Gnus/Emacs Cloud get upload/download and EPG working

[Teodor Zlatanov]

branch: scratch/gnus-cloud
commit 4b1255490ac9171fda6be55f305b2605256b0b3c
Author: Ted Zlatanov <address@hidden>
Commit: Ted Zlatanov <address@hidden>

    Gnus/Emacs Cloud get upload/download and EPG working
---
 lisp/gnus/gnus-cloud.el |   83 +++++++++++++++++++++++++++++++++++------------
 1 file changed, 62 insertions(+), 21 deletions(-)

diff --git a/lisp/gnus/gnus-cloud.el b/lisp/gnus/gnus-cloud.el
index a4b4922..dac8d42 100644
--- a/lisp/gnus/gnus-cloud.el
+++ b/lisp/gnus/gnus-cloud.el
@@ -28,6 +28,12 @@
 (require 'parse-time)
 (require 'nnimap)
 
+(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"
@@ -46,7 +52,8 @@
 (defcustom gnus-cloud-storage-method (if (featurep 'epg) 'epg 'base64-gzip)
   "Storage method for cloud data, defaults to EPG if that's available."
   :group 'gnus-cloud
-  :type '(choice (const :tag "Base64" base64)
+  :type '(choice (const :tag "No encoding" nil)
+                 (const :tag "Base64" base64)
                  (const :tag "Base64+gzip" base64-gzip)
                  (const :tag "EPG" epg)))
 
@@ -61,7 +68,7 @@
 
 (defun gnus-cloud-make-chunk (elems)
   (with-temp-buffer
-    (insert (format "Version %s\n" gnus-cloud-version))
+    (insert (format "Gnus-Cloud-Version %s\n" gnus-cloud-version))
     (insert (gnus-cloud-insert-data elems))
     (buffer-string)))
 
@@ -100,10 +107,25 @@
     (call-process-region (point-min) (point-max) "gzip"
                          t (current-buffer) nil
                          "-c"))
+
    ((memq gnus-cloud-storage-method '(base64 base64-gzip))
     (base64-encode-region (point-min) (point-max)))
+
    ((eq gnus-cloud-storage-method 'epg)
-    (gnus-error 1 "TODO: set up EPG storage"))
+    (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))))
 
@@ -111,19 +133,29 @@
   (cond
    ((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)
-    (gnus-error 1 "TODO: set up EPG storage"))
+    (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
-    (goto-char (point-min))
-    (unless (looking-at "Version \\([0-9]+\\)")
+    (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)))
@@ -158,7 +190,7 @@
             (goto-char (+ (point) 1 length))))))
     (nreverse elems)))
 
-(defun gnus-cloud-update-data (elems)
+(defun gnus-cloud-update-all (elems)
   (dolist (elem elems)
     (let ((type (plist-get elem :type)))
       (cond
@@ -170,7 +202,7 @@
         (gnus-message 1 "Unknown type %s; ignoring" type))))))
 
 (defun gnus-cloud-update-data (elem)
-  (gnus-error 1 "TODO"))
+  (gnus-error 1 "TODO: update newsrc data"))
 
 (defun gnus-cloud-update-file (elem op)
   (let ((file-name (plist-get elem :file-name))
@@ -273,12 +305,11 @@
   (with-temp-buffer
     (let ((elems (gnus-cloud-files-to-upload full))
           (group (gnus-group-full-name gnus-cloud-group-name 
gnus-cloud-method)))
-      (insert (format "Subject: (sequence: %d type: %s)\n"
+      (insert (format "Subject: (sequence: %d type: %s storage-method: %s)\n"
                       gnus-cloud-sequence
-                      (if full :full :partial)))
-      (insert "From: address@hidden")
-      (insert (format "X-Gnus-Cloud-Storage-Method: %s\n"
+                      (if full :full :partial)
                       gnus-cloud-storage-method))
+      (insert "From: address@hidden")
       (insert "\n")
       (insert (gnus-cloud-make-chunk elems))
       (if (gnus-request-accept-article gnus-cloud-group-name gnus-cloud-method
@@ -338,27 +369,37 @@
              (nreverse headers))
      (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method)))))
 
-(defun gnus-cloud-download-data ()
+(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)
         chunks)
     (dolist (header (gnus-cloud-available-chunks))
       (when (> (gnus-cloud-chunk-sequence (mail-header-subject header))
-               gnus-cloud-sequence)
-        (let ((header-storage-method (mail-header 
"X-Gnus-Cloud-Storage-Method" header)))
-          (if (equal header-storage-method (format "%s" 
gnus-cloud-storage-method))
+               (or sequence-override gnus-cloud-sequence))
+
+        (if (string-match (format "storage-method: %s" 
gnus-cloud-storage-method)
+                          (mail-header-subject header))
             (push (mail-header-number header) articles)
-          (gnus-message 1 "Skipping article %s because its storage method %s 
didn't match the gnus-cloud-storage-method %s"
+          (gnus-message 1 "Skipping article %s because it didn't match the 
Gnus Cloud method %s: %s"
                         (mail-header-number header)
-                        header-storage-method
-                        gnus-cloud-storage-method)))))
+                        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 "^Version " nil t)
+        (while (re-search-forward "^Gnus-Cloud-Version " nil t)
           (beginning-of-line)
           (push (gnus-cloud-parse-chunk) chunks)
-          (forward-line 1))))))
+          (forward-line 1))))
+    (if update
+        (gnus-cloud-update-all chunks)
+      chunks)))
 
 (defun gnus-cloud-server-p (server)
   (member server gnus-cloud-covered-servers))