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