Mercurial > emacs

changeset 41221:b6fd3363a398

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
(smtpmail-cred-server, smtpmail-cred-port, smtpmail-cred-key) (smtpmail-cred-user, smtpmail-cred-cert, smtpmail-cred-passwd): Defsubst instead of defmacro. (smtpmail-intersection): Return value in reverse order. (smtpmail-open-stream): Use stringp instead of string-to-list. (smtpmail-open-stream, smtpmail-try-auth-methods): New functions, separated from smtpmail-via-smtp. (top level): Autoload starttls, mail-utils and rfc2104. (smtpmail-smtp-service): Doc fix. :type fix. (smtpmail-debug-info): Doc fix. (smtpmail-debug-verb, smtpmail-auth-credentials) (smtpmail-starttls-credentials, smtpmail-auth-supported): New variables. (smtpmail-deduce-address-list, smtpmail-send-it): Don't require mail-utils (it is autoloaded). (smtpmail-cred-server, smtpmail-cred-port, smtpmail-cred-key) (smtpmail-cred-user, smtpmail-cred-cert, smtpmail-cred-passwd) (smtpmail-find-credentials, smtpmail-intersection): New utility funs. (smtpmail-via-smtp): Support STARTTLS, if binary is installed. (smtpmail-via-smtp): Support AUTH. (smtpmail-via-smtp): Use `smtpmail-debug-verb' to control VERB.
author Richard M. Stallman <rms@gnu.org>
date Sat, 17 Nov 2001 22:43:36 +0000
parents 0a6ed29cea73
children 3d601db16361
files lisp/mail/smtpmail.el
diffstat 1 files changed, 211 insertions(+), 20 deletions(-) [+]
line wrap: on
line diff
--- a/lisp/mail/smtpmail.el	Sat Nov 17 22:41:26 2001 +0000
+++ b/lisp/mail/smtpmail.el	Sat Nov 17 22:43:36 2001 +0000
@@ -3,10 +3,12 @@
 ;; Copyright (C) 1995, 1996, 2001 Free Software Foundation, Inc.
 
 ;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
-;; Maintainer: Brian D. Carlstrom <bdc@ai.mit.edu>
+;; Maintainer: Simon Josefsson <simon@josefsson.org>
+;; w32 Maintainer: Brian D. Carlstrom <bdc@ai.mit.edu>
 ;; ESMTP support: Simon Leinen <simon@switch.ch>
 ;; Hacked by Mike Taylor, 11th October 1999 to add support for
 ;; automatically appending a domain to RCPT TO: addresses.
+;; AUTH=LOGIN support: Stephen Cranefield <scranefield@infoscience.otago.ac.nz>
 ;; Keywords: mail
 
 ;; This file is part of GNU Emacs.
@@ -38,15 +40,37 @@
 ;;(setq smtpmail-local-domain "YOUR DOMAIN NAME")
 ;;(setq smtpmail-sendto-domain "YOUR DOMAIN NAME")
 ;;(setq smtpmail-debug-info t) ; only to debug problems
