gnus-art.el (gnus-mime-buttonize-attachments-in-header): Improve criterion that finds...

[gnus] / lisp / gnus-cloud.el

diff --git a/lisp/gnus-cloud.el b/lisp/gnus-cloud.el
index 3a6d6cd..c47976b 100644 (file)
--- a/lisp/gnus-cloud.el
+++ b/lisp/gnus-cloud.el
@@ -26,13 +26,14 @@
 
 (eval-when-compile (require 'cl))
 (require 'parse-time)
+(require 'nnimap)
 
 (defgroup gnus-cloud nil
   "Syncing Gnus data via IMAP."
   :group 'gnus)
 
 (defcustom gnus-cloud-synced-files
-  '("~/.authinfo"
+  '(;;"~/.authinfo"
     "~/.authinfo.gpg"
     "~/.gnus.el"
     (:directory "~/News" :match ".*.SCORE\\'"))
@@ -40,7 +41,11 @@
   :group 'gnus-cloud
   :type '(repeat regexp))
 
+(defvar gnus-cloud-group-name "*Emacs Cloud*")
+(defvar gnus-cloud-covered-servers nil)
+
 (defvar gnus-cloud-version 1)
+(defvar gnus-cloud-sequence 1)
 
 (defvar gnus-cloud-method nil
   "The IMAP select method used to store the cloud data.")
@@ -120,7 +125,7 @@
        (let ((spec (ignore-errors (read (current-buffer))))
              length)
          (when (and (consp spec)
-                    (memq (getf spec :type) '(:file :data :deleta)))
+                    (memq (plist-get spec :type) '(:file :data :deleta)))
            (setq length (plist-get spec :length))
            (push (append spec
                          (list
@@ -224,6 +229,104 @@
              (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-data (&optional full)
+  (gnus-cloud-ensure-cloud-group)
+  (with-temp-buffer
+    (let ((elems (gnus-cloud-files-to-upload full)))
+      (insert (format "Subject: (sequence: %d type: %s)\n"
+                     gnus-cloud-sequence
+                     (if full :full :partial)))
+      (insert "From: nobody@invalid.com\n")
+      (insert "\n")
+      (insert (gnus-cloud-make-chunk elems))
+      (when (gnus-request-accept-article gnus-cloud-group-name gnus-cloud-method
+                                        t t)
+       (setq gnus-cloud-sequence (1+ gnus-cloud-sequence))
+       (gnus-cloud-add-timestamps elems)))))
+
+(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 (gnus-uncompress-range active) group)
+      (with-current-buffer nntp-server-buffer
+       (goto-char (point-min))
+       (while (and (not (eobp))
+                   (setq head (nnheader-parse-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))
+
+(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-data ()
+  (let ((articles nil)
+       chunks)
+    (dolist (header (gnus-cloud-available-chunks))
+      (when (> (gnus-cloud-chunk-sequence (mail-header-subject header))
+              gnus-cloud-sequence)
+       (push (mail-header-number header) articles)))
+    (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)
+         (beginning-of-line)
+         (push (gnus-cloud-parse-chunk) chunks)
+         (forward-line 1))))))
+
+(defun gnus-cloud-server-p (server)
+  (member server gnus-cloud-covered-servers))
+
 (provide 'gnus-cloud)
 
 ;;; gnus-cloud.el ends here