From ccedc6797e041af35f00f2fa8fb45bffea5c3797 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 11 Jan 2018 11:56:43 -0500 Subject: [PATCH] * lisp/mail/smtpmail.el: Use lexical-binding and cl-generic (smtpmail-auth-supported): Mark it as non-constant. (smtpmail-try-auth-methods): Remove unused var 'ret'. Test non-nullness of mech user and password before calling smtpmail-try-auth-method. (smtpmail-try-auth-method): Make it into a generic function. (smtpmail-via-smtp): Remove unused var 'response-code'. --- etc/NEWS | 4 ++ lisp/mail/smtpmail.el | 110 ++++++++++++++++++++++-------------------- 2 files changed, 61 insertions(+), 53 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index f6f36dfc852..26f8857ca24 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -88,6 +88,10 @@ strings in non-text modes. * Changes in Specialized Modes and Packages in Emacs 27.1 +** Smtpmail +Authentication mechanisms can be added via external packages, by +defining new cl-defmethod of smtpmail-try-auth-method. + ** Footnote-mode *** Support Hebrew-style footnotes *** Footnote text lines are now aligned. diff --git a/lisp/mail/smtpmail.el b/lisp/mail/smtpmail.el index 20cbeb5f4ea..186307fc380 100644 --- a/lisp/mail/smtpmail.el +++ b/lisp/mail/smtpmail.el @@ -1,4 +1,4 @@ -;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail +;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail -*- lexical-binding:t -*- ;; Copyright (C) 1995-1996, 2001-2018 Free Software Foundation, Inc. @@ -138,7 +138,7 @@ The commands enables verbose information from the SMTP server." (defcustom smtpmail-code-conv-from nil "Coding system for encoding outgoing mail. Used for the value of `sendmail-coding-system' when -`select-message-coding-system' is called. " +`select-message-coding-system' is called." :type 'coding-system :group 'smtpmail) @@ -179,9 +179,11 @@ This is relative to `smtpmail-queue-dir'." ;; Buffer-local variable. (defvar smtpmail-read-point) -(defconst smtpmail-auth-supported '(cram-md5 plain login) +(defvar smtpmail-auth-supported '(cram-md5 plain login) "List of supported SMTP AUTH mechanisms. -The list is in preference order.") +The list is in preference order. +Every element should have a matching `cl-defmethod' for +for `smtpmail-try-auth-method'.") (defvar smtpmail-mail-address nil "Value to use for envelope-from address for mail from ambient buffer.") @@ -508,8 +510,7 @@ The list is in preference order.") (user (plist-get auth-info :user)) (password (plist-get auth-info :secret)) (save-function (and ask-for-password - (plist-get auth-info :save-function))) - ret) + (plist-get auth-info :save-function)))) (when (functionp password) (setq password (funcall password))) (when (and user @@ -530,7 +531,10 @@ The list is in preference order.") (when (functionp password) (setq password (funcall password))) (let ((result (catch 'done - (smtpmail-try-auth-method process mech user password)))) + (if (and mech user password) + (smtpmail-try-auth-method process mech user password) + ;; No mechanism, or no credentials. + mech)))) (if (stringp result) (progn (auth-source-forget+ :host host :port port) @@ -539,51 +543,52 @@ The list is in preference order.") (funcall save-function)) result)))) -(defun smtpmail-try-auth-method (process mech user password) - (let (ret) - (cond - ((or (not mech) - (not user) - (not password)) - ;; No mechanism, or no credentials. - mech) - ((eq mech 'cram-md5) - (setq ret (smtpmail-command-or-throw process "AUTH CRAM-MD5")) - (when (eq (car ret) 334) - (let* ((challenge (substring (cadr ret) 4)) - (decoded (base64-decode-string challenge)) - (hash (rfc2104-hash 'md5 64 16 password decoded)) - (response (concat user " " hash)) - ;; Osamu Yamane : - ;; SMTP auth fails because the SMTP server identifies - ;; only the first part of the string (delimited by - ;; new line characters) as a response from the - ;; client, and the rest as distinct commands. - - ;; In my case, the response string is 80 characters - ;; long. Without the no-line-break option for - ;; `base64-encode-string', only the first 76 characters - ;; 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 user t)) - (smtpmail-command-or-throw process (base64-encode-string password 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" user "\0" password) t)) - 235)) - (t - (error "Mechanism %s not implemented" mech))))) +(cl-defgeneric smtpmail-try-auth-method (_process mech _user _password) + "Perform authentication of type MECH for USER with PASSWORD. +MECH should be one of the values in `smtpmail-auth-supported'. +USER and PASSWORD should be non-nil." + (error "Mechanism %S not implemented" mech)) + +(cl-defmethod smtpmail-try-auth-method + (process (_mech (eql cram-md5)) user password) + (let ((ret (smtpmail-command-or-throw process "AUTH CRAM-MD5"))) + (when (eq (car ret) 334) + (let* ((challenge (substring (cadr ret) 4)) + (decoded (base64-decode-string challenge)) + (hash (rfc2104-hash 'md5 64 16 password decoded)) + (response (concat user " " hash)) + ;; Osamu Yamane : + ;; SMTP auth fails because the SMTP server identifies + ;; only the first part of the string (delimited by + ;; new line characters) as a response from the + ;; client, and the rest as distinct commands. + + ;; In my case, the response string is 80 characters + ;; long. Without the no-line-break option for + ;; `base64-encode-string', only the first 76 characters + ;; are taken as a response to the server, and the + ;; authentication fails. + (encoded (base64-encode-string response t))) + (smtpmail-command-or-throw process encoded))))) + +(cl-defmethod smtpmail-try-auth-method + (process (_mech (eql login)) user password) + (smtpmail-command-or-throw process "AUTH LOGIN") + (smtpmail-command-or-throw process (base64-encode-string user t)) + (smtpmail-command-or-throw process (base64-encode-string password t))) + +(cl-defmethod smtpmail-try-auth-method + (process (_mech (eql plain)) user password) + ;; 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" user "\0" password) t)) + 235)) (defun smtpmail-response-code (string) (when string @@ -662,7 +667,6 @@ Returns an error if the server cannot be contacted." (and from (cadr (mail-extract-address-components from)))) (smtpmail-user-mail-address))) - response-code process-buffer result auth-mechanisms -- 2.39.2