+;;(setq smtpmail-auth-credentials
+;;      '(("YOUR SMTP HOST" 25 "username" "password")))
+;;(setq smtpmail-starttls-credentials
+;;      '(("YOUR SMTP HOST" 25 "~/.my_smtp_tls.key" "~/.my_smtp_tls.cert")))
 
 ;; To queue mail, set smtpmail-queue-mail to t and use 
 ;; smtpmail-send-queued-mail to send.
 
+;; Modified by Stephen Cranefield <scranefield@infoscience.otago.ac.nz>,
+;; 22/6/99, to support SMTP Authentication by the AUTH=LOGIN mechanism.
+;; See http://help.netscape.com/products/server/messaging/3x/info/smtpauth.html
+;; Rewritten by Simon Josefsson to use same credential variable as AUTH
+;; support below.
+
+;; Modified by Simon Josefsson <jas@pdc.kth.se>, 22/2/99, to support SMTP
+;; Authentication by the AUTH mechanism.
+;; See http://www.ietf.org/rfc/rfc2554.txt
+
+;; Modified by Simon Josefsson <simon@josefsson.org>, 2000-10-07, to support
+;; STARTTLS.  Requires external program
+;; ftp://ftp.opaopa.org/pub/elisp/starttls-*.tar.gz.
+;; See http://www.ietf.org/rfc/rfc2246.txt, http://www.ietf.org/rfc/rfc2487.txt
 
 ;;; Code:
 
 (require 'sendmail)
 (require 'time-stamp)
+(autoload 'starttls-open-stream "starttls")
+(autoload 'starttls-negotiate "starttls")
+(autoload 'mail-strip-quoted-names "mail-utils")
+(autoload 'rfc2104-hash "rfc2104")
 
 ;;;
 (defgroup smtpmail nil
@@ -66,8 +90,9 @@
   :group 'smtpmail)
 
 (defcustom smtpmail-smtp-service 25
-  "*SMTP service port number. smtp or 25 ."
-  :type 'integer
+  "*SMTP service port number.
+The default value would be \"smtp\" or 25 ."
+  :type '(choice (integer :tag "Port") (string :tag "Service"))
   :group 'smtpmail)
 
 (defcustom smtpmail-local-domain nil
@@ -94,7 +119,15 @@
   :group 'smtpmail)
 
 (defcustom smtpmail-debug-info nil
-  "*smtpmail debug info printout. messages and process buffer."
+  "Whether to print info in buffer *trace of SMTP session to <somewhere>*.
+See also `smtpmail-debug-verb' which determines if the SMTP protocol should
+be verbose as well."
+  :type 'boolean
+  :group 'smtpmail)
+
+(defcustom smtpmail-debug-verb nil
+  "Whether this library sends the SMTP VERB command or not.
+The commands enables verbose information from the SMTP server."
   :type 'boolean
   :group 'smtpmail)
 
@@ -115,6 +148,32 @@
   :type 'directory
   :group 'smtpmail)
 
+(defcustom smtpmail-auth-credentials '(("" 25 "" nil))
+  "Specify username and password for servers.
+It is a list of four-element lists that contain, in order,
+`servername' (a string), `port' (an integer), `user' (a string) and
+`password' (a string, or nil to query the user when needed).
+If you need to enter a `realm' too, add it to the user string, so that
+it looks like `user@realm'."
+  :type '(repeat (list (string  :tag "Server")
+		       (integer :tag "Port")
+		       (string  :tag "Username")
+		       (choice (const :tag "Query when needed" nil)
+			       (string  :tag "Password"))))
+  :version "21.1"
+  :group 'smtpmail)
+
+(defcustom smtpmail-starttls-credentials '(("" 25 "" ""))
+  "Specify STARTTLS keys and certificates for servers.
+This is a list of four-element list with `servername' (a string),
+`port' (an integer), `key' (a filename) and `certificate' (a filename)."
+  :type '(repeat (list (string  :tag "Server")
+		       (integer :tag "Port")
+		       (file    :tag "Key")
+		       (file    :tag "Certificate")))
+  :version "21.1"
+  :group 'smtpmail)
+
 (defcustom smtpmail-warn-about-unknown-extensions nil
   "*If set, print warnings about unknown SMTP extensions.
 This is mainly useful for development purposes, to learn about
@@ -136,13 +195,15 @@
 (defvar smtpmail-queue-index (concat smtpmail-queue-dir
 				     smtpmail-queue-index-file))
 
+(defconst smtpmail-auth-supported '(cram-md5 login)
+  "List of supported SMTP AUTH mechanisms.")
+
 ;;;
 ;;;
 ;;;
 
 ;;;###autoload
 (defun smtpmail-send-it ()
-  (require 'mail-utils)
   (let ((errbuf (if mail-interactive
 		    (generate-new-buffer " smtpmail errors")
 		  0))
@@ -332,12 +393,117 @@
       (concat (system-name) "." smtpmail-local-domain)
     (system-name)))
 
+(defsubst smtpmail-cred-server (cred)
+  (nth 0 cred))
+
+(defsubst smtpmail-cred-port (cred)
+  (nth 1 cred))
+
+(defsubst smtpmail-cred-key (cred)
+  (nth 2 cred))
+
+(defsubst smtpmail-cred-user (cred)
+  (nth 2 cred))
+
+(defsubst smtpmail-cred-cert (cred)
+  (nth 3 cred))
+
+(defsubst smtpmail-cred-passwd (cred)
+  (nth 3 cred))
+
+(defun smtpmail-find-credentials (cred server port)
+  (catch 'done
+    (let ((l cred) el)
+      (while (setq el (pop l))
+	(when (and (equal server (smtpmail-cred-server el))
+		   (equal port (smtpmail-cred-port el)))
+	  (throw 'done el))))))
+
 (defun smtpmail-maybe-append-domain (recipient)
   (if (or (not smtpmail-sendto-domain)
 	  (string-match "@" recipient))
       recipient
     (concat recipient "@" smtpmail-sendto-domain)))
 
+(defun smtpmail-intersection (list1 list2)
+  (let ((result nil))
+    (dolist (el2 list2)
+      (when (memq el2 list1)
+	(push el2 result)))
+    (nreverse result)))
+
+(defun smtpmail-open-stream (process-buffer host port)
+  (let ((cred (smtpmail-find-credentials
+	       smtpmail-starttls-credentials host port)))
+    (if (null (and cred (condition-case ()
+			    (call-process "starttls")
+			  (error nil))))
+	;; The normal case.
+	(open-network-stream "SMTP" process-buffer host port)
+      (let* ((cred-key (smtpmail-cred-key cred))
+	     (cred-cert (smtpmail-cred-cert cred))
+	     (starttls-extra-args
+	      (when (and (stringp cred-key) (stringp cred-cert)
+			 (file-regular-p
+			  (setq cred-key (expand-file-name cred-key)))
+			 (file-regular-p
+			  (setq cred-cert (expand-file-name cred-cert))))
+		(list "--key-file" cred-key "--cert-file" cred-cert))))
+	(starttls-open-stream "SMTP" process-buffer host port)))))
+
+(defun smtpmail-try-auth-methods (process supported-extensions host port)
+  (let* ((mechs (cdr-safe (assoc 'auth supported-extensions)))
+	 (mech (car (smtpmail-intersection smtpmail-auth-supported mechs)))
+	 (cred (smtpmail-find-credentials smtpmail-auth-credentials host port))
+	 (passwd (when cred
+		   (or (smtpmail-cred-passwd cred)
+		       (read-passwd
+			(format "SMTP password for %s:%s: "
+				(smtpmail-cred-server cred)
+				(smtpmail-cred-port cred))))))
+	 ret)
+    (when cred
+      (cond
+       ((eq mech 'cram-md5)
+	(smtpmail-send-command process (format "AUTH %s" mech))
+	(if (or (null (car (setq ret (smtpmail-read-response process))))
+		(not (integerp (car ret)))
+		(>= (car ret) 400))
+	    (throw 'done nil))
+	(when (eq (car ret) 334)
+	  (let* ((challenge (substring (cadr ret) 4))
+		 (decoded (base64-decode-string challenge))
+		 (hash (rfc2104-hash 'md5 64 16 passwd decoded))
+		 (response (concat (smtpmail-cred-user cred) " " hash))
+		 (encoded (base64-encode-string response)))
+	    (smtpmail-send-command process (format "%s" encoded))
+	    (if (or (null (car (setq ret (smtpmail-read-response process))))
+		    (not (integerp (car ret)))
+		    (>= (car ret) 400))
+		(throw 'done nil)))))
+       ((eq mech 'login)
+	(smtpmail-send-command process "AUTH LOGIN")
+	(if (or (null (car (setq ret (smtpmail-read-response process))))
+		(not (integerp (car ret)))
+		(>= (car ret) 400))
+	    (throw 'done nil))
+	(smtpmail-send-command
+	 process (base64-encode-string (smtpmail-cred-user cred)))
+	(if (or (null (car (setq ret (smtpmail-read-response process))))
+		(not (integerp (car ret)))
+		(>= (car ret) 400))
+	    (throw 'done nil))
+	(smtpmail-send-command process (base64-encode-string passwd))
+	(if (or (null (car (setq ret (smtpmail-read-response process))))
+		(not (integerp (car ret)))
+		(>= (car ret) 400))
+	    (throw 'done nil)))
+       (t
+	(error "Mechanism %s not implemented" mech)))
+      ;; Remember the password.
+      (unless (smtpmail-cred-passwd cred)
+	(setcar (cdr (cdr (cdr cred))) passwd)))))
+
 (defun smtpmail-via-smtp (recipient smtpmail-text-buffer)
   (let ((process nil)
 	(host (or smtpmail-smtp-server
@@ -359,7 +525,7 @@
 	    (erase-buffer))
 
 	  ;; open the connection to the server
-	  (setq process (open-network-stream "SMTP" process-buffer host port))
+	  (setq process (smtpmail-open-stream process-buffer host port))
 	  (and (null process) (throw 'done nil))
 
 	  ;; set the send-filter
@@ -378,32 +544,58 @@
 		(throw 'done nil)
 	      )
 
+	    (let ((do-ehlo t)
+		  (do-starttls t))
+	      (while do-ehlo
 	    ;; EHLO
 	    (smtpmail-send-command process (format "EHLO %s" (smtpmail-fqdn)))
 
-	    (if (or (null (car (setq response-code (smtpmail-read-response process))))
+	    (if (or (null (car (setq response-code
+				     (smtpmail-read-response process))))
 		    (not (integerp (car response-code)))
 		    (>= (car response-code) 400))
 		(progn
 		  ;; HELO
-		  (smtpmail-send-command process (format "HELO %s" (smtpmail-fqdn)))
+		  (smtpmail-send-command
+		   process (format "HELO %s" (smtpmail-fqdn)))
 
-		  (if (or (null (car (setq response-code (smtpmail-read-response process))))
+		  (if (or (null (car (setq response-code
+					   (smtpmail-read-response process))))
 			  (not (integerp (car response-code)))
 			  (>= (car response-code) 400))
 		      (throw 'done nil)))
-	      (let ((extension-lines (cdr (cdr response-code))))
-		(while extension-lines
-		  (let ((name (intern (downcase (car (split-string (substring (car extension-lines) 4) "[ ]"))))))
+	      (dolist (line (cdr (cdr response-code)))
+		(let ((name (mapcar (lambda (s) (intern (downcase s)))
+				    (split-string (substring line 4) "[ ]"))))
+		  (and (eq (length name) 1)
+		       (setq name (car name)))
 		    (and name
-			 (cond ((memq name '(verb xvrb 8bitmime onex xone
+		       (cond ((memq (if (consp name) (car name) name)
+				    '(verb xvrb 8bitmime onex xone
 						  expn size dsn etrn
-						  help xusr))
+				      enhancedstatuscodes
+				      help xusr
+				      auth=login auth starttls))
 				(setq supported-extensions
 				      (cons name supported-extensions)))
 			       (smtpmail-warn-about-unknown-extensions
-				(message "Unknown extension %s" name)))))
-		  (setq extension-lines (cdr extension-lines)))))
+			      (message "Unknown extension %s" name)))))))
+
+	    (if (and do-starttls
+		     (smtpmail-find-credentials smtpmail-starttls-credentials host port)
+		     (member 'starttls supported-extensions)
+		     (process-id process))
+		(progn
+		  (smtpmail-send-command process (format "STARTTLS"))
+		  (if (or (null (car (setq response-code (smtpmail-read-response process))))
+			  (not (integerp (car response-code)))
+			  (>= (car response-code) 400))
+		      (throw 'done nil))
+		  (starttls-negotiate process)
+		  (setq do-starttls nil))
+	      (setq do-ehlo nil))))
+	    
+	    (smtpmail-try-auth-methods process supported-extensions host port)
 
 	    (if (or (member 'onex supported-extensions)
 		    (member 'xone supported-extensions))
@@ -414,7 +606,7 @@
 			  (>= (car response-code) 400))
 		      (throw 'done nil))))
 
-	    (if (and smtpmail-debug-info
+	    (if (and smtpmail-debug-verb
 		     (or (member 'verb supported-extensions)
 			 (member 'xvrb supported-extensions)))
 		(progn
@@ -434,7 +626,8 @@
 
 	    ;; MAIL FROM: <sender>
 	    (let ((size-part
-		   (if (member 'size supported-extensions)
+		   (if (or (member 'size supported-extensions)
+			   (assoc 'size supported-extensions))
 		       (format " SIZE=%d"
 			       (save-excursion
 				 (set-buffer smtpmail-text-buffer)
@@ -650,8 +843,6 @@
 
 (defun smtpmail-deduce-address-list (smtpmail-text-buffer header-start header-end)
   "Get address list suitable for smtp RCPT TO: <address>."
-  (require 'mail-utils)  ;; pick up mail-strip-quoted-names
-    
   (unwind-protect
       (save-excursion
 	(set-buffer smtpmail-address-buffer) (erase-buffer)