cgit.sxemacs.org Git - gnus/blob - lisp/mail-source.el

   1 ;;; mail-source.el --- functions for fetching mail
   2 ;; Copyright (C) 1999 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   5 ;; Keywords: news, mail
   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 2, or (at your option)
  12 ;; 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; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (eval-when-compile (require 'cl))
  29 (eval-and-compile
  30   (autoload 'pop3-movemail "pop3"))
  31 (require 'format-spec)
  32
  33 (defgroup mail-source nil
  34   "The mail-fetching library."
  35   :group 'gnus)
  36
  37 (defcustom mail-sources nil
  38   "*Where the mail backends will look for incoming mail.
  39 This variable is a list of mail source specifiers."
  40   :group 'mail-source
  41   :type 'sexp)
  42
  43 (defcustom mail-source-crash-box "~/.emacs-mail-crash-box"
  44   "File where mail will be stored while processing it."
  45   :group 'mail-source
  46   :type 'file)
  47
  48 (defcustom mail-source-directory "~/Mail/"
  49   "Directory where files (if any) will be stored."
  50   :group 'mail-source
  51   :type 'directory)
  52
  53 (defcustom mail-source-default-file-modes 384
  54   "Set the mode bits of all new mail files to this integer."
  55   :group 'mail-source
  56   :type 'integer)
  57
  58 (defcustom mail-source-delete-incoming t
  59   "*If non-nil, delete incoming files after handling."
  60   :group 'mail-source
  61   :type 'boolean)
  62
  63 ;;; Internal variables.
  64
  65 (defvar mail-source-string ""
  66   "A dynamically bound string that says what the current mail source is.")
  67
  68 (eval-and-compile
  69   (defvar mail-source-common-keyword-map
  70     '((:plugged))
  71     "Mapping from keywords to default values.
  72 Common keywords should be listed here.")
  73
  74   (defvar mail-source-keyword-map
  75     '((file
  76        (:prescript)
  77        (:prescript-delay)
  78        (:postscript)
  79        (:path (or (getenv "MAIL")
  80                   (concat "/usr/spool/mail/" (user-login-name)))))
  81       (directory
  82        (:path)
  83        (:suffix ".spool")
  84        (:predicate identity))
  85       (pop
  86        (:prescript)
  87        (:prescript-delay)
  88        (:postscript)
  89        (:server (getenv "MAILHOST"))
  90        (:port 110)
  91        (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
  92        (:program)
  93        (:function)
  94        (:password)
  95        (:authentication password))
  96       (maildir
  97        (:path "~/Maildir/new/")
  98        (:function))
  99       (imap
 100        (:server (getenv "MAILHOST"))
 101        (:port)
 102        (:stream)
 103        (:authentication)
 104        (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
 105        (:password)
 106        (:mailbox "INBOX")
 107        (:predicate "UNSEEN UNDELETED")
 108        (:fetchflag "\\Deleted")
 109        (:dontexpunge))
 110       (webmail
 111        (:subtype hotmail)
 112        (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
 113        (:password)
 114        (:authentication password)))
 115     "Mapping from keywords to default values.
 116 All keywords that can be used must be listed here."))
 117
 118 (defvar mail-source-fetcher-alist
 119   '((file mail-source-fetch-file)
 120     (directory mail-source-fetch-directory)
 121     (pop mail-source-fetch-pop)
 122     (maildir mail-source-fetch-maildir)
 123     (imap mail-source-fetch-imap)
 124     (webmail mail-source-fetch-webmail))
 125   "A mapping from source type to fetcher function.")
 126
 127 (defvar mail-source-password-cache nil)
 128
 129 (defvar mail-source-plugged t)
 130
 131 ;;; Functions
 132
 133 (eval-and-compile
 134   (defun mail-source-strip-keyword (keyword)
 135   "Strip the leading colon off the KEYWORD."
 136   (intern (substring (symbol-name keyword) 1))))
 137
 138 (eval-and-compile
 139   (defun mail-source-bind-1 (type)
 140     (let* ((defaults (cdr (assq type mail-source-keyword-map)))
 141            default bind)
 142       (while (setq default (pop defaults))
 143         (push (list (mail-source-strip-keyword (car default))
 144                     nil)
 145               bind))
 146       bind)))
 147
 148 (defmacro mail-source-bind (type-source &rest body)
 149   "Return a `let' form that binds all variables in source TYPE.
 150 TYPE-SOURCE is a list where the first element is the TYPE, and
 151 the second variable is the SOURCE.
 152 At run time, the mail source specifier SOURCE will be inspected,
 153 and the variables will be set according to it.  Variables not
 154 specified will be given default values.
 155
 156 After this is done, BODY will be executed in the scope
 157 of the `let' form.
 158
 159 The variables bound and their default values are described by
 160 the `mail-source-keyword-map' variable."
 161   `(let ,(mail-source-bind-1 (car type-source))
 162      (mail-source-set-1 ,(cadr type-source))
 163      ,@body))
 164
 165 (put 'mail-source-bind 'lisp-indent-function 1)
 166 (put 'mail-source-bind 'edebug-form-spec '(form body))
 167
 168 (defun mail-source-set-1 (source)
 169   (let* ((type (pop source))
 170          (defaults (cdr (assq type mail-source-keyword-map)))
 171          default value keyword)
 172     (while (setq default (pop defaults))
 173       (set (mail-source-strip-keyword (setq keyword (car default)))
 174            (if (setq value (plist-get source keyword))
 175                (mail-source-value value)
 176              (mail-source-value (cadr default)))))))
 177
 178 (eval-and-compile
 179   (defun mail-source-bind-common-1 ()
 180     (let* ((defaults mail-source-common-keyword-map)
 181            default bind)
 182       (while (setq default (pop defaults))
 183         (push (list (mail-source-strip-keyword (car default))
 184                     nil)
 185               bind))
 186       bind)))
 187
 188 (defun mail-source-set-common-1 (source)
 189   (let* ((type (pop source))
 190          (defaults mail-source-common-keyword-map)
 191          (defaults-1 (cdr (assq type mail-source-keyword-map)))
 192          default value keyword)
 193     (while (setq default (pop defaults))
 194       (set (mail-source-strip-keyword (setq keyword (car default)))
 195            (if (setq value (plist-get source keyword))
 196                (mail-source-value value)
 197              (if (setq value (assq  keyword defaults-1))
 198                  (mail-source-value (cadr value))
 199                (mail-source-value (cadr default))))))))
 200
 201 (defmacro mail-source-bind-common (source &rest body)
 202   "Return a `let' form that binds all common variables.
 203 See `mail-source-bind'."
 204   `(let ,(mail-source-bind-common-1)
 205      (mail-source-set-common-1 source)
 206      ,@body))
 207
 208 (put 'mail-source-bind-common 'lisp-indent-function 1)
 209 (put 'mail-source-bind-common 'edebug-form-spec '(form body))
 210
 211 (defun mail-source-value (value)
 212   "Return the value of VALUE."
 213   (cond
 214    ;; String
 215    ((stringp value)
 216     value)
 217    ;; Function
 218    ((and (listp value)
 219          (functionp (car value)))
 220     (eval value))
 221    ;; Just return the value.
 222    (t
 223     value)))
 224
 225 (defun mail-source-fetch (source callback)
 226   "Fetch mail from SOURCE and call CALLBACK zero or more times.
 227 CALLBACK will be called with the name of the file where (some of)
 228 the mail from SOURCE is put.
 229 Return the number of files that were found."
 230   (mail-source-bind-common source
 231     (if (or mail-source-plugged plugged)
 232         (save-excursion
 233           (let ((function (cadr (assq (car source) mail-source-fetcher-alist)))
 234                 (found 0))
 235             (unless function
 236               (error "%S is an invalid mail source specification" source))
 237             ;; If there's anything in the crash box, we do it first.
 238             (when (file-exists-p mail-source-crash-box)
 239               (message "Processing mail from %s..." mail-source-crash-box)
 240               (setq found (mail-source-callback
 241                            callback mail-source-crash-box)))
 242             (+ found
 243                (condition-case err
 244                    (funcall function source callback)
 245                  (error
 246                   (unless (yes-or-no-p
 247                            (format "Mail source error (%s).  Continue? " err))
 248                     (error "Cannot get new mail."))
 249                   0))))))))
 250
 251 (defun mail-source-make-complex-temp-name (prefix)
 252   (let ((newname (make-temp-name prefix))
 253         (newprefix prefix))
 254     (while (file-exists-p newname)
 255       (setq newprefix (concat newprefix "x"))
 256       (setq newname (make-temp-name newprefix)))
 257     newname))
 258
 259 (defun mail-source-callback (callback info)
 260   "Call CALLBACK on the mail file, and then remove the mail file.
 261 Pass INFO on to CALLBACK."
 262   (if (or (not (file-exists-p mail-source-crash-box))
 263           (zerop (nth 7 (file-attributes mail-source-crash-box))))
 264       (progn
 265         (when (file-exists-p mail-source-crash-box)
 266           (delete-file mail-source-crash-box))
 267         0)
 268     (prog1
 269         (funcall callback mail-source-crash-box info)
 270       (when (file-exists-p mail-source-crash-box)
 271         ;; Delete or move the incoming mail out of the way.
 272         (if mail-source-delete-incoming
 273             (delete-file mail-source-crash-box)
 274           (let ((incoming
 275                  (mail-source-make-complex-temp-name
 276                   (expand-file-name
 277                    "Incoming" mail-source-directory))))
 278             (unless (file-exists-p (file-name-directory incoming))
 279               (make-directory (file-name-directory incoming) t))
 280             (rename-file mail-source-crash-box incoming t)))))))
 281
 282 (defun mail-source-movemail (from to)
 283   "Move FROM to TO using movemail."
 284   (if (not (file-writable-p to))
 285       (error "Can't write to crash box %s.  Not moving mail" to)
 286     (let ((to (file-truename (expand-file-name to)))
 287           errors result)
 288       (setq to (file-truename to)
 289             from (file-truename from))
 290       ;; Set TO if have not already done so, and rename or copy
 291       ;; the file FROM to TO if and as appropriate.
 292       (cond
 293        ((file-exists-p to)
 294         ;; The crash box exists already.
 295         t)
 296        ((not (file-exists-p from))
 297         ;; There is no inbox.
 298         (setq to nil))
 299        ((zerop (nth 7 (file-attributes from)))
 300         ;; Empty file.
 301         (setq to nil))
 302        (t
 303         ;; If getting from mail spool directory, use movemail to move
 304         ;; rather than just renaming, so as to interlock with the
 305         ;; mailer.
 306         (unwind-protect
 307             (save-excursion
 308               (setq errors (generate-new-buffer " *mail source loss*"))
 309               (let ((default-directory "/"))
 310                 (setq result
 311                       (apply
 312                        'call-process
 313                        (append
 314                         (list
 315                          (expand-file-name "movemail" exec-directory)
 316                          nil errors nil from to)))))
 317               (when (file-exists-p to)
 318                 (set-file-modes to mail-source-default-file-modes))
 319               (if (and (not (buffer-modified-p errors))
 320                        (zerop result))
 321                   ;; No output => movemail won.
 322                   t
 323                 (set-buffer errors)
 324                 ;; There may be a warning about older revisions.  We
 325                 ;; ignore that.
 326                 (goto-char (point-min))
 327                 (if (search-forward "older revision" nil t)
 328                     t
 329                   ;; Probably a real error.
 330                   (subst-char-in-region (point-min) (point-max) ?\n ?\  )
 331                   (goto-char (point-max))
 332                   (skip-chars-backward " \t")
 333                   (delete-region (point) (point-max))
 334                   (goto-char (point-min))
 335                   (when (looking-at "movemail: ")
 336                     (delete-region (point-min) (match-end 0)))
 337                   (unless (yes-or-no-p
 338                            (format "movemail: %s (%d return).  Continue? "
 339                                    (buffer-string) result))
 340                     (error "%s" (buffer-string)))
 341                   (setq to nil)))))))
 342       (when (and errors
 343                  (buffer-name errors))
 344         (kill-buffer errors))
 345       ;; Return whether we moved successfully or not.
 346       to)))
 347
 348 (defun mail-source-movemail-and-remove (from to)
 349   "Move FROM to TO using movemail, then remove FROM if empty."
 350   (or (not (mail-source-movemail from to))
 351       (not (zerop (nth 7 (file-attributes from))))
 352       (delete-file from)))
 353
 354 (defvar mail-source-read-passwd nil)
 355 (defun mail-source-read-passwd (prompt &rest args)
 356   "Read a password using PROMPT.
 357 If ARGS, PROMPT is used as an argument to `format'."
 358   (let ((prompt
 359          (if args
 360              (apply 'format prompt args)
 361            prompt)))
 362     (unless mail-source-read-passwd
 363       (if (or (fboundp 'read-passwd) (load "passwd" t))
 364           (setq mail-source-read-passwd 'read-passwd)
 365         (unless (fboundp 'ange-ftp-read-passwd)
 366           (autoload 'ange-ftp-read-passwd "ange-ftp"))
 367         (setq mail-source-read-passwd 'ange-ftp-read-passwd)))
 368     (funcall mail-source-read-passwd prompt)))
 369
 370 (defun mail-source-fetch-with-program (program)
 371   (zerop (call-process shell-file-name nil nil nil
 372                        shell-command-switch program)))
 373
 374 (defun mail-source-run-script (script spec &optional delay)
 375   (when script
 376     (if (and (symbolp script) (fboundp script))
 377         (funcall script)
 378       (mail-source-call-script
 379        (format-spec script spec))))
 380   (when delay
 381     (sleep-for delay)))
 382
 383 (defun mail-source-call-script (script)
 384   (let ((background nil))
 385     (when (string-match "& *$" script)
 386       (setq script (substring script 0 (match-beginning 0))
 387             background 0))
 388     (call-process shell-file-name nil background nil
 389                   shell-command-switch script)))
 390
 391 ;;;
 392 ;;; Different fetchers
 393 ;;;
 394
 395 (defun mail-source-fetch-file (source callback)
 396   "Fetcher for single-file sources."
 397   (mail-source-bind (file source)
 398     (mail-source-run-script
 399      prescript (format-spec-make ?t mail-source-crash-box)
 400      prescript-delay)
 401     (let ((mail-source-string (format "file:%s" path)))
 402       (if (mail-source-movemail path mail-source-crash-box)
 403           (prog1
 404               (mail-source-callback callback path)
 405             (mail-source-run-script
 406              postscript (format-spec-make ?t mail-source-crash-box)))
 407         0))))
 408
 409 (defun mail-source-fetch-directory (source callback)
 410   "Fetcher for directory sources."
 411   (mail-source-bind (directory source)
 412     (let ((found 0)
 413           (mail-source-string (format "directory:%s" path)))
 414       (dolist (file (directory-files
 415                      path t (concat (regexp-quote suffix) "$")))
 416         (when (and (file-regular-p file)
 417                    (funcall predicate file)
 418                    (mail-source-movemail file mail-source-crash-box))
 419           (incf found (mail-source-callback callback file))))
 420       found)))
 421
 422 (defun mail-source-fetch-pop (source callback)
 423   "Fetcher for single-file sources."
 424   (mail-source-bind (pop source)
 425     (mail-source-run-script
 426      prescript
 427      (format-spec-make ?p password ?t mail-source-crash-box
 428                                       ?s server ?P port ?u user)
 429      prescript-delay)
 430     (let ((from (format "%s:%s:%s" server user port))
 431           (mail-source-string (format "pop:%s@%s" user server))
 432           result)
 433       (when (eq authentication 'password)
 434         (setq password
 435               (or password
 436                   (cdr (assoc from mail-source-password-cache))
 437                   (mail-source-read-passwd
 438                    (format "Password for %s at %s: " user server)))))
 439       (when server
 440         (setenv "MAILHOST" server))
 441       (setq result
 442             (cond
 443              (program
 444               (mail-source-fetch-with-program
 445                (format-spec
 446                 program
 447                 (format-spec-make ?p password ?t mail-source-crash-box
 448                                   ?s server ?P port ?u user))))
 449              (function
 450               (funcall function mail-source-crash-box))
 451              ;; The default is to use pop3.el.
 452              (t
 453               (let ((pop3-password password)
 454                     (pop3-maildrop user)
 455                     (pop3-mailhost server)
 456                     (pop3-port port)
 457                     (pop3-authentication-scheme
 458                      (if (eq authentication 'apop) 'apop 'pass)))
 459                 (save-excursion (pop3-movemail mail-source-crash-box))))))
 460       (if result
 461           (progn
 462             (when (eq authentication 'password)
 463               (unless (assoc from mail-source-password-cache)
 464                 (push (cons from password) mail-source-password-cache)))
 465             (prog1
 466                 (mail-source-callback callback server)
 467               (mail-source-run-script
 468                postscript
 469                (format-spec-make ?p password ?t mail-source-crash-box
 470                                  ?s server ?P port ?u user))))
 471         ;; We nix out the password in case the error
 472         ;; was because of a wrong password being given.
 473         (setq mail-source-password-cache
 474               (delq (assoc from mail-source-password-cache)
 475                     mail-source-password-cache))
 476         0))))
 477
 478 (defun mail-source-fetch-maildir (source callback)
 479   "Fetcher for maildir sources."
 480   (mail-source-bind (maildir source)
 481     (let ((found 0)
 482           (mail-source-string (format "maildir:%s" path)))
 483       (dolist (file (directory-files path t))
 484         (when (and (not (file-directory-p file))
 485                    (not (if function
 486                             (funcall function file mail-source-crash-box)
 487                           (rename-file file mail-source-crash-box))))
 488           (incf found (mail-source-callback callback file))))
 489       found)))
 490
 491 (eval-and-compile
 492   (autoload 'imap-open "imap")
 493   (autoload 'imap-authenticate "imap")
 494   (autoload 'imap-mailbox-select "imap")
 495   (autoload 'imap-mailbox-unselect "imap")
 496   (autoload 'imap-mailbox-close "imap")
 497   (autoload 'imap-search "imap")
 498   (autoload 'imap-fetch "imap")
 499   (autoload 'imap-close "imap")
 500   (autoload 'imap-error-text "imap")
 501   (autoload 'imap-message-flags-add "imap")
 502   (autoload 'imap-list-to-message-set "imap")
 503   (autoload 'nnheader-ms-strip-cr "nnheader"))
 504
 505 (defun mail-source-fetch-imap (source callback)
 506   "Fetcher for imap sources."
 507   (mail-source-bind (imap source)
 508     (let ((found 0)
 509           (buf (get-buffer-create (generate-new-buffer-name " *imap source*")))
 510           (mail-source-string (format "imap:%s:%s" server mailbox))
 511           remove)
 512       (if (and (imap-open server port stream authentication buf)
 513                (imap-authenticate user password buf)
 514                (imap-mailbox-select mailbox nil buf))
 515           (let (str (coding-system-for-write 'binary))
 516             (with-temp-file mail-source-crash-box
 517               ;; if predicate is nil, use all uids
 518               (dolist (uid (imap-search (or predicate "1:*") buf))
 519                 (when (setq str (imap-fetch uid "RFC822.PEEK" 'RFC822 nil buf))
 520                   (push uid remove)
 521                   (insert "From imap " (current-time-string) "\n")
 522                   (save-excursion
 523                     (insert str "\n\n"))
 524                   (while (re-search-forward "^From " nil t)
 525                     (replace-match ">From "))
 526                   (goto-char (point-max))))
 527               (nnheader-ms-strip-cr))
 528             (incf found (mail-source-callback callback server))
 529             (when (and remove fetchflag)
 530               (imap-message-flags-add
 531                (imap-list-to-message-set remove) fetchflag nil buf))
 532             (if dontexpunge
 533                 (imap-mailbox-unselect buf)
 534               (imap-mailbox-close buf))
 535             (imap-close buf))
 536         (imap-close buf)
 537         (error (imap-error-text buf)))
 538       (kill-buffer buf)
 539       found)))
 540
 541 (eval-and-compile
 542   (autoload 'webmail-fetch "webmail"))
 543
 544 (defun mail-source-fetch-webmail (source callback)
 545   "Fetch for webmail source."
 546   (mail-source-bind (webmail source)
 547     (when (eq authentication 'password)
 548       (setq password
 549             (or password
 550                 (mail-source-read-passwd
 551                  (format "Password for %s at %s: " user subtype)))))
 552     (webmail-fetch mail-source-crash-box subtype user password)
 553     (mail-source-callback callback (symbol-name subtype))))
 554
 555 (provide 'mail-source)
 556
 557 ;;; mail-source.el ends here