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

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