[Emacs-diffs] scratch/gnus-cloud bd2fb4a 2/4: Gnus/Emacs Cloud add storage method and minor cleanups

[Teodor Zlatanov]

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

    Gnus/Emacs Cloud add storage method and minor cleanups
---
 lisp/gnus/gnus-cloud.el |   96 +++++++++++++++++++++++++++++++----------------
 1 file changed, 63 insertions(+), 33 deletions(-)

diff --git a/lisp/gnus/gnus-cloud.el b/lisp/gnus/gnus-cloud.el
index 23b1c0c..f5a8a7b 100644
--- a/lisp/gnus/gnus-cloud.el
+++ b/lisp/gnus/gnus-cloud.el
@@ -43,6 +43,13 @@
   ;; FIXME this type does not match the default.  Nor does the documentation.
   :type '(repeat regexp))
 
+(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)
+                 (const :tag "Base64+gzip" base64-gzip)
+                 (const :tag "EPG" epg)))
+
 (defvar gnus-cloud-group-name "Emacs-Cloud")
 (defvar gnus-cloud-covered-servers nil)
 
@@ -88,16 +95,30 @@
     (buffer-string)))
 
 (defun gnus-cloud-encode-data ()
-  (call-process-region (point-min) (point-max) "gzip"
-                      t (current-buffer) nil
-                      "-c")
-  (base64-encode-region (point-min) (point-max)))
+  (cond
+   ((eq gnus-cloud-storage-method 'base64-gzip)
+    (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"))
+   (t (gnus-error 1 "Invalid cloud storage method %S"
+                  gnus-cloud-storage-method))))
 
 (defun gnus-cloud-decode-data ()
-  (base64-decode-region (point-min) (point-max))
-  (call-process-region (point-min) (point-max) "gunzip"
-                      t (current-buffer) nil
-                      "-c"))
+  (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"))
+   (t (gnus-error 1 "Invalid cloud storage method %S"
+                  gnus-cloud-storage-method))))
 
 (defun gnus-cloud-parse-chunk ()
   (save-excursion
@@ -142,27 +163,33 @@
     (let ((type (plist-get elem :type)))
       (cond
        ((eq type :data)
-       )
-       ((eq type :delete)
-       (gnus-cloud-delete-file (plist-get elem :file-name))
-       )
-       ((eq type :file)
-       (gnus-cloud-update-file elem))
+       (gnus-cloud-update-data elem))
+       ((memq type '(:delete :file))
+       (gnus-cloud-update-file elem type))
        (t
-       (message "Unknown type %s; ignoring" type))))))
+       (gnus-message 1 "Unknown type %s; ignoring" type))))))
 
-(defun gnus-cloud-update-file (elem)
+(defun gnus-cloud-update-data (elem)
+  (gnus-error 1 "TODO"))
+
+(defun gnus-cloud-update-file (elem op)
   (let ((file-name (plist-get elem :file-name))
-       (date (plist-get elem :timestamp))
-       (contents (plist-get elem :contents)))
-    (unless (gnus-cloud-file-covered-p file-name)
-      (message "%s isn't covered by the cloud; ignoring" file-name))
-    (when (or (not (file-exists-p file-name))
-             (and (file-exists-p file-name)
-                  (mm-with-unibyte-buffer
-                    (insert-file-contents-literally file-name)
-                    (not (equal (buffer-string) contents)))))
-      (gnus-cloud-replace-file file-name date contents))))
+        (date (plist-get elem :timestamp))
+        (contents (plist-get elem :contents)))
+    (if (gnus-cloud-file-covered-p file-name)
+        (cond
+         ((eq op :delete)
+          (if (file-exists-p file-name)
+              (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 (file-exists-p file-name))
+                    (and (file-exists-p file-name)
+                         (mm-with-unibyte-buffer
+                           (insert-file-contents-literally file-name)
+                           (not (equal (buffer-string) contents)))))
+            (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
@@ -172,12 +199,6 @@
     (write-region (point-min) (point-max) file-name)
     (set-file-times file-name (parse-iso8601-time-string date))))
 
-(defun gnus-cloud-delete-file (file-name)
-  (unless (gnus-cloud-file-covered-p file-name)
-    (message "%s isn't covered by the cloud; ignoring" file-name))
-  (when (file-exists-p file-name)
-    (rename-file file-name (car (find-backup-file-name file-name)))))
-
 (defun gnus-cloud-file-covered-p (file-name)
   (let ((matched nil))
     (dolist (elem gnus-cloud-synced-files)
@@ -256,6 +277,8 @@
                      gnus-cloud-sequence
                      (if full :full :partial)))
       (insert "From: address@hidden")
+      (insert (format "X-Gnus-Cloud-Storage-Method: %s\n"
+                      gnus-cloud-storage-method))
       (insert "\n")
       (insert (gnus-cloud-make-chunk elems))
       (if (gnus-request-accept-article gnus-cloud-group-name gnus-cloud-method
@@ -297,6 +320,7 @@
       (string-to-number (match-string 1 string))
     0))
 
+;; TODO: use this
 (defun gnus-cloud-prune-old-chunks (headers)
   (let ((headers (reverse headers))
        (found nil))
@@ -320,7 +344,13 @@
     (dolist (header (gnus-cloud-available-chunks))
       (when (> (gnus-cloud-chunk-sequence (mail-header-subject header))
               gnus-cloud-sequence)
-       (push (mail-header-number header) articles)))
+        (let ((header-storage-method (mail-header 
"X-Gnus-Cloud-Storage-Method" header)))
+          (if (equal header-storage-method (format "%s" 
gnus-cloud-storage-method))
+            (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"
+                        (mail-header-number header)
+                        header-storage-method
+                        gnus-cloud-storage-method)))))
     (when articles
       (nnimap-request-articles (nreverse articles) gnus-cloud-group-name)
       (with-current-buffer nntp-server-buffer