/[emacs]/emacs/lisp/mail/smtpmail.el
ViewVC logotype

Diff of /emacs/lisp/mail/smtpmail.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.32 by monnier, Thu Oct 18 20:48:04 2001 UTC revision 1.33 by rms, Sat Nov 17 22:43:36 2001 UTC
# Line 3  Line 3 
3  ;; Copyright (C) 1995, 1996, 2001 Free Software Foundation, Inc.  ;; Copyright (C) 1995, 1996, 2001 Free Software Foundation, Inc.
4    
5  ;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>  ;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
6  ;; Maintainer: Brian D. Carlstrom <bdc@ai.mit.edu>  ;; Maintainer: Simon Josefsson <simon@josefsson.org>
7    ;; w32 Maintainer: Brian D. Carlstrom <bdc@ai.mit.edu>
8  ;; ESMTP support: Simon Leinen <simon@switch.ch>  ;; ESMTP support: Simon Leinen <simon@switch.ch>
9  ;; Hacked by Mike Taylor, 11th October 1999 to add support for  ;; Hacked by Mike Taylor, 11th October 1999 to add support for
10  ;; automatically appending a domain to RCPT TO: addresses.  ;; automatically appending a domain to RCPT TO: addresses.
11    ;; AUTH=LOGIN support: Stephen Cranefield <scranefield@infoscience.otago.ac.nz>
12  ;; Keywords: mail  ;; Keywords: mail
13    
14  ;; This file is part of GNU Emacs.  ;; This file is part of GNU Emacs.
# Line 38  Line 40 
40  ;;(setq smtpmail-local-domain "YOUR DOMAIN NAME")  ;;(setq smtpmail-local-domain "YOUR DOMAIN NAME")
41  ;;(setq smtpmail-sendto-domain "YOUR DOMAIN NAME")  ;;(setq smtpmail-sendto-domain "YOUR DOMAIN NAME")
42  ;;(setq smtpmail-debug-info t) ; only to debug problems  ;;(setq smtpmail-debug-info t) ; only to debug problems
43    ;;(setq smtpmail-auth-credentials
44    ;;      '(("YOUR SMTP HOST" 25 "username" "password")))
45    ;;(setq smtpmail-starttls-credentials
46    ;;      '(("YOUR SMTP HOST" 25 "~/.my_smtp_tls.key" "~/.my_smtp_tls.cert")))
47    
48  ;; To queue mail, set smtpmail-queue-mail to t and use  ;; To queue mail, set smtpmail-queue-mail to t and use
49  ;; smtpmail-send-queued-mail to send.  ;; smtpmail-send-queued-mail to send.
50    
51    ;; Modified by Stephen Cranefield <scranefield@infoscience.otago.ac.nz>,
52    ;; 22/6/99, to support SMTP Authentication by the AUTH=LOGIN mechanism.
53    ;; See http://help.netscape.com/products/server/messaging/3x/info/smtpauth.html
54    ;; Rewritten by Simon Josefsson to use same credential variable as AUTH
55    ;; support below.
56    
57    ;; Modified by Simon Josefsson <jas@pdc.kth.se>, 22/2/99, to support SMTP
58    ;; Authentication by the AUTH mechanism.
59    ;; See http://www.ietf.org/rfc/rfc2554.txt
60    
61    ;; Modified by Simon Josefsson <simon@josefsson.org>, 2000-10-07, to support
62    ;; STARTTLS.  Requires external program
63    ;; ftp://ftp.opaopa.org/pub/elisp/starttls-*.tar.gz.
64    ;; See http://www.ietf.org/rfc/rfc2246.txt, http://www.ietf.org/rfc/rfc2487.txt
65    
66  ;;; Code:  ;;; Code:
67    
68  (require 'sendmail)  (require 'sendmail)
69  (require 'time-stamp)  (require 'time-stamp)
70    (autoload 'starttls-open-stream "starttls")
71    (autoload 'starttls-negotiate "starttls")
72    (autoload 'mail-strip-quoted-names "mail-utils")
73    (autoload 'rfc2104-hash "rfc2104")
74    
75  ;;;  ;;;
76  (defgroup smtpmail nil  (defgroup smtpmail nil
# Line 66  Line 90 
90    :group 'smtpmail)    :group 'smtpmail)
91    
92  (defcustom smtpmail-smtp-service 25  (defcustom smtpmail-smtp-service 25
93    "*SMTP service port number. smtp or 25 ."    "*SMTP service port number.
94    :type 'integer  The default value would be \"smtp\" or 25 ."
95      :type '(choice (integer :tag "Port") (string :tag "Service"))
96    :group 'smtpmail)    :group 'smtpmail)
97    
98  (defcustom smtpmail-local-domain nil  (defcustom smtpmail-local-domain nil
# Line 94  buffer includes an exchange like: Line 119  buffer includes an exchange like:
119    :group 'smtpmail)    :group 'smtpmail)
120    
121  (defcustom smtpmail-debug-info nil  (defcustom smtpmail-debug-info nil
122    "*smtpmail debug info printout. messages and process buffer."    "Whether to print info in buffer *trace of SMTP session to <somewhere>*.
123    See also `smtpmail-debug-verb' which determines if the SMTP protocol should
124    be verbose as well."
125      :type 'boolean
126      :group 'smtpmail)
127    
128    (defcustom smtpmail-debug-verb nil
129      "Whether this library sends the SMTP VERB command or not.
130    The commands enables verbose information from the SMTP server."
131    :type 'boolean    :type 'boolean
132    :group 'smtpmail)    :group 'smtpmail)
133    
# Line 115  and sent with `smtpmail-send-queued-mail Line 148  and sent with `smtpmail-send-queued-mail
148    :type 'directory    :type 'directory
149    :group 'smtpmail)    :group 'smtpmail)
150    
151    (defcustom smtpmail-auth-credentials '(("" 25 "" nil))
152      "Specify username and password for servers.
153    It is a list of four-element lists that contain, in order,
154    `servername' (a string), `port' (an integer), `user' (a string) and
155    `password' (a string, or nil to query the user when needed).
156    If you need to enter a `realm' too, add it to the user string, so that
157    it looks like `user@realm'."
158      :type '(repeat (list (string  :tag "Server")
159                           (integer :tag "Port")
160                           (string  :tag "Username")
161                           (choice (const :tag "Query when needed" nil)
162                                   (string  :tag "Password"))))
163      :version "21.1"
164      :group 'smtpmail)
165    
166    (defcustom smtpmail-starttls-credentials '(("" 25 "" ""))
167      "Specify STARTTLS keys and certificates for servers.
168    This is a list of four-element list with `servername' (a string),
169    `port' (an integer), `key' (a filename) and `certificate' (a filename)."
170      :type '(repeat (list (string  :tag "Server")
171                           (integer :tag "Port")
172                           (file    :tag "Key")
173                           (file    :tag "Certificate")))
174      :version "21.1"
175      :group 'smtpmail)
176    
177  (defcustom smtpmail-warn-about-unknown-extensions nil  (defcustom smtpmail-warn-about-unknown-extensions nil
178    "*If set, print warnings about unknown SMTP extensions.    "*If set, print warnings about unknown SMTP extensions.
179  This is mainly useful for development purposes, to learn about  This is mainly useful for development purposes, to learn about
# Line 136  This is relative to `smtpmail-queue-dir' Line 195  This is relative to `smtpmail-queue-dir'
195  (defvar smtpmail-queue-index (concat smtpmail-queue-dir  (defvar smtpmail-queue-index (concat smtpmail-queue-dir
196                                       smtpmail-queue-index-file))                                       smtpmail-queue-index-file))
197    
198    (defconst smtpmail-auth-supported '(cram-md5 login)
199      "List of supported SMTP AUTH mechanisms.")
200    
201  ;;;  ;;;
202  ;;;  ;;;
203  ;;;  ;;;
204    
205  ;;;###autoload  ;;;###autoload
206  (defun smtpmail-send-it ()  (defun smtpmail-send-it ()
   (require 'mail-utils)  
207    (let ((errbuf (if mail-interactive    (let ((errbuf (if mail-interactive
208                      (generate-new-buffer " smtpmail errors")                      (generate-new-buffer " smtpmail errors")
209                    0))                    0))
# Line 332  This is relative to `smtpmail-queue-dir' Line 393  This is relative to `smtpmail-queue-dir'
393        (concat (system-name) "." smtpmail-local-domain)        (concat (system-name) "." smtpmail-local-domain)
394      (system-name)))      (system-name)))
395    
396    (defsubst smtpmail-cred-server (cred)
397      (nth 0 cred))
398    
399    (defsubst smtpmail-cred-port (cred)
400      (nth 1 cred))
401    
402    (defsubst smtpmail-cred-key (cred)
403      (nth 2 cred))
404    
405    (defsubst smtpmail-cred-user (cred)
406      (nth 2 cred))
407    
408    (defsubst smtpmail-cred-cert (cred)
409      (nth 3 cred))
410    
411    (defsubst smtpmail-cred-passwd (cred)
412      (nth 3 cred))
413    
414    (defun smtpmail-find-credentials (cred server port)
415      (catch 'done
416        (let ((l cred) el)
417          (while (setq el (pop l))
418            (when (and (equal server (smtpmail-cred-server el))
419                       (equal port (smtpmail-cred-port el)))
420              (throw 'done el))))))
421    
422  (defun smtpmail-maybe-append-domain (recipient)  (defun smtpmail-maybe-append-domain (recipient)
423    (if (or (not smtpmail-sendto-domain)    (if (or (not smtpmail-sendto-domain)
424            (string-match "@" recipient))            (string-match "@" recipient))
425        recipient        recipient
426      (concat recipient "@" smtpmail-sendto-domain)))      (concat recipient "@" smtpmail-sendto-domain)))
427    
428    (defun smtpmail-intersection (list1 list2)
429      (let ((result nil))
430        (dolist (el2 list2)
431          (when (memq el2 list1)
432            (push el2 result)))
433        (nreverse result)))
434    
435    (defun smtpmail-open-stream (process-buffer host port)
436      (let ((cred (smtpmail-find-credentials
437                   smtpmail-starttls-credentials host port)))
438        (if (null (and cred (condition-case ()
439                                (call-process "starttls")
440                              (error nil))))
441            ;; The normal case.
442            (open-network-stream "SMTP" process-buffer host port)
443          (let* ((cred-key (smtpmail-cred-key cred))
444                 (cred-cert (smtpmail-cred-cert cred))
445                 (starttls-extra-args
446                  (when (and (stringp cred-key) (stringp cred-cert)
447                             (file-regular-p
448                              (setq cred-key (expand-file-name cred-key)))
449                             (file-regular-p
450                              (setq cred-cert (expand-file-name cred-cert))))
451                    (list "--key-file" cred-key "--cert-file" cred-cert))))
452            (starttls-open-stream "SMTP" process-buffer host port)))))
453    
454    (defun smtpmail-try-auth-methods (process supported-extensions host port)
455      (let* ((mechs (cdr-safe (assoc 'auth supported-extensions)))
456             (mech (car (smtpmail-intersection smtpmail-auth-supported mechs)))
457             (cred (smtpmail-find-credentials smtpmail-auth-credentials host port))
458             (passwd (when cred
459                       (or (smtpmail-cred-passwd cred)
460                           (read-passwd
461                            (format "SMTP password for %s:%s: "
462                                    (smtpmail-cred-server cred)
463                                    (smtpmail-cred-port cred))))))
464             ret)
465        (when cred
466          (cond
467           ((eq mech 'cram-md5)
468            (smtpmail-send-command process (format "AUTH %s" mech))
469            (if (or (null (car (setq ret (smtpmail-read-response process))))
470                    (not (integerp (car ret)))
471                    (>= (car ret) 400))
472                (throw 'done nil))
473            (when (eq (car ret) 334)
474              (let* ((challenge (substring (cadr ret) 4))
475                     (decoded (base64-decode-string challenge))
476                     (hash (rfc2104-hash 'md5 64 16 passwd decoded))
477                     (response (concat (smtpmail-cred-user cred) " " hash))
478                     (encoded (base64-encode-string response)))
479                (smtpmail-send-command process (format "%s" encoded))
480                (if (or (null (car (setq ret (smtpmail-read-response process))))
481                        (not (integerp (car ret)))
482                        (>= (car ret) 400))
483                    (throw 'done nil)))))
484           ((eq mech 'login)
485            (smtpmail-send-command process "AUTH LOGIN")
486            (if (or (null (car (setq ret (smtpmail-read-response process))))
487                    (not (integerp (car ret)))
488                    (>= (car ret) 400))
489                (throw 'done nil))
490            (smtpmail-send-command
491             process (base64-encode-string (smtpmail-cred-user cred)))
492            (if (or (null (car (setq ret (smtpmail-read-response process))))
493                    (not (integerp (car ret)))
494                    (>= (car ret) 400))
495                (throw 'done nil))
496            (smtpmail-send-command process (base64-encode-string passwd))
497            (if (or (null (car (setq ret (smtpmail-read-response process))))
498                    (not (integerp (car ret)))
499                    (>= (car ret) 400))
500                (throw 'done nil)))
501           (t
502            (error "Mechanism %s not implemented" mech)))
503          ;; Remember the password.
504          (unless (smtpmail-cred-passwd cred)
505            (setcar (cdr (cdr (cdr cred))) passwd)))))
506    
507  (defun smtpmail-via-smtp (recipient smtpmail-text-buffer)  (defun smtpmail-via-smtp (recipient smtpmail-text-buffer)
508    (let ((process nil)    (let ((process nil)
509          (host (or smtpmail-smtp-server          (host (or smtpmail-smtp-server
# Line 359  This is relative to `smtpmail-queue-dir' Line 525  This is relative to `smtpmail-queue-dir'
525              (erase-buffer))              (erase-buffer))
526    
527            ;; open the connection to the server            ;; open the connection to the server
528            (setq process (open-network-stream "SMTP" process-buffer host port))            (setq process (smtpmail-open-stream process-buffer host port))
529            (and (null process) (throw 'done nil))            (and (null process) (throw 'done nil))
530    
531            ;; set the send-filter            ;; set the send-filter
# Line 378  This is relative to `smtpmail-queue-dir' Line 544  This is relative to `smtpmail-queue-dir'
544                  (throw 'done nil)                  (throw 'done nil)
545                )                )
546    
547                (let ((do-ehlo t)
548                      (do-starttls t))
549                  (while do-ehlo
550              ;; EHLO              ;; EHLO
551              (smtpmail-send-command process (format "EHLO %s" (smtpmail-fqdn)))              (smtpmail-send-command process (format "EHLO %s" (smtpmail-fqdn)))
552    
553              (if (or (null (car (setq response-code (smtpmail-read-response process))))              (if (or (null (car (setq response-code
554                                         (smtpmail-read-response process))))
555                      (not (integerp (car response-code)))                      (not (integerp (car response-code)))
556                      (>= (car response-code) 400))                      (>= (car response-code) 400))
557                  (progn                  (progn
558                    ;; HELO                    ;; HELO
559                    (smtpmail-send-command process (format "HELO %s" (smtpmail-fqdn)))                    (smtpmail-send-command
560                       process (format "HELO %s" (smtpmail-fqdn)))
561    
562                    (if (or (null (car (setq response-code (smtpmail-read-response process))))                    (if (or (null (car (setq response-code
563                                               (smtpmail-read-response process))))
564                            (not (integerp (car response-code)))                            (not (integerp (car response-code)))
565                            (>= (car response-code) 400))                            (>= (car response-code) 400))
566                        (throw 'done nil)))                        (throw 'done nil)))
567                (let ((extension-lines (cdr (cdr response-code))))                (dolist (line (cdr (cdr response-code)))
568                  (while extension-lines                  (let ((name (mapcar (lambda (s) (intern (downcase s)))
569                    (let ((name (intern (downcase (car (split-string (substring (car extension-lines) 4) "[ ]"))))))                                      (split-string (substring line 4) "[ ]"))))
570                      (and (eq (length name) 1)
571                           (setq name (car name)))
572                      (and name                      (and name
573                           (cond ((memq name '(verb xvrb 8bitmime onex xone                         (cond ((memq (if (consp name) (car name) name)
574                                        '(verb xvrb 8bitmime onex xone
575                                                    expn size dsn etrn                                                    expn size dsn etrn
576                                                    help xusr))                                        enhancedstatuscodes
577                                          help xusr
578                                          auth=login auth starttls))
579                                  (setq supported-extensions                                  (setq supported-extensions
580                                        (cons name supported-extensions)))                                        (cons name supported-extensions)))
581                                 (smtpmail-warn-about-unknown-extensions                                 (smtpmail-warn-about-unknown-extensions
582                                  (message "Unknown extension %s" name)))))                                (message "Unknown extension %s" name)))))))
583                    (setq extension-lines (cdr extension-lines)))))  
584                (if (and do-starttls
585                         (smtpmail-find-credentials smtpmail-starttls-credentials host port)
586                         (member 'starttls supported-extensions)
587                         (process-id process))
588                    (progn
589                      (smtpmail-send-command process (format "STARTTLS"))
590                      (if (or (null (car (setq response-code (smtpmail-read-response process))))
591                              (not (integerp (car response-code)))
592                              (>= (car response-code) 400))
593                          (throw 'done nil))
594                      (starttls-negotiate process)
595                      (setq do-starttls nil))
596                  (setq do-ehlo nil))))
597                
598                (smtpmail-try-auth-methods process supported-extensions host port)
599    
600              (if (or (member 'onex supported-extensions)              (if (or (member 'onex supported-extensions)
601                      (member 'xone supported-extensions))                      (member 'xone supported-extensions))
# Line 414  This is relative to `smtpmail-queue-dir' Line 606  This is relative to `smtpmail-queue-dir'
606                            (>= (car response-code) 400))                            (>= (car response-code) 400))
607                        (throw 'done nil))))                        (throw 'done nil))))
608    
609              (if (and smtpmail-debug-info              (if (and smtpmail-debug-verb
610                       (or (member 'verb supported-extensions)                       (or (member 'verb supported-extensions)
611                           (member 'xvrb supported-extensions)))                           (member 'xvrb supported-extensions)))
612                  (progn                  (progn
# Line 434  This is relative to `smtpmail-queue-dir' Line 626  This is relative to `smtpmail-queue-dir'
626    
627              ;; MAIL FROM: <sender>              ;; MAIL FROM: <sender>
628              (let ((size-part              (let ((size-part
629                     (if (member 'size supported-extensions)                     (if (or (member 'size supported-extensions)
630                               (assoc 'size supported-extensions))
631                         (format " SIZE=%d"                         (format " SIZE=%d"
632                                 (save-excursion                                 (save-excursion
633                                   (set-buffer smtpmail-text-buffer)                                   (set-buffer smtpmail-text-buffer)
# Line 650  This is relative to `smtpmail-queue-dir' Line 843  This is relative to `smtpmail-queue-dir'
843    
844  (defun smtpmail-deduce-address-list (smtpmail-text-buffer header-start header-end)  (defun smtpmail-deduce-address-list (smtpmail-text-buffer header-start header-end)
845    "Get address list suitable for smtp RCPT TO: <address>."    "Get address list suitable for smtp RCPT TO: <address>."
   (require 'mail-utils)  ;; pick up mail-strip-quoted-names  
       
846    (unwind-protect    (unwind-protect
847        (save-excursion        (save-excursion
848          (set-buffer smtpmail-address-buffer) (erase-buffer)          (set-buffer smtpmail-address-buffer) (erase-buffer)

Legend:
Removed from v.1.32  
changed lines
  Added in v.1.33

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26