From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Lars Magne Ingebrigtsen Newsgroups: gmane.emacs.devel Subject: Re: netrc field encryption in auth-source Date: Wed, 15 Jun 2011 23:21:08 +0200 Organization: Programmerer Ingebrigtsen Message-ID: References: <87k4e8ucw3.fsf@lifelogs.com> <87liyofwxp.fsf@lifelogs.com> <874o5cfui5.fsf@lifelogs.com> <87liyndz5l.fsf@lifelogs.com> <8739jogwf9.fsf@lifelogs.com> <87lix9eknu.fsf_-_@lifelogs.com> <878vt52ykv.fsf@lifelogs.com> NNTP-Posting-Host: lo.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: dough.gmane.org 1308175395 30348 80.91.229.12 (15 Jun 2011 22:03:15 GMT) X-Complaints-To: usenet@dough.gmane.org NNTP-Posting-Date: Wed, 15 Jun 2011 22:03:15 +0000 (UTC) To: emacs-devel@gnu.org Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Thu Jun 16 00:03:10 2011 Return-path: Envelope-to: ged-emacs-devel@m.gmane.org Original-Received: from lists.gnu.org ([140.186.70.17]) by lo.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1QWyB2-0001xR-S9 for ged-emacs-devel@m.gmane.org; Thu, 16 Jun 2011 00:03:09 +0200 Original-Received: from localhost ([::1]:37727 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1QWyB2-00039r-1Y for ged-emacs-devel@m.gmane.org; Wed, 15 Jun 2011 18:03:08 -0400 Original-Received: from eggs.gnu.org ([140.186.70.92]:55822) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1QWxWh-0008Uk-Nf for emacs-devel@gnu.org; Wed, 15 Jun 2011 17:21:34 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1QWxWd-0000bM-Id for emacs-devel@gnu.org; Wed, 15 Jun 2011 17:21:27 -0400 Original-Received: from lo.gmane.org ([80.91.229.12]:44953) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1QWxWc-0000ar-G3 for emacs-devel@gnu.org; Wed, 15 Jun 2011 17:21:23 -0400 Original-Received: from list by lo.gmane.org with local (Exim 4.69) (envelope-from ) id 1QWxWb-0006Xv-6b for emacs-devel@gnu.org; Wed, 15 Jun 2011 23:21:21 +0200 Original-Received: from cm-84.215.51.58.getinternet.no ([84.215.51.58]) by main.gmane.org with esmtp (Gmexim 0.1 (Debian)) id 1AlnuQ-0007hv-00 for ; Wed, 15 Jun 2011 23:21:21 +0200 Original-Received: from larsi by cm-84.215.51.58.getinternet.no with local (Gmexim 0.1 (Debian)) id 1AlnuQ-0007hv-00 for ; Wed, 15 Jun 2011 23:21:21 +0200 X-Injected-Via-Gmane: http://gmane.org/ Mail-Followup-To: emacs-devel@gnu.org Original-Lines: 799 Original-X-Complaints-To: usenet@dough.gmane.org X-Gmane-NNTP-Posting-Host: cm-84.215.51.58.getinternet.no Face: iVBORw0KGgoAAAANSUhEUgAAADAAAAAwBAMAAAClLOS0AAAAGFBMVEVJPz0vJSM4LiudlJEQ BwUoHhwXDgshFxQMfUe2AAACUklEQVQ4jV2UQU/cMBCFJ3GXXHGkiKsTpPbq7qjtlaIovW5oQ66A UucKRY7/ft+Ms1upA9jOfH5vPJs11GsMXYqGC1cs/R6Up3ua43c+0qf0HzhxlU7M/uq2V82wg+Ga /SsznwrzawhAQ8jgRzJIsy/IfBhCWJYzuKfasH+8JjJfwxrAth1447iCozHfkARQxdDf+T8df2me yfDnJWww263u2L+xD+/Mxm9hW3dFP6zMV8xo0RsfcqhVCIaPhg84mOGcX/c+niRV4o8ErGHdaOlD j7UAj06ItQKslkEOt/xkjdLxttdYpEQIT+JP1c0zf7wAtVphZK7izQtX51NBIJp3gMqm31QE6RAA XS5YvHiiqnp2VMr+tOYaQsj46jESHbSNRCEr1/QKxfqAIU7W2oZGW3fQ4/eayq4+uOLBEVYAHYIk nOGKXIG34gDeagEOEjL4ROqpqLEfWycFpQP06MW3VoGlqEDCsLx4X5aEhzYrsHSUPy1Ynq12iQLP KCugFgV1JHKniiMenNTIxVXNeE3scZJOgDQorMTJpHyRjQFGKy2q7hZGVo/SwqqxSiTay5a2oWlU UJ9TOrYCprGtxaCt20uvXQcQRWJr22ZLtbMAKVqpIjHW9hINxQizjKaMVS+KCYHHcRrHpsGke2ZK SUEeGvyMIp1GAEjiDiQvM4YMJOIoowy2wUAbgLipYzPtMUoNTU3zlEnMKlGApDRjUibODZQU0r+Y 44wNImgSaUZkoosyRy1FuFV6VRYsgtxY7IjzFHEN5BKc/+fgzuNrLB5/AeWpCvHrpQiwAAAAAElF TkSuQmCC Mail-Copies-To: never X-Now-Playing: Demdike Stare's _Tryptych (2): Liberation Through Hearing_: "Bardo Thodol" User-Agent: Gnus/5.110018 (No Gnus v0.18) Emacs/24.0.50 (gnu/linux) Cancel-Lock: sha1:Dkf0uGUtr23aRnaAYrnw3p7G77g= X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.6 (newer, 3) X-Received-From: 80.91.229.12 X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Original-Sender: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.emacs.devel:140520 Archived-At: --=-=-= Content-Type: text/plain Lars Magne Ingebrigtsen writes: > So please apply and I'll get started with the smtpmail.el stuff. :-) I'm basically done with the smtpmail.el STARTTLS/AUTH/startup things, and I've tested it with all the error cases I could think of (and beefed up the error reporting significantly), so I think we're good to go. But I'll wait until Tuesday to check this in. It's a pretty big patch, but the good news is that the result is about 50 lines shorter than it was when I started. :-) --=-=-= Content-Type: text/x-diff Content-Disposition: inline; filename=smtpmail.diff === modified file 'lisp/mail/smtpmail.el' *** lisp/mail/smtpmail.el 2011-05-30 17:23:47 +0000 --- lisp/mail/smtpmail.el 2011-06-15 20:33:56 +0000 *************** *** 34,47 **** ;; ;;(setq send-mail-function 'smtpmail-send-it) ; if you use `mail' ;;(setq message-send-mail-function 'smtpmail-send-it) ; if you use message/Gnus ! ;;(setq smtpmail-default-smtp-server "YOUR SMTP HOST") ;;(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 ; or use ~/.authinfo ;; '(("YOUR SMTP HOST" 25 "username" "password"))) - ;;(setq smtpmail-starttls-credentials - ;; '(("YOUR SMTP HOST" 25 "~/.my_smtp_tls.key" "~/.my_smtp_tls.cert"))) ;; Where the 25 equals the value of `smtpmail-smtp-service', it can be an ;; integer or a string, just as long as they match (eq). --- 34,45 ---- ;; ;;(setq send-mail-function 'smtpmail-send-it) ; if you use `mail' ;;(setq message-send-mail-function 'smtpmail-send-it) ; if you use message/Gnus ! ;;(setq smtpmail-smtp-server "YOUR SMTP HOST") ;;(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 ; or use ~/.authinfo ;; '(("YOUR SMTP HOST" 25 "username" "password"))) ;; Where the 25 equals the value of `smtpmail-smtp-service', it can be an ;; integer or a string, just as long as they match (eq). *************** *** 58,74 **** ;; Authentication by the AUTH mechanism. ;; See http://www.ietf.org/rfc/rfc2554.txt - ;; Modified by Simon Josefsson , 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) - (autoload 'starttls-any-program-available "starttls") - (autoload 'starttls-open-stream "starttls") - (autoload 'starttls-negotiate "starttls") (autoload 'mail-strip-quoted-names "mail-utils") (autoload 'message-make-date "message") (autoload 'message-make-message-id "message") --- 56,64 ---- *************** *** 85,95 **** :group 'mail) ! (defcustom smtpmail-default-smtp-server nil "Specify default SMTP server. ! This only has effect if you specify it before loading the smtpmail library." ! :type '(choice (const nil) string) ! :group 'smtpmail) (defcustom smtpmail-smtp-server (or (getenv "SMTPSERVER") smtpmail-default-smtp-server) --- 75,83 ---- :group 'mail) ! (defvar smtpmail-default-smtp-server nil "Specify default SMTP server. ! This only has effect if you specify it before loading the smtpmail library.") (defcustom smtpmail-smtp-server (or (getenv "SMTPSERVER") smtpmail-default-smtp-server) *************** *** 110,115 **** --- 98,113 ---- :type '(choice (const nil) string) :group 'smtpmail) + (defcustom smtpmail-stream-type nil + "Connection type SMTP connections. + This may be either nil (plain connection) or `starttls' (use the + starttls mechanism to turn on TLS security after opening the + stream)." + :version "24.1" + :group 'smtpmail + :type '(choice (const :tag "Plain" nil) + (const starttls))) + (defcustom smtpmail-sendto-domain nil "Local domain name without a host name. This is appended (with an @-sign) to any specified recipients which do *************** *** 174,195 **** :version "22.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). - If you do not have a certificate/key pair, leave the `key' and - `certificate' fields as `nil'. A key/certificate pair is only - needed if you want to use X.509 client authenticated - connections." - :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 --- 172,177 ---- *************** *** 230,235 **** --- 212,218 ---- (tembuf (generate-new-buffer " smtpmail temp")) (case-fold-search nil) delimline + result (mailbuf (current-buffer)) ;; Examine this variable now, so that ;; local binding in the mail buffer will take effect. *************** *** 373,381 **** ;; Send or queue (if (not smtpmail-queue-mail) (if (not (null smtpmail-recipient-address-list)) ! (if (not (smtpmail-via-smtp ! smtpmail-recipient-address-list tembuf)) ! (error "Sending failed; SMTP protocol error")) (error "Sending failed; no recipients")) (let* ((file-data (expand-file-name --- 356,365 ---- ;; Send or queue (if (not smtpmail-queue-mail) (if (not (null smtpmail-recipient-address-list)) ! (when (setq result ! (smtpmail-via-smtp ! smtpmail-recipient-address-list tembuf)) ! (error "Sending failed: %s" result)) (error "Sending failed; no recipients")) (let* ((file-data (expand-file-name *************** *** 432,438 **** ;; mail, send it, etc... (let ((file-msg "") (qfile (expand-file-name smtpmail-queue-index-file ! smtpmail-queue-dir))) (insert-file-contents qfile) (goto-char (point-min)) (while (not (eobp)) --- 416,423 ---- ;; mail, send it, etc... (let ((file-msg "") (qfile (expand-file-name smtpmail-queue-index-file ! smtpmail-queue-dir)) ! result) (insert-file-contents qfile) (goto-char (point-min)) (while (not (eobp)) *************** *** 448,464 **** (or (and mail-specify-envelope-from (mail-envelope-from)) user-mail-address))) (if (not (null smtpmail-recipient-address-list)) ! (if (not (smtpmail-via-smtp smtpmail-recipient-address-list ! (current-buffer))) ! (error "Sending failed; SMTP protocol error")) (error "Sending failed; no recipients")))) (delete-file file-msg) (delete-file (concat file-msg ".el")) (delete-region (point-at-bol) (point-at-bol 2))) (write-region (point-min) (point-max) qfile)))) - ;; (defun smtpmail-via-smtp (host,port,sender,destination,smtpmail-text-buffer) - (defun smtpmail-fqdn () (if smtpmail-local-domain (concat (system-name) "." smtpmail-local-domain) --- 433,448 ---- (or (and mail-specify-envelope-from (mail-envelope-from)) user-mail-address))) (if (not (null smtpmail-recipient-address-list)) ! (when (setq result (smtpmail-via-smtp ! smtpmail-recipient-address-list ! (current-buffer))) ! (error "Sending failed: %s" result)) (error "Sending failed; no recipients")))) (delete-file file-msg) (delete-file (concat file-msg ".el")) (delete-region (point-at-bol) (point-at-bol 2))) (write-region (point-min) (point-max) qfile)))) (defun smtpmail-fqdn () (if smtpmail-local-domain (concat (system-name) "." smtpmail-local-domain) *************** *** 503,548 **** (push el2 result))) (nreverse result))) - (defvar starttls-extra-args) - (defvar starttls-extra-arguments) - - (defun smtpmail-open-stream (process-buffer host port) - (let ((cred (smtpmail-find-credentials - smtpmail-starttls-credentials host port))) - (if (null (and cred (starttls-any-program-available))) - ;; The normal case. - (open-network-stream "SMTP" process-buffer host port) - (let* ((cred-key (smtpmail-cred-key cred)) - (cred-cert (smtpmail-cred-cert cred)) - (starttls-extra-args - (append - starttls-extra-args - (when (and (stringp cred-key) (stringp cred-cert) - (file-regular-p - (setq cred-key (expand-file-name cred-key))) - (file-regular-p - (setq cred-cert (expand-file-name cred-cert)))) - (list "--key-file" cred-key "--cert-file" cred-cert)))) - (starttls-extra-arguments - (append - starttls-extra-arguments - (when (and (stringp cred-key) (stringp cred-cert) - (file-regular-p - (setq cred-key (expand-file-name cred-key))) - (file-regular-p - (setq cred-cert (expand-file-name cred-cert)))) - (list "--x509keyfile" cred-key "--x509certfile" cred-cert))))) - (starttls-open-stream "SMTP" process-buffer host port))))) - ;; `password-read' autoloads password-cache. (declare-function password-cache-add "password-cache" (key password)) ! (defun smtpmail-try-auth-methods (process supported-extensions host port) (let* ((mechs (cdr-safe (assoc 'auth supported-extensions))) (mech (car (smtpmail-intersection mechs smtpmail-auth-supported))) (auth-info (auth-source-search :max 1 :host host ! :port (or port "smtp"))) (auth-user (plist-get (nth 0 auth-info) :user)) (auth-pass (plist-get (nth 0 auth-info) :secret)) (auth-pass (if (functionp auth-pass) --- 487,511 ---- (push el2 result))) (nreverse result))) ;; `password-read' autoloads password-cache. (declare-function password-cache-add "password-cache" (key password)) ! (defun smtpmail-command-or-throw (process string &optional code) ! (let (ret) ! (smtpmail-send-command process string) ! (unless (smtpmail-ok-p (setq ret (smtpmail-read-response process)) ! code) ! (throw 'done (smtpmail-response-text ret))) ! ret)) ! ! (defun smtpmail-try-auth-methods (process supported-extensions host port ! &optional ask-for-password) (let* ((mechs (cdr-safe (assoc 'auth supported-extensions))) (mech (car (smtpmail-intersection mechs smtpmail-auth-supported))) (auth-info (auth-source-search :max 1 :host host ! :port (or port "smtp") ! :create ask-for-password)) (auth-user (plist-get (nth 0 auth-info) :user)) (auth-pass (plist-get (nth 0 auth-info) :secret)) (auth-pass (if (functionp auth-pass) *************** *** 571,584 **** (or (smtpmail-cred-passwd cred) (password-read prompt prompt)))) ret) ! (when (and cred mech) (cond ((eq mech 'cram-md5) ! (smtpmail-send-command process (upcase (format "AUTH %s" mech))) ! (if (or (null (car (setq ret (smtpmail-read-response process)))) ! (not (integerp (car ret))) ! (>= (car ret) 400)) ! (throw 'done nil)) (when (eq (car ret) 334) (let* ((challenge (substring (cadr ret) 4)) (decoded (base64-decode-string challenge)) --- 534,545 ---- (or (smtpmail-cred-passwd cred) (password-read prompt prompt)))) ret) ! (if (not (and cred mech)) ! mech (cond ((eq mech 'cram-md5) ! (setq ret (smtpmail-command-or-throw ! process (format "AUTH %s" (upcase mech)))) (when (eq (car ret) 334) (let* ((challenge (substring (cadr ret) 4)) (decoded (base64-decode-string challenge)) *************** *** 596,648 **** ;; are taken as a response to the server, and the ;; authentication fails. (encoded (base64-encode-string response t))) ! (smtpmail-send-command process (format "%s" encoded)) ! (if (or (null (car (setq ret (smtpmail-read-response process)))) ! (not (integerp (car ret))) ! (>= (car ret) 400)) ! (throw 'done nil))))) ((eq mech 'login) ! (smtpmail-send-command process "AUTH LOGIN") ! (if (or (null (car (setq ret (smtpmail-read-response process)))) ! (not (integerp (car ret))) ! (>= (car ret) 400)) ! (throw 'done nil)) ! (smtpmail-send-command process (base64-encode-string (smtpmail-cred-user cred) t)) ! (if (or (null (car (setq ret (smtpmail-read-response process)))) ! (not (integerp (car ret))) ! (>= (car ret) 400)) ! (throw 'done nil)) ! (smtpmail-send-command process (base64-encode-string passwd t)) ! (if (or (null (car (setq ret (smtpmail-read-response process)))) ! (not (integerp (car ret))) ! (>= (car ret) 400)) ! (throw 'done nil))) ((eq mech 'plain) ;; We used to send an empty initial request, and wait for an ;; empty response, and then send the password, but this ;; violate a SHOULD in RFC 2222 paragraph 5.1. Note that this ;; is not sent if the server did not advertise AUTH PLAIN in ;; the EHLO response. See RFC 2554 for more info. ! (smtpmail-send-command process ! (concat "AUTH PLAIN " ! (base64-encode-string ! (concat "\0" ! (smtpmail-cred-user cred) ! "\0" ! passwd) t))) ! (if (or (null (car (setq ret (smtpmail-read-response process)))) ! (not (integerp (car ret))) ! (not (equal (car ret) 235))) ! (throw 'done nil))) ! (t (error "Mechanism %s not implemented" mech))) ;; Remember the password. (when (null (smtpmail-cred-passwd cred)) ! (password-cache-add prompt passwd))))) ! (defun smtpmail-via-smtp (recipient smtpmail-text-buffer) (let ((process nil) (host (or smtpmail-smtp-server (error "`smtpmail-smtp-server' not defined"))) --- 557,610 ---- ;; are taken as a response to the server, and the ;; authentication fails. (encoded (base64-encode-string response t))) ! (smtpmail-command-or-throw process encoded)))) ((eq mech 'login) ! (smtpmail-command-or-throw process "AUTH LOGIN") ! (smtpmail-command-or-throw process (base64-encode-string (smtpmail-cred-user cred) t)) ! (smtpmail-command-or-throw process (base64-encode-string passwd t))) ((eq mech 'plain) ;; We used to send an empty initial request, and wait for an ;; empty response, and then send the password, but this ;; violate a SHOULD in RFC 2222 paragraph 5.1. Note that this ;; is not sent if the server did not advertise AUTH PLAIN in ;; the EHLO response. See RFC 2554 for more info. ! (smtpmail-command-or-throw ! process ! (concat "AUTH PLAIN " ! (base64-encode-string ! (concat "\0" ! (smtpmail-cred-user cred) ! "\0" ! passwd) t)) ! 235)) (t (error "Mechanism %s not implemented" mech))) ;; Remember the password. (when (null (smtpmail-cred-passwd cred)) ! (password-cache-add prompt passwd)) ! nil))) ! ! (defun smtpmail-response-code (string) ! (when string ! (with-temp-buffer ! (insert string) ! (goto-char (point-min)) ! (and (re-search-forward "^\\([0-9]+\\) " nil t) ! (string-to-number (match-string 1)))))) ! ! (defun smtpmail-ok-p (response &optional code) ! (and (car response) ! (integerp (car response)) ! (< (car response) 400) ! (or (null code) ! (= code (car response))))) ! ! (defun smtpmail-response-text (response) ! (mapconcat 'identity (cdr response) "\n")) ! (defun smtpmail-via-smtp (recipient smtpmail-text-buffer ! &optional ask-for-password) (let ((process nil) (host (or smtpmail-smtp-server (error "`smtpmail-smtp-server' not defined"))) *************** *** 654,667 **** (mail-envelope-from)) user-mail-address)) response-code - greeting process-buffer (supported-extensions '())) (unwind-protect (catch 'done ;; get or create the trace buffer (setq process-buffer ! (get-buffer-create (format "*trace of SMTP session to %s*" host))) ;; clear the trace buffer of old output (with-current-buffer process-buffer --- 616,631 ---- (mail-envelope-from)) user-mail-address)) response-code process-buffer + result + auth-mechanisms (supported-extensions '())) (unwind-protect (catch 'done ;; get or create the trace buffer (setq process-buffer ! (get-buffer-create ! (format "*trace of SMTP session to %s*" host))) ;; clear the trace buffer of old output (with-current-buffer process-buffer *************** *** 669,773 **** (erase-buffer)) ;; open the connection to the server ! (setq process (smtpmail-open-stream process-buffer host port)) ! (and (null process) (throw 'done nil)) ;; set the send-filter (set-process-filter process 'smtpmail-process-filter) (with-current-buffer process-buffer (set-buffer-process-coding-system 'raw-text-unix 'raw-text-unix) (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)) ! (throw 'done nil)) ! ! (let ((do-ehlo t) ! (do-starttls t)) ! (while do-ehlo ! ;; EHLO ! (smtpmail-send-command process (format "EHLO %s" (smtpmail-fqdn))) ! ! (if (or (null (car (setq response-code ! (smtpmail-read-response process)))) ! (not (integerp (car response-code))) ! (>= (car response-code) 400)) ! (progn ! ;; HELO ! (smtpmail-send-command ! process (format "HELO %s" (smtpmail-fqdn))) ! ! (if (or (null (car (setq response-code ! (smtpmail-read-response process)))) ! (not (integerp (car response-code))) ! (>= (car response-code) 400)) ! (throw 'done nil))) ! (dolist (line (cdr (cdr response-code))) ! (let ((name ! (with-case-table ascii-case-table ! (mapcar (lambda (s) (intern (downcase s))) ! (split-string (substring line 4) "[ ]"))))) ! (and (eq (length name) 1) ! (setq name (car name))) ! (and name ! (cond ((memq (if (consp name) (car name) name) ! '(verb xvrb 8bitmime onex xone ! expn size dsn etrn ! enhancedstatuscodes ! help xusr ! auth=login auth starttls)) ! (setq supported-extensions ! (cons name supported-extensions))) ! (smtpmail-warn-about-unknown-extensions ! (message "Unknown extension %s" name))))))) ! ! (if (and do-starttls ! (smtpmail-find-credentials smtpmail-starttls-credentials host port) ! (member 'starttls supported-extensions) ! (numberp (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)))) ! ! (smtpmail-try-auth-methods process supported-extensions host port) ! ! (if (or (member 'onex supported-extensions) ! (member 'xone supported-extensions)) ! (progn ! (smtpmail-send-command process (format "ONEX")) ! (if (or (null (car (setq response-code (smtpmail-read-response process)))) ! (not (integerp (car response-code))) ! (>= (car response-code) 400)) ! (throw 'done nil)))) ! ! (if (and smtpmail-debug-verb ! (or (member 'verb supported-extensions) ! (member 'xvrb supported-extensions))) ! (progn ! (smtpmail-send-command process (format "VERB")) ! (if (or (null (car (setq response-code (smtpmail-read-response process)))) ! (not (integerp (car response-code))) ! (>= (car response-code) 400)) ! (throw 'done nil)))) ! ! (if (member 'xusr supported-extensions) ! (progn ! (smtpmail-send-command process (format "XUSR")) ! (if (or (null (car (setq response-code (smtpmail-read-response process)))) ! (not (integerp (car response-code))) ! (>= (car response-code) 400)) ! (throw 'done nil)))) ! ;; MAIL FROM: (let ((size-part (if (or (member 'size supported-extensions) --- 633,719 ---- (erase-buffer)) ;; open the connection to the server ! (setq result ! (open-network-stream ! "smtpmail" process-buffer host port ! :type smtpmail-stream-type ! :return-list t ! :capability-command (format "EHLO %s\r\n" (smtpmail-fqdn)) ! :end-of-command "^[0-9]+ .*\r\n" ! :success "^2.*\n" ! :always-query-capabilities t ! :starttls-function ! (lambda (capabilities) ! (and (string-match "-STARTTLS" capabilities) ! "STARTTLS\r\n")))) ! ! ;; If we couldn't access the server at all, we give up. ! (unless (setq process (car result)) ! (throw 'done "Unable to contact server")) ;; set the send-filter (set-process-filter process 'smtpmail-process-filter) + (let* ((greeting (plist-get (cdr result) :greeting)) + (code (smtpmail-response-code greeting))) + (unless code + (throw 'done (format "No greeting: %s" greeting))) + (when (>= code 400) + (throw 'done (format "Connection not allowed: %s" greeting)))) + (with-current-buffer process-buffer (set-buffer-process-coding-system 'raw-text-unix 'raw-text-unix) (make-local-variable 'smtpmail-read-point) (setq smtpmail-read-point (point-min)) ! (let* ((capabilities (plist-get (cdr result) :capabilities)) ! (code (smtpmail-response-code capabilities))) ! (if (or (null code) ! (>= code 400)) ! ;; The server didn't accept EHLO, so we fall back on HELO. ! (smtpmail-command-or-throw ! process (format "HELO %s" (smtpmail-fqdn))) ! ;; EHLO was successful, so we parse the extensions. ! (dolist (line (delete ! "" ! (split-string ! (plist-get (cdr result) :capabilities) ! "\r\n"))) ! (let ((name ! (with-case-table ascii-case-table ! (mapcar (lambda (s) (intern (downcase s))) ! (split-string (substring line 4) "[ ]"))))) ! (when (= (length name) 1) ! (setq name (car name))) ! (when name ! (cond ((memq (if (consp name) (car name) name) ! '(verb xvrb 8bitmime onex xone ! expn size dsn etrn ! 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 auth-mechanisms ! (smtpmail-try-auth-methods ! process supported-extensions host port ! ask-for-password)) ! ! (when (or (member 'onex supported-extensions) ! (member 'xone supported-extensions)) ! (smtpmail-command-or-throw process (format "ONEX"))) ! ! (when (and smtpmail-debug-verb ! (or (member 'verb supported-extensions) ! (member 'xvrb supported-extensions))) ! (smtpmail-command-or-throw process (format "VERB"))) ! ! (when (member 'xusr supported-extensions) ! (smtpmail-command-or-throw process (format "XUSR"))) ! ;; MAIL FROM: (let ((size-part (if (or (member 'size supported-extensions) *************** *** 797,861 **** " BODY=8BITMIME" "") ""))) ! ;; (smtpmail-send-command process (format "MAIL FROM:%s@%s" (user-login-name) (smtpmail-fqdn))) ! (smtpmail-send-command process (format "MAIL FROM:<%s>%s%s" ! envelope-from ! size-part ! body-part)) ! ! (if (or (null (car (setq response-code (smtpmail-read-response process)))) ! (not (integerp (car response-code))) ! (>= (car response-code) 400)) ! (throw 'done nil))) ;; RCPT TO: (let ((n 0)) (while (not (null (nth n recipient))) ! (smtpmail-send-command process (format "RCPT TO:<%s>" (smtpmail-maybe-append-domain (nth n recipient)))) ! (setq n (1+ n)) ! ! (setq response-code (smtpmail-read-response process)) ! (if (or (null (car response-code)) ! (not (integerp (car response-code))) ! (>= (car response-code) 400)) ! (throw 'done nil)))) ! ! ;; DATA ! (smtpmail-send-command process "DATA") ! ! (if (or (null (car (setq response-code (smtpmail-read-response process)))) ! (not (integerp (car response-code))) ! (>= (car response-code) 400)) ! (throw 'done nil)) ! ;; Mail contents (smtpmail-send-data process smtpmail-text-buffer) - ;; DATA end "." ! (smtpmail-send-command process ".") ! ! (if (or (null (car (setq response-code (smtpmail-read-response process)))) ! (not (integerp (car response-code))) ! (>= (car response-code) 400)) ! (throw 'done nil)) ! ! ;; QUIT ! ;; (smtpmail-send-command process "QUIT") ! ;; (and (null (car (smtpmail-read-response process))) ! ;; (throw 'done nil)) ! t)) ! (if process ! (with-current-buffer (process-buffer process) ! (smtpmail-send-command process "QUIT") ! (smtpmail-read-response process) ! ! ;; (if (or (null (car (setq response-code (smtpmail-read-response process)))) ! ;; (not (integerp (car response-code))) ! ;; (>= (car response-code) 400)) ! ;; (throw 'done nil)) ! (delete-process process) ! (unless smtpmail-debug-info ! (kill-buffer process-buffer))))))) (defun smtpmail-process-filter (process output) --- 743,795 ---- " BODY=8BITMIME" "") ""))) ! (smtpmail-command-or-throw ! process (format "MAIL FROM:<%s>%s%s" ! envelope-from size-part body-part))) ;; RCPT TO: (let ((n 0)) (while (not (null (nth n recipient))) ! (smtpmail-send-command ! process (format "RCPT TO:<%s>" ! (smtpmail-maybe-append-domain ! (nth n recipient)))) ! (cond ! ((smtpmail-ok-p (setq result (smtpmail-read-response process))) ! ;; Success. ! nil) ! ((and auth-mechanisms ! (not ask-for-password) ! (= (car result) 550)) ! ;; We got a "550 relay not permitted", and the server ! ;; accepts credentials, so we try again, but ask for a ! ;; password first. ! (smtpmail-send-command process "QUIT") ! (smtpmail-read-response process) ! (delete-process process) ! (throw 'done ! (smtpmail-via-smtp recipient smtpmail-text-buffer t))) ! (t ! ;; Return the error code. ! (throw 'done ! (smtpmail-response-text result)))) ! (setq n (1+ n)))) ! ;; Send the contents. ! (smtpmail-command-or-throw process "DATA") (smtpmail-send-data process smtpmail-text-buffer) ;; DATA end "." ! (smtpmail-command-or-throw process ".") ! ;; Return success. ! nil)) ! (when (and process ! (buffer-live-p process-buffer)) ! (with-current-buffer (process-buffer process) ! (smtpmail-send-command process "QUIT") ! (smtpmail-read-response process) ! (delete-process process) ! (unless smtpmail-debug-info ! (kill-buffer process-buffer))))))) (defun smtpmail-process-filter (process output) --=-=-= Content-Type: text/plain -- (domestic pets only, the antidote for overdose, milk.) bloggy blog http://lars.ingebrigtsen.no/ --=-=-=--