code.delx.au - gnu-emacs/blob - lisp/gnus/gnus-cloud.el

   1 ;;; gnus-cloud.el --- storing and retrieving data via IMAP
   2
   3 ;; Copyright (C) 2014 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;; Keywords: mail
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;;; Code:
  26
  27 (eval-when-compile (require 'cl))
  28 (require 'parse-time)
  29 (require 'nnimap)
  30
  31 (defgroup gnus-cloud nil
  32   "Syncing Gnus data via IMAP."
  33   :group 'gnus)
  34
  35 (defcustom gnus-cloud-synced-files
  36   '(;;"~/.authinfo"
  37     "~/.authinfo.gpg"
  38     "~/.gnus.el"
  39     (:directory "~/News" :match ".*.SCORE\\'"))
  40   "List of file regexps that should be kept up-to-date via the cloud."
  41   :group 'gnus-cloud
  42   :type '(repeat regexp))
  43
  44 (defvar gnus-cloud-group-name "*Emacs Cloud*")
  45 (defvar gnus-cloud-covered-servers nil)
  46
  47 (defvar gnus-cloud-version 1)
  48 (defvar gnus-cloud-sequence 1)
  49
  50 (defvar gnus-cloud-method nil
  51   "The IMAP select method used to store the cloud data.")
  52
  53 (defun gnus-cloud-make-chunk (elems)
  54   (with-temp-buffer
  55     (insert (format "Version %s\n" gnus-cloud-version))
  56     (insert (gnus-cloud-insert-data elems))
  57     (buffer-string)))
  58
  59 (defun gnus-cloud-insert-data (elems)
  60   (mm-with-unibyte-buffer
  61     (dolist (elem elems)
  62       (cond
  63        ((eq (plist-get elem :type) :file)
  64         (let (length data)
  65           (mm-with-unibyte-buffer
  66             (insert-file-contents-literally (plist-get elem :file-name))
  67             (setq length (buffer-size)
  68                   data (buffer-string)))
  69           (insert (format "(:type :file :file-name %S :timestamp %S :length %d)\n"
  70                           (plist-get elem :file-name)
  71                           (plist-get elem :timestamp)
  72                           length))
  73           (insert data)
  74           (insert "\n")))
  75        ((eq (plist-get elem :type) :data)
  76         (insert (format "(:type :data :name %S :length %d)\n"
  77                         (plist-get elem :name)
  78                         (with-current-buffer (plist-get elem :buffer)
  79                           (buffer-size))))
  80         (insert-buffer-substring (plist-get elem :buffer))
  81         (insert "\n"))
  82        ((eq (plist-get elem :type) :delete)
  83         (insert (format "(:type :delete :file-name %S)\n"
  84                         (plist-get elem :file-name))))))
  85     (gnus-cloud-encode-data)
  86     (buffer-string)))
  87
  88 (defun gnus-cloud-encode-data ()
  89   (call-process-region (point-min) (point-max) "gzip"
  90                        t (current-buffer) nil
  91                        "-c")
  92   (base64-encode-region (point-min) (point-max)))
  93
  94 (defun gnus-cloud-decode-data ()
  95   (base64-decode-region (point-min) (point-max))
  96   (call-process-region (point-min) (point-max) "gunzip"
  97                        t (current-buffer) nil
  98                        "-c"))
  99
 100 (defun gnus-cloud-parse-chunk ()
 101   (save-excursion
 102     (goto-char (point-min))
 103     (unless (looking-at "Version \\([0-9]+\\)")
 104       (error "Not a valid Cloud chunk in the current buffer"))
 105     (forward-line 1)
 106     (let ((version (string-to-number (match-string 1)))
 107           (data (buffer-substring (point) (point-max))))
 108       (mm-with-unibyte-buffer
 109         (insert data)
 110         (cond
 111          ((= version 1)
 112           (gnus-cloud-decode-data)
 113           (goto-char (point-min))
 114           (gnus-cloud-parse-version-1))
 115          (t
 116           (error "Unsupported Cloud chunk version %s" version)))))))
 117
 118 (defun gnus-cloud-parse-version-1 ()
 119   (let ((elems nil))
 120     (while (not (eobp))
 121       (while (and (not (eobp))
 122                   (not (looking-at "(:type")))
 123         (forward-line 1))
 124       (unless (eobp)
 125         (let ((spec (ignore-errors (read (current-buffer))))
 126               length)
 127           (when (and (consp spec)
 128                      (memq (plist-get spec :type) '(:file :data :delete)))
 129             (setq length (plist-get spec :length))
 130             (push (append spec
 131                           (list
 132                            :contents (buffer-substring (1+ (point))
 133                                                        (+ (point) 1 length))))
 134                   elems)
 135             (goto-char (+ (point) 1 length))))))
 136     (nreverse elems)))
 137
 138 (defun gnus-cloud-update-data (elems)
 139   (dolist (elem elems)
 140     (let ((type (plist-get elem :type)))
 141       (cond
 142        ((eq type :data)
 143         )
 144        ((eq type :delete)
 145         (gnus-cloud-delete-file (plist-get elem :file-name))
 146         )
 147        ((eq type :file)
 148         (gnus-cloud-update-file elem))
 149        (t
 150         (message "Unknown type %s; ignoring" type))))))
 151
 152 (defun gnus-cloud-update-file (elem)
 153   (let ((file-name (plist-get elem :file-name))
 154         (date (plist-get elem :timestamp))
 155         (contents (plist-get elem :contents)))
 156     (unless (gnus-cloud-file-covered-p file-name)
 157       (message "%s isn't covered by the cloud; ignoring" file-name))
 158     (when (or (not (file-exists-p file-name))
 159               (and (file-exists-p file-name)
 160                    (mm-with-unibyte-buffer
 161                      (insert-file-contents-literally file-name)
 162                      (not (equal (buffer-string) contents)))))
 163       (gnus-cloud-replace-file file-name date contents))))
 164
 165 (defun gnus-cloud-replace-file (file-name date new-contents)
 166   (mm-with-unibyte-buffer
 167     (insert new-contents)
 168     (when (file-exists-p file-name)
 169       (rename-file file-name (car (find-backup-file-name file-name))))
 170     (write-region (point-min) (point-max) file-name)
 171     (set-file-times file-name (parse-iso8601-time-string date))))
 172
 173 (defun gnus-cloud-delete-file (file-name)
 174   (unless (gnus-cloud-file-covered-p file-name)
 175     (message "%s isn't covered by the cloud; ignoring" file-name))
 176   (when (file-exists-p file-name)
 177     (rename-file file-name (car (find-backup-file-name file-name)))))
 178
 179 (defun gnus-cloud-file-covered-p (file-name)
 180   (let ((matched nil))
 181     (dolist (elem gnus-cloud-synced-files)
 182       (cond
 183        ((stringp elem)
 184         (when (equal elem file-name)
 185           (setq matched t)))
 186        ((consp elem)
 187         (when (and (equal (directory-file-name (plist-get elem :directory))
 188                           (directory-file-name (file-name-directory file-name)))
 189                    (string-match (plist-get elem :match)
 190                                  (file-name-nondirectory file-name)))
 191           (setq matched t)))))
 192     matched))
 193
 194 (defun gnus-cloud-all-files ()
 195   (let ((files nil))
 196     (dolist (elem gnus-cloud-synced-files)
 197       (cond
 198        ((stringp elem)
 199         (push elem files))
 200        ((consp elem)
 201         (dolist (file (directory-files (plist-get elem :directory)
 202                                        nil
 203                                        (plist-get elem :match)))
 204           (push (format "%s/%s"
 205                         (directory-file-name (plist-get elem :directory))
 206                         file)
 207                 files)))))
 208     (nreverse files)))
 209
 210 (defvar gnus-cloud-file-timestamps nil)
 211
 212 (defun gnus-cloud-files-to-upload (&optional full)
 213   (let ((files nil)
 214         timestamp)
 215     (dolist (file (gnus-cloud-all-files))
 216       (if (file-exists-p file)
 217           (when (setq timestamp (gnus-cloud-file-new-p file full))
 218             (push `(:type :file :file-name ,file :timestamp ,timestamp) files))
 219         (when (assoc file gnus-cloud-file-timestamps)
 220           (push `(:type :delete :file-name ,file) files))))
 221     (nreverse files)))
 222
 223 (defun gnus-cloud-file-new-p (file full)
 224   (let ((timestamp (format-time-string
 225                     "%FT%T%z" (nth 5 (file-attributes file))))
 226         (old (cadr (assoc file gnus-cloud-file-timestamps))))
 227     (when (or full
 228               (null old)
 229               (string< old timestamp))
 230       timestamp)))
 231
 232 (declare-function gnus-activate-group "gnus-start"
 233                   (group &optional scan dont-check method dont-sub-check))
 234 (declare-function gnus-subscribe-group "gnus-start"
 235                   (group &optional previous method))
 236
 237 (defun gnus-cloud-ensure-cloud-group ()
 238   (let ((method (if (stringp gnus-cloud-method)
 239                     (gnus-server-to-method gnus-cloud-method)
 240                   gnus-cloud-method)))
 241     (unless (or (gnus-active gnus-cloud-group-name)
 242                 (gnus-activate-group gnus-cloud-group-name nil nil
 243                                      gnus-cloud-method))
 244       (and (gnus-request-create-group gnus-cloud-group-name gnus-cloud-method)
 245            (gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method)
 246            (gnus-subscribe-group gnus-cloud-group-name)))))
 247
 248 (defun gnus-cloud-upload-data (&optional full)
 249   (gnus-cloud-ensure-cloud-group)
 250   (with-temp-buffer
 251     (let ((elems (gnus-cloud-files-to-upload full)))
 252       (insert (format "Subject: (sequence: %d type: %s)\n"
 253                       gnus-cloud-sequence
 254                       (if full :full :partial)))
 255       (insert "From: nobody@invalid.com\n")
 256       (insert "\n")
 257       (insert (gnus-cloud-make-chunk elems))
 258       (when (gnus-request-accept-article gnus-cloud-group-name gnus-cloud-method
 259                                          t t)
 260         (setq gnus-cloud-sequence (1+ gnus-cloud-sequence))
 261         (gnus-cloud-add-timestamps elems)))))
 262
 263 (defun gnus-cloud-add-timestamps (elems)
 264   (dolist (elem elems)
 265     (let* ((file-name (plist-get elem :file-name))
 266            (old (assoc file-name gnus-cloud-file-timestamps)))
 267       (when old
 268         (setq gnus-cloud-file-timestamps
 269               (delq old gnus-cloud-file-timestamps)))
 270       (push (list file-name (plist-get elem :timestamp))
 271             gnus-cloud-file-timestamps))))
 272
 273 (defun gnus-cloud-available-chunks ()
 274   (gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method)
 275   (let* ((group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method))
 276          (active (gnus-active group))
 277          headers head)
 278     (when (gnus-retrieve-headers (gnus-uncompress-range active) group)
 279       (with-current-buffer nntp-server-buffer
 280         (goto-char (point-min))
 281         (while (and (not (eobp))
 282                     (setq head (nnheader-parse-head)))
 283           (push head headers))))
 284     (sort (nreverse headers)
 285           (lambda (h1 h2)
 286             (> (gnus-cloud-chunk-sequence (mail-header-subject h1))
 287                (gnus-cloud-chunk-sequence (mail-header-subject h2)))))))
 288
 289 (defun gnus-cloud-chunk-sequence (string)
 290   (if (string-match "sequence: \\([0-9]+\\)" string)
 291       (string-to-number (match-string 1 string))
 292     0))
 293
 294 (defun gnus-cloud-prune-old-chunks (headers)
 295   (let ((headers (reverse headers))
 296         (found nil))
 297   (while (and headers
 298               (not found))
 299     (when (string-match "type: :full" (mail-header-subject (car headers)))
 300       (setq found t))
 301     (pop headers))
 302   ;; All the chunks that are older than the newest :full chunk can be
 303   ;; deleted.
 304   (when headers
 305     (gnus-request-expire-articles
 306      (mapcar (lambda (h)
 307                (mail-header-number h))
 308              (nreverse headers))
 309      (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method)))))
 310
 311 (defun gnus-cloud-download-data ()
 312   (let ((articles nil)
 313         chunks)
 314     (dolist (header (gnus-cloud-available-chunks))
 315       (when (> (gnus-cloud-chunk-sequence (mail-header-subject header))
 316                gnus-cloud-sequence)
 317         (push (mail-header-number header) articles)))
 318     (when articles
 319       (nnimap-request-articles (nreverse articles) gnus-cloud-group-name)
 320       (with-current-buffer nntp-server-buffer
 321         (goto-char (point-min))
 322         (while (re-search-forward "^Version " nil t)
 323           (beginning-of-line)
 324           (push (gnus-cloud-parse-chunk) chunks)
 325           (forward-line 1))))))
 326
 327 (defun gnus-cloud-server-p (server)
 328   (member server gnus-cloud-covered-servers))
 329
 330 (provide 'gnus-cloud)
 331
 332 ;;; gnus-cloud.el ends here