smtpmail.el AUTH and STARTTLS support

[Simon Josefsson]

Hi, now that Emacs have md5 support, my smtpmail.el patch might be
useful.  This add support for SMTP AUTH (authentication) and STARTTLS
(encryption + authentication) to smtpmail.el.

Starttls.el is part of Gnus -- I'm not sure if you wish to put it in
lisp/mail/ or sync up lisp/gnus with Gnus CVS.  rfc2104.el is also
part of Gnus, but Emacs 21 has it.

--- smtpmail.el-emacs20 Sat Sep 30 21:10:04 2000
+++ smtpmail.el Sat Dec  2 21:47:52 2000
@@ -5,6 +5,8 @@
 ;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
 ;; Maintainer: Brian D. Carlstrom <bdc@ai.mit.edu>
 ;; ESMTP support: Simon Leinen <simon@switch.ch>
+;; AUTH=LOGIN support: Stephen Cranefield <scranefield@infoscience.otago.ac.nz>
+;; AUTH support: Simon Josefsson <jas@pdc.kth.se>
 ;; Keywords: mail
 
 ;; This file is part of GNU Emacs.
@@ -35,15 +37,36 @@
 ;;(setq smtpmail-default-smtp-server "YOUR SMTP HOST")
 ;;(setq smtpmail-local-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.  Require external program 
ftp://ftp.opaopa.org/pub/elisp/starttls-*.tar.gz.
+;; See http://www.ietf.org/rfc/rfc2246.txt, http://www.ietf.org/rfc/rfc2595.txt
 
 ;;; Code:
 
 (require 'sendmail)
 (require 'time-stamp)
+(require 'starttls)
+(require 'rfc2104)
+(require 'base64)
+(eval-when-compile (require 'cl))
 
 ;;;
 (defgroup smtpmail nil
@@ -96,6 +119,29 @@
   :type 'directory
   :group 'smtpmail)
 
+(defcustom smtpmail-auth-credentials '(("" 25 "" ""))
+  "*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).
+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")
+                      (string  :tag "Password")))
+  :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")))
+  :group 'smtpmail)
+
 (defvar smtpmail-queue-index-file "index"
   "File name of queued mail index,
 This is relative to `smtpmail-queue-dir'.")
@@ -109,6 +155,9 @@
 (defvar smtpmail-queue-index (concat smtpmail-queue-dir
                                     smtpmail-queue-index-file))
 
+(defconst smtpmail-auth-supported '(cram-md5)
+  "List of supported SMTP AUTH mechanisms.")
+
 ;;;
 ;;;
 ;;;
@@ -305,6 +354,14 @@
       (concat (system-name) "." smtpmail-local-domain)
     (system-name)))
 
+(defun smtpmail-find-credentials (cred server port)
+  (catch 'done
+    (let ((l cred) el)
+      (while (setq el (pop l))
+       (when (and (equal server (nth 0 el))
+                  (equal port (nth 1 el)))
+         (throw 'done el))))))
+
 (defun smtpmail-via-smtp (recipient smtpmail-text-buffer)
   (let ((process nil)
        (host (or smtpmail-smtp-server
@@ -326,7 +383,18 @@
            (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 (nth 2 cred)) (string-to-list 
(nth 3 cred))
+                                 (file-regular-p (expand-file-name (nth 2 
cred)))
+                                 (file-regular-p (expand-file-name (nth 3 
cred))))
+                        (list "--key-file" (expand-file-name (nth 2 cred))
+                              "--cert-file" (expand-file-name (nth 3 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
@@ -338,7 +406,6 @@
            (make-local-variable 'smtpmail-read-point)
            (setq smtpmail-read-point (point-min))
 
-           
            (if (or (null (car (setq greeting (smtpmail-read-response 
process))))
                    (not (integerp (car greeting)))
                    (>= (car greeting) 400))
@@ -361,17 +428,75 @@
                      (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
-                                                 expn size dsn etrn
-                                                 help xusr))
+                                                 expn size dsn etrn 
+                                                 enhancedstatuscodes
+                                                 help xusr
+                                                 auth=login auth starttls))
+                               (setq supported-extensions
+                                     (cons name supported-extensions)))
+                              ((and (consp name) (memq (car name) '(auth)))
                                (setq supported-extensions
                                      (cons name supported-extensions)))
                               (t (message "unknown extension %s"
                                           name)))))
                  (setq extension-lines (cdr extension-lines)))))
 
+           (if (and (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)))
+
+           (let* ((mechs (cdr-safe (assoc 'auth supported-extensions)))
+                  (mech (car (intersection smtpmail-auth-supported mechs)))
+                  (cred (smtpmail-find-credentials smtpmail-auth-credentials 
host port)))
+             (when 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 (nth 3 cred) 
decoded))
+                               (response (concat (nth 2 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)))))
+                     ((member 'auth=login supported-extensions)
+                      (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 
(nth 2 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 
(nth 3 cred)))
+                      (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)))))
+               
            (if (or (member 'onex supported-extensions)
                    (member 'xone supported-extensions))
                (progn

starttls.el
Description: application/emacs-lisp