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 ;; * When moving an article for expiry, copy all the marks except 'expire
  45 ;;   from the original article.
  46 ;; * Add a hook for when moving messages from new/ to cur/, to support
  47 ;;   nnmail's duplicate detection.
  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    (put 'nnmaildir--condcase         'lisp-indent-function 2)
  60    )
  61 ]
  62
  63 (eval-and-compile
  64   (require 'nnheader)
  65   (require 'gnus)
  66   (require 'gnus-util)
  67   (require 'gnus-range)
  68   (require 'gnus-start)
  69   (require 'gnus-int)
  70   (require 'message))
  71 (eval-when-compile
  72   (require 'cl)
  73   (require 'nnmail))
  74
  75 (defconst nnmaildir-version "Gnus")
  76
  77 (defvar nnmaildir-article-file-name nil
  78   "*The filename of the most recently requested article.  This variable is set
  79 by nnmaildir-request-article.")
  80
  81 ;; The filename of the article being moved/copied:
  82 (defvar nnmaildir--file nil)
  83
  84 ;; Variables to generate filenames of messages being delivered:
  85 (defvar   nnmaildir--delivery-time "")
  86 (defconst nnmaildir--delivery-pid (concat "P" (number-to-string (emacs-pid))))
  87 (defvar   nnmaildir--delivery-count nil)
  88
  89 ;; An obarry containing symbols whose names are server names and whose values
  90 ;; are servers:
  91 (defvar nnmaildir--servers (make-vector 3 0))
  92 ;; The current server:
  93 (defvar nnmaildir--cur-server nil)
  94
  95 ;; A copy of nnmail-extra-headers
  96 (defvar nnmaildir--extra nil)
  97
  98 ;; A NOV structure looks like this (must be prin1-able, so no defstruct):
  99 ["subject\tfrom\tdate"
 100  "references\tchars\lines"
 101  "To: you\tIn-Reply-To: <your.mess@ge>"
 102  (12345 67890)     ;; modtime of the corresponding article file
 103  (to in-reply-to)] ;; contemporary value of nnmail-extra-headers
 104 (defconst nnmaildir--novlen 5)
 105 (defmacro nnmaildir--nov-new (beg mid end mtime extra)
 106   `(vector ,beg ,mid ,end ,mtime ,extra))
 107 (defmacro nnmaildir--nov-get-beg   (nov) `(aref ,nov 0))
 108 (defmacro nnmaildir--nov-get-mid   (nov) `(aref ,nov 1))
 109 (defmacro nnmaildir--nov-get-end   (nov) `(aref ,nov 2))
 110 (defmacro nnmaildir--nov-get-mtime (nov) `(aref ,nov 3))
 111 (defmacro nnmaildir--nov-get-extra (nov) `(aref ,nov 4))
 112 (defmacro nnmaildir--nov-set-beg   (nov value) `(aset ,nov 0 ,value))
 113 (defmacro nnmaildir--nov-set-mid   (nov value) `(aset ,nov 1 ,value))
 114 (defmacro nnmaildir--nov-set-end   (nov value) `(aset ,nov 2 ,value))
 115 (defmacro nnmaildir--nov-set-mtime (nov value) `(aset ,nov 3 ,value))
 116 (defmacro nnmaildir--nov-set-extra (nov value) `(aset ,nov 4 ,value))
 117
 118 (defstruct nnmaildir--art
 119   (prefix nil :type string)  ;; "time.pid.host"
 120   (suffix nil :type string)  ;; ":2,flags"
 121   (num    nil :type natnum)  ;; article number
 122   (msgid  nil :type string)  ;; "<mess.age@id>"
 123   (nov    nil :type vector)) ;; cached nov structure, or nil
 124
 125 (defstruct nnmaildir--grp
 126   (name  nil :type string)  ;; "group.name"
 127   (new   nil :type list)    ;; new/ modtime
 128   (cur   nil :type list)    ;; cur/ modtime
 129   (min   1   :type natnum)  ;; minimum article number
 130   (count 0   :type natnum)  ;; count of articles
 131   (nlist nil :type list)    ;; list of articles, ordered descending by number
 132   (flist nil :type vector)  ;; obarray mapping filename prefix->article
 133   (mlist nil :type vector)  ;; obarray mapping message-id->article
 134   (cache nil :type vector)  ;; nov cache
 135   (index nil :type natnum)  ;; index of next cache entry to replace
 136   (mmth  nil :type vector)) ;; obarray mapping mark name->dir modtime
 137                                         ; ("Mark Mod Time Hash")
 138
 139 (defstruct nnmaildir--srv
 140   (address       nil :type string)         ;; server address string
 141   (method        nil :type list)           ;; (nnmaildir "address" ...)
 142   (prefix        nil :type string)         ;; "nnmaildir+address:"
 143   (dir           nil :type string)         ;; "/expanded/path/to/server/dir/"
 144   (ls            nil :type function)       ;; directory-files function
 145   (groups        nil :type vector)         ;; obarray mapping group name->group
 146   (curgrp        nil :type nnmaildir--grp) ;; current group, or nil
 147   (error         nil :type string)         ;; last error message, or nil
 148   (mtime         nil :type list)           ;; modtime of dir
 149   (gnm           nil)                      ;; flag: split from mail-sources?
 150   (target-prefix nil :type string))        ;; symlink target prefix
 151
 152 (defun nnmaildir--expired-article (group article)
 153   (setf (nnmaildir--art-nov article) nil)
 154   (let ((flist  (nnmaildir--grp-flist group))
 155         (mlist  (nnmaildir--grp-mlist group))
 156         (min    (nnmaildir--grp-min   group))
 157         (count  (1- (nnmaildir--grp-count group)))
 158         (prefix (nnmaildir--art-prefix article))
 159         (msgid  (nnmaildir--art-msgid  article))
 160         (new-nlist nil)
 161         (nlist-pre '(nil . nil))
 162         nlist-post num)
 163     (unless (zerop count)
 164       (setq nlist-post (nnmaildir--grp-nlist group)
 165             num (nnmaildir--art-num article))
 166       (if (eq num (caar nlist-post))
 167           (setq new-nlist (cdr nlist-post))
 168         (setq new-nlist nlist-post
 169               nlist-pre nlist-post
 170               nlist-post (cdr nlist-post))
 171         (while (/= num (caar nlist-post))
 172           (setq nlist-pre nlist-post
 173                 nlist-post (cdr nlist-post)))
 174         (setq nlist-post (cdr nlist-post))
 175         (if (eq num min)
 176             (setq min (caar nlist-pre)))))
 177     (let ((inhibit-quit t))
 178       (setf (nnmaildir--grp-min   group) min)
 179       (setf (nnmaildir--grp-count group) count)
 180       (setf (nnmaildir--grp-nlist group) new-nlist)
 181       (setcdr nlist-pre nlist-post)
 182       (unintern prefix flist)
 183       (unintern msgid mlist))))
 184
 185 (defun nnmaildir--nlist-art (group num)
 186   (let ((entry (assq num (nnmaildir--grp-nlist group))))
 187     (if entry
 188         (cdr entry))))
 189 (defmacro nnmaildir--flist-art (list file)
 190   `(symbol-value (intern-soft ,file ,list)))
 191 (defmacro nnmaildir--mlist-art (list msgid)
 192   `(symbol-value (intern-soft ,msgid ,list)))
 193
 194 (defun nnmaildir--pgname (server gname)
 195   (let ((prefix (nnmaildir--srv-prefix server)))
 196     (if prefix (concat prefix gname)
 197       (setq gname (gnus-group-prefixed-name gname
 198                                             (nnmaildir--srv-method server)))
 199       (setf (nnmaildir--srv-prefix server) (gnus-group-real-prefix gname))
 200       gname)))
 201
 202 (defun nnmaildir--param (pgname param)
 203   (setq param (gnus-group-find-parameter pgname param 'allow-list))
 204   (if (vectorp param) (setq param (aref param 0)))
 205   (eval param))
 206
 207 (defmacro nnmaildir--with-nntp-buffer (&rest body)
 208   `(save-excursion
 209      (set-buffer nntp-server-buffer)
 210      ,@body))
 211 (defmacro nnmaildir--with-work-buffer (&rest body)
 212   `(save-excursion
 213      (set-buffer (get-buffer-create " *nnmaildir work*"))
 214      ,@body))
 215 (defmacro nnmaildir--with-nov-buffer (&rest body)
 216   `(save-excursion
 217      (set-buffer (get-buffer-create " *nnmaildir nov*"))
 218      ,@body))
 219 (defmacro nnmaildir--with-move-buffer (&rest body)
 220   `(save-excursion
 221      (set-buffer (get-buffer-create " *nnmaildir move*"))
 222      ,@body))
 223
 224 (defmacro nnmaildir--subdir (dir subdir)
 225   `(file-name-as-directory (concat ,dir ,subdir)))
 226 (defmacro nnmaildir--srvgrp-dir (srv-dir gname)
 227   `(nnmaildir--subdir ,srv-dir ,gname))
 228 (defmacro nnmaildir--tmp       (dir) `(nnmaildir--subdir ,dir "tmp"))
 229 (defmacro nnmaildir--new       (dir) `(nnmaildir--subdir ,dir "new"))
 230 (defmacro nnmaildir--cur       (dir) `(nnmaildir--subdir ,dir "cur"))
 231 (defmacro nnmaildir--nndir     (dir) `(nnmaildir--subdir ,dir ".nnmaildir"))
 232 (defmacro nnmaildir--nov-dir   (dir) `(nnmaildir--subdir ,dir "nov"))
 233 (defmacro nnmaildir--marks-dir (dir) `(nnmaildir--subdir ,dir "marks"))
 234 (defmacro nnmaildir--num-dir   (dir) `(nnmaildir--subdir ,dir "num"))
 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--mkfile (file)
 243   (write-region "" nil file nil 'no-message))
 244 (defun nnmaildir--delete-dir-files (dir ls)
 245   (when (file-attributes dir)
 246     (mapcar 'delete-file (funcall ls dir 'full "\\`[^.]" 'nosort))
 247     (delete-directory dir)))
 248
 249 (defun nnmaildir--group-maxnum (server group)
 250   (catch 'return
 251     (if (zerop (nnmaildir--grp-count group)) (throw 'return 0))
 252     (let ((dir (nnmaildir--srvgrp-dir (nnmaildir--srv-dir server)
 253                                     (nnmaildir--grp-name group)))
 254           (number-opened 1)
 255           attr ino-opened nlink number-linked)
 256       (setq dir (nnmaildir--nndir dir)
 257             dir (nnmaildir--num-dir dir))
 258       (while t
 259         (setq attr (file-attributes
 260                     (concat dir (number-to-string number-opened))))
 261         (or attr (throw 'return (1- number-opened)))
 262         (setq ino-opened (nth 10 attr)
 263               nlink (nth 1 attr)
 264               number-linked (+ number-opened nlink))
 265         (if (or (< nlink 1) (< number-linked nlink))
 266             (signal 'error '("Arithmetic overflow")))
 267         (setq attr (file-attributes
 268                     (concat dir (number-to-string number-linked))))
 269         (or attr (throw 'return (1- number-linked)))
 270         (if (/= ino-opened (nth 10 attr))
 271             (setq number-opened number-linked))))))
 272
 273 ;; Make the given server, if non-nil, be the current server.  Then make the
 274 ;; given group, if non-nil, be the current group of the current server.  Then
 275 ;; return the group object for the current group.
 276 (defun nnmaildir--prepare (server group)
 277   (let (x groups)
 278     (catch 'return
 279       (if (null server)
 280           (unless (setq server nnmaildir--cur-server)
 281             (throw 'return nil))
 282         (unless (setq server (intern-soft server nnmaildir--servers))
 283           (throw 'return nil))
 284         (setq server (symbol-value server)
 285               nnmaildir--cur-server server))
 286       (unless (setq groups (nnmaildir--srv-groups server))
 287         (throw 'return nil))
 288       (unless (nnmaildir--srv-method server)
 289         (setq x (concat "nnmaildir:" (nnmaildir--srv-address server))
 290               x (gnus-server-to-method x))
 291         (unless x (throw 'return nil))
 292         (setf (nnmaildir--srv-method server) x))
 293       (if (null group)
 294           (unless (setq group (nnmaildir--srv-curgrp server))
 295             (throw 'return nil))
 296         (unless (setq group (intern-soft group groups))
 297           (throw 'return nil))
 298         (setq group (symbol-value group)))
 299       group)))
 300
 301 (defun nnmaildir--tab-to-space (string)
 302   (let ((pos 0))
 303     (while (string-match "\t" string pos)
 304       (aset string (match-beginning 0) ? )
 305       (setq pos (match-end 0))))
 306   string)
 307
 308 (defmacro nnmaildir--condcase (errsym body &rest handler)
 309   `(condition-case ,errsym
 310        (let ((system-messages-locale "C")) ,body)
 311      (error . ,handler)))
 312
 313 (defun nnmaildir--emlink-p (err)
 314   (and (eq (car err) 'file-error)
 315        (string= (downcase (caddr err)) "too many links")))
 316
 317 (defun nnmaildir--enoent-p (err)
 318   (and (eq (car err) 'file-error)
 319        (string= (downcase (caddr err)) "no such file or directory")))
 320
 321 (defun nnmaildir--eexist-p (err)
 322   (eq (car err) 'file-already-exists))
 323
 324 (defun nnmaildir--new-number (nndir)
 325   "Allocate a new article number by atomically creating a file under NNDIR."
 326   (let ((numdir (nnmaildir--num-dir nndir))
 327         (make-new-file t)
 328         (number-open 1)
 329         number-link previous-number-link path-open path-link ino-open)
 330     (nnmaildir--mkdir numdir)
 331     (catch 'return
 332       (while t
 333         (setq path-open (concat numdir (number-to-string number-open)))
 334         (if (not make-new-file)
 335             (setq previous-number-link number-link)
 336           (nnmaildir--mkfile path-open)
 337           ;; If Emacs had O_CREAT|O_EXCL, we could return number-open here.
 338           (setq make-new-file nil
 339                 previous-number-link 0))
 340         (let* ((attr (file-attributes path-open))
 341                (nlink (nth 1 attr)))
 342           (setq ino-open (nth 10 attr)
 343                 number-link (+ number-open nlink))
 344           (if (or (< nlink 1) (< number-link nlink))
 345               (signal 'error '("Arithmetic overflow"))))
 346         (if (= number-link previous-number-link)
 347             ;; We've already tried this number, in the previous loop iteration,
 348             ;; and failed.
 349             (signal 'error `("Corrupt internal nnmaildir data" ,path-open)))
 350         (setq path-link (concat numdir (number-to-string number-link)))
 351         (nnmaildir--condcase err