[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
smtpmail.el STARTTLS/AUTH support
From: |
Simon Josefsson |
Subject: |
smtpmail.el STARTTLS/AUTH support |
Date: |
Tue, 23 Oct 2001 23:54:09 +0200 |
User-agent: |
Gnus/5.090004 (Oort Gnus v0.04) Emacs/21.1 (i686-pc-linux-gnu) |
I think this patch was scheduled for Emacs 21.2 previously, this is a
slightly updated version of the patch.
This patch uses (require 'cl), I know this is bad style but I get byte
compile warnings otherwise (even if I wrap it in eval-when-compile).
What is the proper solution?
2001-10-23 Simon Josefsson <jas@extundo.com>
* mail/smtpmail.el (top-level): Autoload starttls, mail-utils and
rfc2104. Require base64 and cl.
(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): New utility functions.
(smtpmail-via-smtp): Support STARTTLS, if binary is installed.
(smtpmail-via-smtp): Support AUTH.
(smtpmail-via-smtp): Use `smtpmail-debug-verb' to control VERB.
Index: smtpmail.el
===================================================================
RCS file: /cvsroot/emacs/emacs/lisp/mail/smtpmail.el,v
retrieving revision 1.32
diff -u -u -w -r1.32 smtpmail.el
--- smtpmail.el 2001/10/18 20:48:04 1.32
+++ smtpmail.el 2001/10/23 21:52:22
@@ -7,6 +7,9 @@
;; 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>
+;; AUTH support: Simon Josefsson <jas@pdc.kth.se>
+;; STARTTLS support: Simon Josefsson <jas@pdc.kth.se>
;; Keywords: mail
;; This file is part of GNU Emacs.
@@ -38,15 +41,39 @@
;;(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")
+(require 'base64)
+(require 'cl)
;;;
(defgroup smtpmail nil
@@ -66,8 +93,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,10 +122,18 @@
: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)
+
(defcustom smtpmail-code-conv-from nil ;; *junet*
"*smtpmail code convert from this code to *internal*..for tiny-mime.."
:type 'boolean
@@ -115,6 +151,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 +198,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,6 +396,32 @@
(concat (system-name) "." smtpmail-local-domain)
(system-name)))
+(defmacro smtpmail-cred-server (cred)
+ `(nth 0 ,cred))
+
+(defmacro smtpmail-cred-port (cred)
+ `(nth 1 ,cred))
+
+(defmacro smtpmail-cred-key (cred)
+ `(nth 2 ,cred))
+
+(defmacro smtpmail-cred-user (cred)
+ `(nth 2 ,cred))
+
+(defmacro smtpmail-cred-cert (cred)
+ `(nth 3 ,cred))
+
+(defmacro 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))
@@ -359,7 +449,19 @@
(erase-buffer))
;; open the connection to the server
- (setq process (open-network-stream "SMTP" process-buffer host port))
+ (let ((cred (smtpmail-find-credentials smtpmail-starttls-credentials
host port)))
+ (if (and cred (condition-case ()
+ (call-process "starttls")
+ (error nil)))
+ (let ((starttls-extra-args
+ (when (and (string-to-list (smtpmail-cred-key cred))
+ (string-to-list (smtpmail-cred-cert cred))
+ (file-regular-p (expand-file-name
(smtpmail-cred-key cred)))
+ (file-regular-p (expand-file-name
(smtpmail-cred-cert cred))))
+ (list "--key-file" (expand-file-name
(smtpmail-cred-key cred))
+ "--cert-file" (expand-file-name
(smtpmail-cred-cert cred))))))
+ (setq process (starttls-open-stream "SMTP" process-buffer
host port)))
+ (setq process (open-network-stream "SMTP" process-buffer host
port))))
(and (null process) (throw 'done nil))
;; set the send-filter
@@ -378,6 +480,9 @@
(throw 'done nil)
)
+ (let ((do-ehlo t)
+ (do-starttls t))
+ (while do-ehlo
;; EHLO
(smtpmail-send-command process (format "EHLO %s" (smtpmail-fqdn)))
@@ -394,17 +499,84 @@
(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) "[ ]"))))))
+ (let ((name (mapcar 'intern (mapcar 'downcase
(split-string (substring (car extension-lines) 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)))))
+ (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))))
+
+ (let* ((mechs (cdr-safe (assoc 'auth supported-extensions)))
+ (mech (car (intersection smtpmail-auth-supported mechs)))
+ (cred (smtpmail-find-credentials smtpmail-auth-credentials
host port))
+ passwd)
+ (when cred
+ (or (smtpmail-cred-passwd cred)
+ (setq passwd (read-passwd
+ (format "SMTP password for %s:%s: "
+ (smtpmail-cred-server cred)
+ (smtpmail-cred-port cred)))))
+ (cond ((eq mech 'cram-md5)
+ (smtpmail-send-command process (format "AUTH %s" mech))
+ (if (or (null (car (setq response-code
(smtpmail-read-response process))))
+ (not (integerp (car response-code)))
+ (>= (car response-code) 400))
+ (throw 'done nil))
+ (when (eq (car response-code) 334)
+ (let* ((challenge (substring (cadr response-code) 4))
+ (decoded (base64-decode-string challenge))
+ (hash (rfc2104-hash 'md5 64 16 (or
(smtpmail-cred-passwd cred) 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 response-code
(smtpmail-read-response process))))
+ (not (integerp (car response-code)))
+ (>= (car response-code) 400))
+ (throw 'done nil)))))
+ ((eq mech 'login)
+ (smtpmail-send-command process "AUTH LOGIN")
+ (if (or (null (car (setq response-code
(smtpmail-read-response process))))
+ (not (integerp (car response-code)))
+ (>= (car response-code) 400))
+ (throw 'done nil))
+ (smtpmail-send-command process (base64-encode-string
(smtpmail-cred-user cred)))
+ (if (or (null (car (setq response-code
(smtpmail-read-response process))))
+ (not (integerp (car response-code)))
+ (>= (car response-code) 400))
+ (throw 'done nil))
+ (smtpmail-send-command process (base64-encode-string (or
(smtpmail-cred-passwd cred) passwd)))
+ (if (or (null (car (setq response-code
(smtpmail-read-response process))))
+ (not (integerp (car response-code)))
+ (>= (car response-code) 400))
+ (throw 'done nil)))
+ (t
+ (error "Mechanism %s not implemented" mech)))
+ (when passwd
+ (setcar (cdr (cdr (cdr cred))) passwd))))
+
(if (or (member 'onex supported-extensions)
(member 'xone supported-extensions))
(progn
@@ -414,7 +586,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 +606,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 +823,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)
- smtpmail.el STARTTLS/AUTH support,
Simon Josefsson <=