cgit.sxemacs.org Git - gnus/blob - lisp/nnmaildir.el

   1 ;;; nnmaildir.el --- maildir backend for Gnus
   2
   3 ;; This file is in the public domain.
   4
   5 ;; Author: Paul Jarc <prj@po.cwru.edu>
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software: you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23
  24 ;; Maildir format is documented at <URL:http://cr.yp.to/proto/maildir.html>
  25 ;; and in the maildir(5) man page from qmail (available at
  26 ;; <URL:http://www.qmail.org/man/man5/maildir.html>).  nnmaildir also stores
  27 ;; extra information in the .nnmaildir/ directory within a maildir.
  28 ;;
  29 ;; Some goals of nnmaildir:
  30 ;; * Everything Just Works, and correctly.  E.g., NOV data is automatically
  31 ;;   regenerated when stale; no need for manually running
  32 ;;   *-generate-nov-databases.
  33 ;; * Perfect reliability: [C-g] will never corrupt its data in memory, and
  34 ;;   SIGKILL will never corrupt its data in the filesystem.
  35 ;; * Allow concurrent operation as much as possible.  If files change out
  36 ;;   from under us, adapt to the changes or degrade gracefully.
  37 ;; * We use the filesystem as a database, so that, e.g., it's easy to
  38 ;;   manipulate marks from outside Gnus.
  39 ;; * All information about a group is stored in the maildir, for easy backup,
  40 ;;   copying, restoring, etc.
  41 ;;
  42 ;; Todo:
  43 ;; * When moving an article for expiry, copy all the marks except 'expire
  44 ;;   from the original article.
  45 ;; * Add a hook for when moving messages from new/ to cur/, to support
  46 ;;   nnmail's duplicate detection.
  47 ;; * Improve generated Xrefs, so crossposts are detectable.
  48 ;; * Improve code readability.
  49
  50 ;;; Code:
  51
  52 ;; eval this before editing
  53 [(progn
  54    (put 'nnmaildir--with-nntp-buffer 'lisp-indent-function 0)
  55    (put 'nnmaildir--with-work-buffer 'lisp-indent-function 0)
  56    (put 'nnmaildir--with-nov-buffer  'lisp-indent-function 0)
  57    (put 'nnmaildir--with-move-buffer 'lisp-indent-function 0)
  58    (put 'nnmaildir--condcase         'lisp-indent-function 2)
  59    )
  60 ]
  61
  62 ;; For Emacs <22.2 and XEmacs.
  63 (eval-and-compile
  64   (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
  65
  66 (eval-and-compile
  67   (require 'nnheader)
  68   (require 'gnus)
  69   (require 'gnus-util)
  70   (require 'gnus-range)
  71   (require 'gnus-start)
  72   (require 'gnus-int)
  73   (require 'message))
  74 (eval-when-compile
  75   (require 'cl)
  76   (require 'nnmail))
  77
  78 (defconst nnmaildir-version "Gnus")
  79
  80 (defconst nnmaildir-flag-mark-mapping
  81   '((?F . tick)
  82     (?R . reply)
  83     (?S . read))
  84   "Alist mapping Maildir filename flags to Gnus marks.
  85 Maildir filenames are of the form \"unique-id:2,FLAGS\",
  86 where FLAGS are a string of characters in ASCII order.
  87 Some of the FLAGS correspond to Gnus marks.")
  88
  89 (defsubst nnmaildir--mark-to-flag (mark)
  90   "Find the Maildir flag that corresponds to MARK (an atom).
  91 Return a character, or `nil' if not found.
  92 See `nnmaildir-flag-mark-mapping'."
  93   (car (rassq mark nnmaildir-flag-mark-mapping)))
  94
  95 (defsubst nnmaildir--flag-to-mark (flag)
  96   "Find the Gnus mark that corresponds to FLAG (a character).
  97 Return an atom, or `nil' if not found.
  98 See `nnmaildir-flag-mark-mapping'."
  99   (cdr (assq flag nnmaildir-flag-mark-mapping)))
 100
 101 (defun nnmaildir--ensure-suffix (filename)
 102   "Ensure that FILENAME contains the suffix \":2,\"."
 103   (if (gnus-string-match-p ":2," filename)
 104       filename
 105     (concat filename ":2,")))
 106
 107 (defun nnmaildir--add-flag (flag suffix)
 108   "Return a copy of SUFFIX where FLAG is set.
 109 SUFFIX should start with \":2,\"."
 110   (unless (gnus-string-match-p "^:2," suffix)
 111     (error "Invalid suffix `%s'" suffix))
 112   (let* ((flags (substring suffix 3))
 113          (flags-as-list (append flags nil))
 114          (new-flags
 115           (concat (gnus-delete-duplicates
 116                    ;; maildir flags must be sorted
 117                    (sort (cons flag flags-as-list) '<)))))
 118     (concat ":2," new-flags)))
 119
 120 (defun nnmaildir--remove-flag (flag suffix)
 121   "Return a copy of SUFFIX where FLAG is cleared.
 122 SUFFIX should start with \":2,\"."
 123   (unless (gnus-string-match-p "^:2," suffix)
 124     (error "Invalid suffix `%s'" suffix))
 125   (let* ((flags (substring suffix 3))
 126          (flags-as-list (append flags nil))
 127          (new-flags (concat (delq flag flags-as-list))))
 128     (concat ":2," new-flags)))
 129
 130 (defvar nnmaildir-article-file-name nil
 131   "*The filename of the most recently requested article.  This variable is set
 132 by nnmaildir-request-article.")
 133
 134 ;; The filename of the article being moved/copied:
 135 (defvar nnmaildir--file nil)
 136
 137 ;; Variables to generate filenames of messages being delivered:
 138 (defvar   nnmaildir--delivery-time "")
 139 (defconst nnmaildir--delivery-pid (concat "P" (number-to-string (emacs-pid))))
 140 (defvar   nnmaildir--delivery-count nil)
 141
 142 ;; An obarry containing symbols whose names are server names and whose values
 143 ;; are servers:
 144 (defvar nnmaildir--servers (make-vector 3 0))
 145 ;; The current server:
 146 (defvar nnmaildir--cur-server nil)
 147
 148 ;; A copy of nnmail-extra-headers
 149 (defvar nnmaildir--extra nil)
 150
 151 ;; A NOV structure looks like this (must be prin1-able, so no defstruct):
 152 ["subject\tfrom\tdate"
 153  "references\tchars\lines"
 154  "To: you\tIn-Reply-To: <your.mess@ge>"
 155  (12345 67890)     ;; modtime of the corresponding article file
 156  (to in-reply-to)] ;; contemporary value of nnmail-extra-headers
 157 (defconst nnmaildir--novlen 5)
 158 (defmacro nnmaildir--nov-new (beg mid end mtime extra)
 159   `(vector ,beg ,mid ,end ,mtime ,extra))
 160 (defmacro nnmaildir--nov-get-beg   (nov) `(aref ,nov 0))
 161 (defmacro nnmaildir--nov-get-mid   (nov) `(aref ,nov 1))
 162 (defmacro nnmaildir--nov-get-end   (nov) `(aref ,nov 2))
 163 (defmacro nnmaildir--nov-get-mtime (nov) `(aref ,nov 3))
 164 (defmacro nnmaildir--nov-get-extra (nov) `(aref ,nov 4))
 165 (defmacro nnmaildir--nov-set-beg   (nov value) `(aset ,nov 0 ,value))
 166 (defmacro nnmaildir--nov-set-mid   (nov value) `(aset ,nov 1 ,value))
 167 (defmacro nnmaildir--nov-set-end   (nov value) `(aset ,nov 2 ,value))
 168 (defmacro nnmaildir--nov-set-mtime (nov value) `(aset ,nov 3 ,value))
 169 (defmacro nnmaildir--nov-set-extra (nov value) `(aset ,nov 4 ,value))
 170
 171 (defstruct nnmaildir--art
 172   (prefix nil :type string)  ;; "time.pid.host"
 173   (suffix nil :type string)  ;; ":2,flags"
 174   (num    nil :type natnum)  ;; article number
 175   (msgid  nil :type string)  ;; "<mess.age@id>"
 176   (nov    nil :type vector)) ;; cached nov structure, or nil
 177
 178 (defstruct nnmaildir--grp
 179   (name  nil :type string)  ;; "group.name"
 180   (new   nil :type list)    ;; new/ modtime
 181   (cur   nil :type list)    ;; cur/ modtime
 182   (min   1   :type natnum)  ;; minimum article number
 183   (count 0   :type natnum)  ;; count of articles
 184   (nlist nil :type list)    ;; list of articles, ordered descending by number
 185   (flist nil :type vector)  ;; obarray mapping filename prefix->article
 186   (mlist nil :type vector)  ;; obarray mapping message-id->article
 187   (cache nil :type vector)  ;; nov cache
 188   (index nil :type natnum)  ;; index of next cache entry to replace
 189   (mmth  nil :type vector)) ;; obarray mapping mark name->dir modtime
 190                                         ; ("Mark Mod Time Hash")
 191
 192 (defstruct nnmaildir--srv
 193   (address       nil :type string)         ;; server address string
 194   (method        nil :type list)           ;; (nnmaildir "address" ...)
 195   (prefix        nil :type string)         ;; "nnmaildir+address:"
 196   (dir           nil :type string)         ;; "/expanded/path/to/server/dir/"
 197   (ls            nil :type function)       ;; directory-files function
 198   (groups        nil :type vector)         ;; obarray mapping group name->group
 199   (curgrp        nil :type nnmaildir--grp) ;; current group, or nil
 200   (error         nil :type string)         ;; last error message, or nil
 201   (mtime         nil :type list)           ;; modtime of dir
 202   (gnm           nil)                      ;; flag: split from mail-sources?
 203   (target-prefix nil :type string))        ;; symlink target prefix
 204
 205 (defun nnmaildir--article-set-flags (article new-suffix curdir)
 206   (let* ((prefix (nnmaildir--art-prefix article))
 207          (suffix (nnmaildir--art-suffix article))
 208          (article-file (concat curdir prefix suffix))
 209          (new-name (concat curdir prefix new-suffix)))
 210     (unless (file-exists-p article-file)
 211       (error "Couldn't find article file %s" article-file))
 212     (rename-file article-file new-name 'replace)
 213     (setf (nnmaildir--art-suffix article) new-suffix)))
 214
 215 (defun nnmaildir--expired-article (group article)
 216   (setf (nnmaildir--art-nov article) nil)
 217   (let ((flist  (nnmaildir--grp-flist group))
 218         (mlist  (nnmaildir--grp-mlist group))
 219         (min    (nnmaildir--grp-min   group))
 220         (count  (1- (nnmaildir--grp-count group)))
 221         (prefix (nnmaildir--art-prefix article))
 222         (msgid  (nnmaildir--art-msgid  article))
 223         (new-nlist nil)
 224         (nlist-pre '(nil . nil))
 225         nlist-post num)
 226     (unless (zerop count)
 227       (setq nlist-post (nnmaildir--grp-nlist group)
 228             num (nnmaildir--art-num article))
 229       (if (eq num (caar nlist-post))
 230           (setq new-nlist (cdr nlist-post))
 231         (setq new-nlist nlist-post
 232               nlist-pre nlist-post
 233               nlist-post (cdr nlist-post))
 234         (while (/= num (caar nlist-post))
 235           (setq nlist-pre nlist-post
 236                 nlist-post (cdr nlist-post)))
 237         (setq nlist-post (cdr nlist-post))
 238         (if (eq num min)
 239             (setq min (caar nlist-pre)))))
 240     (let ((inhibit-quit t))
 241       (setf (nnmaildir--grp-min   group) min)
 242       (setf (nnmaildir--grp-count group) count)
 243       (setf (nnmaildir--grp-nlist group) new-nlist)
 244       (setcdr nlist-pre nlist-post)
 245       (unintern prefix flist)
 246       (unintern msgid mlist))))
 247
 248 (defun nnmaildir--nlist-art (group num)
 249   (let ((entry (assq num (nnmaildir--grp-nlist group))))
 250     (if entry
 251         (cdr entry))))
 252 (defmacro nnmaildir--flist-art (list file)
 253   `(symbol-value (intern-soft ,file ,list)))
 254 (defmacro nnmaildir--mlist-art (list msgid)
 255   `(symbol-value (intern-soft ,msgid ,list)))
 256
 257 (defun nnmaildir--pgname (server gname)
 258   (let ((prefix (nnmaildir--srv-prefix server)))
 259     (if prefix (concat prefix gname)
 260       (setq gname (gnus-group-prefixed-name gname
 261                                             (nnmaildir--srv-method server)))
 262       (setf (nnmaildir--srv-prefix server) (gnus-group-real-prefix gname))
 263       gname)))
 264
 265 (defun nnmaildir--param (pgname param)
 266   (setq param (gnus-group-find-parameter pgname param 'allow-list))
 267   (if (vectorp param) (setq param (aref param 0)))
 268   (eval param))
 269
 270 (defmacro nnmaildir--with-nntp-buffer (&rest body)
 271   (declare (debug (body)))
 272   `(with-current-buffer nntp-server-buffer
 273      ,@body))
 274 (defmacro nnmaildir--with-work-buffer (&rest body)
 275   (declare (debug (body)))
 276   `(with-current-buffer (get-buffer-create " *nnmaildir work*")
 277      ,@body))
 278 (defmacro nnmaildir--with-nov-buffer (&rest body)
 279   (declare (debug (body)))
 280   `(with-current-buffer (get-buffer-create " *nnmaildir nov*")
 281      ,@body))
 282 (defmacro nnmaildir--with-move-buffer (&rest body)
 283   (declare (debug (body)))
 284   `(with-current-buffer (get-buffer-create " *nnmaildir move*")
 285      ,@body))
 286
 287 (defsubst nnmaildir--subdir (dir subdir)
 288   (file-name-as-directory (concat dir subdir)))
 289 (defsubst nnmaildir--srvgrp-dir (srv-dir gname)
 290   (nnmaildir--subdir srv-dir gname))
 291 (defsubst nnmaildir--tmp       (dir) (nnmaildir--subdir dir "tmp"))
 292 (defsubst nnmaildir--new       (dir) (nnmaildir--subdir dir "new"))
 293 (defsubst nnmaildir--cur       (dir) (nnmaildir--subdir dir "cur"))
 294 (defsubst nnmaildir--nndir     (dir) (nnmaildir--subdir dir ".nnmaildir"))
 295 (defsubst nnmaildir--nov-dir   (dir) (nnmaildir--subdir dir "nov"))
 296 (defsubst nnmaildir--marks-dir (dir) (nnmaildir--subdir dir "marks"))
 297 (defsubst nnmaildir--num-dir   (dir) (nnmaildir--subdir dir "num"))
 298
 299 (defmacro nnmaildir--unlink (file-arg)
 300   `(let ((file ,file-arg))
 301      (if (file-attributes file) (delete-file file))))
 302 (defun nnmaildir--mkdir (dir)
 303   (or (file-exists-p (file-name-as-directory dir))
 304       (make-directory-internal (directory-file-name dir))))
 305 (defun nnmaildir--mkfile (file)
 306   (write-region "" nil file nil 'no-message))
 307 (defun nnmaildir--delete-dir-files (dir ls)
 308   (when (file-attributes dir)
 309     (mapc 'delete-file (funcall ls dir 'full "\\`[^.]" 'nosort))
 310     (delete-directory dir)))
 311
 312 (defun nnmaildir--group-maxnum (server group)
 313   (catch 'return
 314     (if (zerop (nnmaildir--grp-count group)) (throw 'return 0))
 315     (let ((dir (nnmaildir--srvgrp-dir (nnmaildir--srv-dir server)
 316                                     (nnmaildir--grp-name group)))
 317           (number-opened 1)
 318           attr ino-opened nlink number-linked)
 319       (setq dir (nnmaildir--nndir dir)
 320             dir (nnmaildir--num-dir dir))
 321       (while t
 322         (setq attr (file-attributes
 323                     (concat dir (number-to-string number-opened))))
 324         (or attr (throw 'return (1- number-opened)))
 325         (setq ino-opened (nth 10 attr)
 326               nlink (nth 1 attr)
 327               number-linked (+ number-opened nlink))
 328         (if (or (< nlink 1) (< number-linked nlink))
 329             (signal 'error '("Arithmetic overflow")))
 330         (setq attr (file-attributes
 331                     (concat dir (number-to-string number-linked))))
 332         (or attr (throw 'return (1- number-linked)))
 333         (unless (equal ino-opened (nth 10 attr))
 334           (setq number-opened number-linked))))))
 335
 336 ;; Make the given server, if non-nil, be the current server.  Then make the
 337 ;; given group, if non-nil, be the current group of the current server.  Then
 338 ;; return the group object for the current group.
 339 (defun nnmaildir--prepare (server group)
 340   (let (x groups)
 341     (catch 'return
 342       (if (null server)
 343           (unless (setq server nnmaildir--cur-server)
 344             (throw 'return nil))
 345         (unless (setq server (intern-soft server nnmaildir--servers))
 346           (throw 'return nil))
 347         (setq server (symbol-value server)
 348               nnmaildir--cur-server server))
 349       (unless (setq groups (nnmaildir--srv-groups server))
 350         (throw 'return nil))
 351       (unless (nnmaildir--srv-method server)
 352         (setq x (concat "nnmaildir:" (nnmaildir--srv-address server))
 353               x (gnus-server-to-method x))
 354         (unless x (throw 'return nil))
 355         (setf (nnmaildir--srv-method server) x))
 356       (if (null group)
 357           (unless (setq group (nnmaildir--srv-curgrp server))
 358             (throw 'return nil))
 359         (unless (setq group (intern-soft group groups))
 360           (throw 'return nil))
 361         (setq group (symbol-value group)))
 362       group)))
 363
 364 (defun nnmaildir--tab-to-space (string)
 365   (let ((pos 0))
 366     (while (string-match "\t" string pos)
 367       (aset string (match-beginning 0) ? )
 368       (setq pos (match-end 0))))
 369   string)
 370
 371 (defmacro nnmaildir--condcase (errsym body &rest handler)
 372   (declare (debug (sexp form body)))
 373   `(condition-case ,errsym
 374        (let ((system-messages-locale "C")) ,body)
 375      (error . ,handler)))
 376
 377 (defun nnmaildir--emlink-p (err)
 378   (and (eq (car err) 'file-error)
 379        (string= (downcase (caddr err)) "too many links")))
 380
 381 (defun nnmaildir--enoent-p (err)
 382   (and (eq (car err) 'file-error)
 383        (string= (downcase (caddr err)) "no such file or directory")))
 384
 385 (defun nnmaildir--eexist-p (err)
 386   (eq (car err) 'file-already-exists))
 387
 388 (defun nnmaildir--new-number (nndir)
 389   "Allocate a new article number by atomically creating a file under NNDIR."
 390   (let ((numdir (nnmaildir--num-dir nndir))
 391         (make-new-file t)
 392         (number-open 1)
 393         number-link previous-number-link path-open path-link ino-open)
 394     (nnmaildir--mkdir numdir)
 395     (catch 'return
 396       (while t
 397         (setq path-open (concat numdir (number-to-string number-open)))
 398         (if (not make-new-file)
 399             (setq previous-number-link number-link)
 400           (nnmaildir--mkfile path-open)
 401           ;; If Emacs had O_CREAT|O_EXCL, we could return number-open here.
 402           (setq make-new-file nil
 403                 previous-number-link 0))
 404         (let* ((attr (file-attributes path-open))
 405                (nlink (nth 1 attr)))
 406           (setq ino-open (nth 10 attr)
 407                 number-link (+ number-open nlink))
 408           (if (or (< nlink 1) (< number-link nlink))
 409               (signal 'error '("Arithmetic overflow"))))
 410         (if (= number-link previous-number-link)
 411             ;; We've already tried this number, in the previous loop iteration,
 412             ;; and failed.
 413             (signal 'error `("Corrupt internal nnmaildir data" ,path-open)))
 414         (setq path-link (concat numdir (number-to-string number-link)))
 415         (nnmaildir--condcase err
 416             (progn
 417               (add-name-to-file path-open path-link)
 418               (throw 'return number-link))
 419           (cond
 420            ((nnmaildir--emlink-p err)
 421             (setq make-new-file t
 422                   number-open number-link))
 423            ((nnmaildir--eexist-p err)
 424             (let ((attr (file-attributes path-link)))
 425               (unless (equal (nth 10 attr) ino-open)
 426                 (setq number-open number-link
 427                       number-link 0))))
 428            (t (signal (car err) (cdr err)))))))))
 429
 430 (defun nnmaildir--update-nov (server group article)
 431   (let ((nnheader-file-coding-system 'binary)
 432         (srv-dir (nnmaildir--srv-dir server))
 433         (storage-version 1) ;; [version article-number msgid [...nov...]]
 434         dir gname pgname msgdir prefix suffix file attr mtime novdir novfile
 435         nov msgid nov-beg nov-mid nov-end field val old-extra num numdir
 436         deactivate-mark)
 437     (catch 'return