X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-cloud.el;h=c47976bdcfa851db94c72b5ff6b7d175babde027;hb=073ff61fbe32f1ee26096dba8da9243c0269fe6f;hp=133e6c18dcccf6787d111a85d91c414245ff1b8a;hpb=7ad464af4737b14cd4c6dff2c2dc18bc0c40fca4;p=gnus

diff --git a/lisp/gnus-cloud.el b/lisp/gnus-cloud.el
index 133e6c18d..c47976bdc 100644
--- a/lisp/gnus-cloud.el
+++ b/lisp/gnus-cloud.el
@@ -25,13 +25,15 @@
 ;;; Code:
 
 (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\\'"))
@@ -39,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.")
@@ -54,25 +60,28 @@
   (mm-with-unibyte-buffer
     (dolist (elem elems)
       (cond
-       ((eq (car elem) :file)
+       ((eq (plist-get elem :type) :file)
 	(let (length data)
 	  (mm-with-unibyte-buffer
-	    (insert-file-contents-literally (cadr elem))
+	    (insert-file-contents-literally (plist-get elem :file-name))
 	    (setq length (buffer-size)
 		  data (buffer-string)))
-	  (insert (format "(:file %S %S %d)\n"
-			  (cadr elem)
-			  (format-time-string
-			   "%FT%T%z" (nth 5 (file-attributes (cadr elem))))
+	  (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 (car elem) :buffer)
-	(insert (format "(:data %S %d)\n" (cadr elem)
-			(with-current-buffer (caddr elem)
+       ((eq (plist-get elem :type) :data)
+	(insert (format "(:type :data :name %S :length %d)\n"
+			(plist-get elem :name)
+			(with-current-buffer (plist-get elem :buffer)
 			  (buffer-size))))
-	(insert-buffer-substring (caddr elem))
-	(insert "\n"))))
+	(insert-buffer-substring (plist-get elem :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)))
 
@@ -101,6 +110,7 @@
 	(cond
 	 ((= version 1)
 	  (gnus-cloud-decode-data)
+	  (goto-char (point-min))
 	  (gnus-cloud-parse-version-1))
 	 (t
 	  (error "Unsupported Cloud chunk version %s" version)))))))
@@ -109,39 +119,40 @@
   (let ((elems nil))
     (while (not (eobp))
       (while (and (not (eobp))
-		  (not (looking-at "(:file\\|(:data")))
+		  (not (looking-at "(:type")))
 	(forward-line 1))
       (unless (eobp)
 	(let ((spec (ignore-errors (read (current-buffer))))
 	      length)
 	  (when (and (consp spec)
-		     (or (eq (car spec) :file)
-			 (eq (car spec) :data)))
-	    (setq length (car (last spec)))
-	    (push (append (butlast spec)
+		     (memq (plist-get spec :type) '(:file :data :deleta)))
+	    (setq length (plist-get spec :length))
+	    (push (append spec
 			  (list
-			   (buffer-substring (1+ (point))
-					     (+ (point) 1 length))))
+			   :contents (buffer-substring (1+ (point))
+						       (+ (point) 1 length))))
 		  elems)
 	    (goto-char (+ (point) 1 length))))))
     (nreverse elems)))
 
 (defun gnus-cloud-update-data (elems)
   (dolist (elem elems)
-    (cond
-     ((eq (car elem) :data)
-      )
-     ((eq (car elem) :file)
-      (unless (= (length elem) 4)
-	(error "Invalid length of a file spec: %s" (length elem)))
-      (gnus-cloud-update-file (cdr elem)))
-     (t
-      (error "Unknown type %s" (car elem))))))
+    (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))
+       (t
+	(message "Unknown type %s; ignoring" type))))))
 
 (defun gnus-cloud-update-file (elem)
-  (let ((file-name (pop elem))
-	(date (pop elem))
-	(contents (pop elem)))
+  (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))
@@ -155,9 +166,15 @@
   (mm-with-unibyte-buffer
     (insert new-contents)
     (when (file-exists-p file-name)
-      (let ((backup (car (find-backup-file-name file-name))))
-	(rename-file file-name backup)))
-    (write-region (point-min) (point-max) file-name)))
+      (rename-file file-name (car (find-backup-file-name file-name))))
+    (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))
@@ -174,6 +191,142 @@
 	  (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-file-new-p (file full)
+  (let ((timestamp (format-time-string
+		    "%FT%T%z" (nth 5 (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-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