--- smtpmail.el-emacs21 Sat Sep 30 21:10:54 2000 +++ smtpmail.el Sat Oct 7 19:48:46 2000 @@ -7,6 +7,8 @@ ;; Author: Tomoji Kagatani ;; Maintainer: Brian D. Carlstrom ;; ESMTP support: Simon Leinen +;; AUTH=LOGIN support: Stephen Cranefield +;; AUTH support: Simon Josefsson ;; Keywords: mail ;; This file is part of GNU Emacs. @@ -38,16 +40,38 @@ ;;(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 , +;; 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 , 22/2/99, to support SMTP +;; Authentication by the AUTH mechanism. +;; See http://www.ietf.org/rfc/rfc2554.txt + +;; Modified by Simon Josefsson , 2000-10-07, to support +;; STARTTLS +;; See http://www.ietf.org/rfc/rfc2246.txt, http://www.ietf.org/rfc/rfc2595.txt + ;;; Code: (require 'sendmail) (require 'time-stamp) +(eval-when-compile (require 'cl)) +(eval-and-compile + (autoload 'rfc2104-hash "rfc2104")) + ;;; (defgroup smtpmail nil "SMTP protocol for sending mail." @@ -121,6 +145,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'.") @@ -134,6 +181,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.") + ;;; ;;; ;;; @@ -330,6 +380,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 @@ -351,7 +409,20 @@ (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 () + (progn + (require 'starttls) + (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 @@ -386,17 +457,74 @@ (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 (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 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)) + (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))) + (t + (error "Mechanism %s not implemented" mech))))) + (if (or (member 'onex supported-extensions) (member 'xone supported-extensions)) (progn