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.
It requires rfc2104.el and md5.el that is shipped with recent Gnus's.
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) + "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))))) + ((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 (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