Sending authenticated mail (rfc2554) using Emacs

Simon Josefsson <jas@pdc.kth.se>


RFC2554 describe a method of authenticating SMTP sessions. This patch against smtpmail.el (shipped with Emacs) implement the HMAC CRAM-MD5 SMTP AUTH scheme described in RFC2104.

Emacs 21 users: Do not use the patch below, just fetch the latest smtpmail.el version from Emacs CVS instead. It is much more complete. Update: You need sendmail.el and netrc.el too.

XEmacs users: Just get the latest "mail-lib" package, it includes everything you need.

Update! A manual for smtpmail.el has been written, available online as HTML, and also as PDF.

It requires rfc2104.el and md5.el that is shipped with recent Gnus's. (The `md5' functionality that comes with Emacs 21 is sufficient, if you use Emacs 21 you do not need to install neither rfc2104.el nor md5.el.)

If this patch fail to apply for some reason, you can download my patched copy.

Stephen Cranefield <scranefield@infoscience.otago.ac.nz> contributed AUTH=LOGIN support, I've merged it with my patch and this version support both variants (I believe AUTH=LOGIN was the draft that later became RFC2554, and turned out to be incompatible).

I've found a great resource of sendmail SMTP AUTH tips.

--- smtpmail.el.orig	Sat Feb 19 00:44:11 2000
+++ smtpmail.el	Tue Feb 22 22:19:20 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>
+;; ESMTP AUTH support: Simon Josefsson <jas@pdc.kth.se>
+;; ESMTP AUTH=LOGIN support: Stephen Cranefield <scranefield@infoscience.otago.ac.nz>
 ;; Keywords: mail
 
 ;; This file is part of GNU Emacs.
@@ -35,16 +37,34 @@
 ;;(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-login-username "YOUR AUTHENTICATION NAME HERE")
+;;                                   e.g. "infoscience\\scranefield"
+;;                                   for NT domain\NT username
 
 ;; 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
+;; Slightly modified by Simon Josefsson.
+
+;; 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
 
 ;;; Code:
 
 (require 'sendmail)
 (require 'time-stamp)
 
+(eval-when-compile (require 'cl))
+(eval-and-compile
+  (autoload 'base64-decode-string "base64")
+  (autoload 'base64-encode-string "base64")
+  (autoload 'rfc2104-hash "rfc2104")
+  (autoload 'md5 "md5"))
+
 ;;;
 (defgroup smtpmail nil
   "SMTP protocol for sending mail."
@@ -96,6 +116,14 @@
   :type 'directory
   :group 'smtpmail)
 
+(defcustom smtpmail-auth-credentials nil
+  "*Specify username and password for servers.
+This is a list of the triplet `servername', `user' and `password'."
+  :type '(repeat (list (string :tag "Server")
+		       (string :tag "Username")
+		       (string :tag "Password")))
+  :group 'smtpmail)
+
 (defvar smtpmail-queue-index-file "index"
   "File name of queued mail index,
 This is relative to `smtpmail-queue-dir'.")
@@ -109,6 +137,9 @@
 (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.")
+
 ;;;
 ;;;
 ;;;
@@ -361,17 +392,64 @@
 		      (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))
+						  help xusr auth=login auth))
+				(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)))))
 
+	    (let* ((mechs (assoc 'auth supported-extensions))
+		  (mech (car (intersection smtpmail-auth-supported (cdr mechs))))
+		  (cred (assoc host smtpmail-auth-credentials)))
+	      (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 2 cred) decoded))
+				(response (concat (nth 1 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 (format (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 
+					      (format (base64-encode-string (nth 1 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