[PATCH] mail-lib: starttls fixes for smtpmail.el

I've installed this, but it needs review and testing. Index: ChangeLog =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/mail-lib/ChangeLog,v retrieving revision 1.163 retrieving revision 1.166 diff -u -p -r1.163 -r1.166 --- ChangeLog 28 Oct 2005 05:16:48 -0000 1.163 +++ ChangeLog 8 Mar 2006 10:13:04 -0000 1.166 ＠＠ -1,3 +1,12 ＠＠ +2006-03-08 Simon Josefsson <jas(a)extundo.com&gt; + + * smtpmail.el: Sync with GNU Emacs, adds support for GnuTLS and + some other fixes. + + * tls.el: Sync with GNU Emacs, adds support for OpenSSL. + + * starttls.el: Sync cosmetic fixes with GNU Emacs CVS HEAD. + 2005-10-28 Norbert Koch <viteno(a)xemacs.org&gt; * Makefile (VERSION): XEmacs package 1.75 released. Index: smtpmail.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/mail-lib/smtpmail.el,v retrieving revision 1.23 retrieving revision 1.24 diff -u -p -r1.23 -r1.24 --- smtpmail.el 26 Oct 2005 07:53:20 -0000 1.23 +++ smtpmail.el 8 Mar 2006 10:12:55 -0000 1.24 ＠＠ -1,7 +1,7 ＠＠ ;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail -;; Copyright (C) 1995, 1996, 2001, 2002, 2003, 2004, 2005 -;; Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996, 2001, 2002, 2003, 2004, 2005, +;; 2006 Free Software Foundation, Inc. ;; Author: Tomoji Kagatani <kagatani(a)rbc.ncl.omron.co.jp&gt; ;; Maintainer: Simon Josefsson <simon(a)josefsson.org&gt; ＠＠ -26,10 +26,8 ＠＠ ;; You should have received a copy of the GNU General Public License ;; along with XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: Emacs 21.3 from CVS 2002-09-17 +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: ＠＠ -170,9 +168,9 ＠＠ need to enter a `realm' too, add it to t looks like `user(a)realm&#39;.&quot; :type '(choice file (repeat (list (string :tag "Server") - (integer :tag "Port") - (string :tag "Username") - (choice (const :tag "Query when needed" nil) + (integer :tag "Port") + (string :tag "Username") + (choice (const :tag "Query when needed" nil) (string :tag "Password"))))) :group 'smtpmail) ＠＠ -208,7 +206,7 ＠＠ This is relative to `smtpmail-queue-dir' (defvar smtpmail-queue-index (concat smtpmail-queue-dir smtpmail-queue-index-file)) -(defconst smtpmail-auth-supported '(cram-md5 login) +(defconst smtpmail-auth-supported '(cram-md5 plain login) "List of supported SMTP AUTH mechanisms.") ;;; ＠＠ -216,7 +214,7 ＠＠ This is relative to `smtpmail-queue-dir' ;;; (defvar smtpmail-mail-address nil - "Value of `user-mail-address' in ambient buffer.") + "Value to use for envelope-from address for mail from ambient buffer.") ;;;###autoload (defun smtpmail-send-it () ＠＠ -227,7 +225,11 ＠＠ This is relative to `smtpmail-queue-dir' (case-fold-search nil) delimline (mailbuf (current-buffer)) - (smtpmail-mail-address (user-mail-address)) ;; XEmacs + ;; Examine this variable now, so that + ;; local binding in the mail buffer will take effect. + (smtpmail-mail-address + (or (and mail-specify-envelope-from (mail-envelope-from)) + (user-mail-address))) ;; XEmacs ;; XEmacs: Don't frob `smtpmail-code-conv-from' here ) (unwind-protect ＠＠ -359,9 +361,11 ＠＠ This is relative to `smtpmail-queue-dir' (buffer-data (create-file-buffer file-data)) (buffer-elisp (create-file-buffer file-elisp)) (buffer-scratch "*queue-mail*")) + (unless (file-exists-p smtpmail-queue-dir) + (make-directory smtpmail-queue-dir t)) (with-current-buffer buffer-data (erase-buffer) - (insert-buffer tembuf) + (insert-buffer-substring tembuf) (write-file file-data) (set-buffer buffer-elisp) (erase-buffer) ＠＠ -383,6 +387,7 ＠＠ This is relative to `smtpmail-queue-dir' (if (bufferp errbuf) (kill-buffer errbuf))))) +;;;###autoload (defun smtpmail-send-queued-mail () "Send mail that was queued as a result of setting `smtpmail-queue-mail'." (interactive) ＠＠ -393,7 +398,7 ＠＠ This is relative to `smtpmail-queue-dir' (insert-file-contents smtpmail-queue-index) (goto-char (point-min)) (while (not (eobp)) - (setq file-msg (buffer-substring (point) (point-at-eol))) ;; XEmacs + (setq file-msg (buffer-substring (point) (line-end-position))) (load file-msg) ;; Insert the message literally: it is already encoded as per ;; the MIME headers, and code conversions might guess the ＠＠ -401,14 +406,17 ＠＠ This is relative to `smtpmail-queue-dir' (with-temp-buffer (let ((coding-system-for-read 'binary)) ;; XEmacs (insert-file-contents file-msg)) - (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"))) + (let ((smtpmail-mail-address + (or (and mail-specify-envelope-from (mail-envelope-from)) + (user-mail-address)))) ;; XEmacs + (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) (save-excursion (forward-line 1) (point)))) + (delete-region (point-at-bol) (point-at-bol 2))) (write-region (point-min) (point-max) smtpmail-queue-index)))) ;(defun smtpmail-via-smtp (host,port,sender,destination,smtpmail-text-buffer) ＠＠ -457,25 +465,41 ＠＠ This is relative to `smtpmail-queue-dir' (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 (condition-case () - (progn + (with-no-warnings (require 'starttls) - (call-process starttls-program)) + (call-process (if starttls-use-gnutls + starttls-gnutls-program + starttls-program))) (error nil)))) ;; 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 - (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)))) + (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))))) (defun smtpmail-try-auth-methods (process supported-extensions host port) ＠＠ -483,9 +507,9 ＠＠ This is relative to `smtpmail-queue-dir' (mech (car (smtpmail-intersection smtpmail-auth-supported mechs))) (cred (if (stringp smtpmail-auth-credentials) (let* ((netrc (netrc-parse smtpmail-auth-credentials)) - (hostentry (netrc-machine - netrc host (format "%s" (or port "smtp")) - "smtp"))) + (port-name (format "%s" (or port "smtp"))) + (hostentry (netrc-machine netrc host port-name + port-name))) (when hostentry (list host port (netrc-get hostentry "login") ＠＠ -499,10 +523,10 ＠＠ This is relative to `smtpmail-queue-dir' (smtpmail-cred-server cred) (smtpmail-cred-port cred)))))) ret) - (when cred + (when (and cred mech) (cond ((eq mech 'cram-md5) - (smtpmail-send-command process (format "AUTH %s" mech)) + (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)) ＠＠ -535,6 +559,24 ＠＠ This is relative to `smtpmail-queue-dir' (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)))) + (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. ＠＠ -547,10 +589,12 ＠＠ This is relative to `smtpmail-queue-dir' (host (or smtpmail-smtp-server (error "`smtpmail-smtp-server' not defined"))) (port smtpmail-smtp-service) - (envelope-from (or (mail-envelope-from) - smtpmail-mail-address - ;; XEmacs: - (user-mail-address))) + ;; smtpmail-mail-address should be set to the appropriate + ;; buffer-local value by the caller, but in case not: + (envelope-from (or smtpmail-mail-address + (and mail-specify-envelope-from + (mail-envelope-from)) + (user-mail-address))) ;; XEmacs response-code greeting process-buffer ＠＠ -563,6 +607,7 ＠＠ This is relative to `smtpmail-queue-dir' ;; clear the trace buffer of old output (with-current-buffer process-buffer + (setq buffer-undo-list t) (erase-buffer)) ;; open the connection to the server ＠＠ -666,7 +711,7 ＠＠ This is relative to `smtpmail-queue-dir' (>= (car response-code) 400)) (throw 'done nil)))) - ;; MAIL FROM: <sender> + ;; MAIL FROM:<sender> (let ((size-part (if (or (member 'size supported-extensions) (assoc 'size supported-extensions)) ＠＠ -675,13 +720,8 ＠＠ This is relative to `smtpmail-queue-dir' ;; size estimate: (+ (- (point-max) (point-min)) ;; Add one byte for each change-of-line - ;; because or CR-LF representation: - (count-lines (point-min) (point-max)) - ;; For some reason, an empty line is - ;; added to the message. Maybe this - ;; is a bug, but it can't hurt to add - ;; those two bytes anyway: - 2))) + ;; because of CR-LF representation: + (count-lines (point-min) (point-max))))) "")) (body-part (if (member '8bitmime supported-extensions) ＠＠ -701,8 +741,8 ＠＠ This is relative to `smtpmail-queue-dir' "") ""))) ; (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 + (smtpmail-send-command process (format "MAIL FROM:<%s>%s%s" + envelope-from size-part body-part)) ＠＠ -712,10 +752,10 ＠＠ This is relative to `smtpmail-queue-dir' (throw 'done nil) )) - ;; RCPT TO: <recipient> + ;; RCPT TO:<recipient> (let ((n 0)) (while (not (null (nth n recipient))) - (smtpmail-send-command process (format "RCPT TO: <%s>" (smtpmail-maybe-append-domain (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)) ＠＠ -778,49 +818,49 ＠＠ This is relative to `smtpmail-queue-dir' (response-continue t) (return-value '(nil ())) match-end) + (catch 'done + (while response-continue + (goto-char smtpmail-read-point) + (while (not (search-forward "\r\n" nil t)) + (unless (memq (process-status process) '(open run)) + (throw 'done nil)) + (accept-process-output process) + (goto-char smtpmail-read-point)) - (while response-continue - (goto-char smtpmail-read-point) - (while (not (search-forward "\r\n" nil t)) - (accept-process-output process) - (goto-char smtpmail-read-point)) - - (setq match-end (point)) - (setq response-strings - (cons (buffer-substring smtpmail-read-point (- match-end 2)) - response-strings)) - - (goto-char smtpmail-read-point) - (if (looking-at "[0-9]+ ") - (let ((begin (match-beginning 0)) - (end (match-end 0))) - (if smtpmail-debug-info - (message "%s" (car response-strings))) - - (setq smtpmail-read-point match-end) - - ;; ignore lines that start with "0" - (if (looking-at "0[0-9]+ ") - nil + (setq match-end (point)) + (setq response-strings + (cons (buffer-substring smtpmail-read-point (- match-end 2)) + response-strings)) + + (goto-char smtpmail-read-point) + (if (looking-at "[0-9]+ ") + (let ((begin (match-beginning 0)) + (end (match-end 0))) + (if smtpmail-debug-info + (message "%s" (car response-strings))) + + (setq smtpmail-read-point match-end) + + ;; ignore lines that start with "0" + (if (looking-at "0[0-9]+ ") + nil + (setq response-continue nil) + (setq return-value + (cons (string-to-number + (buffer-substring begin end)) + (nreverse response-strings))))) + + (if (looking-at "[0-9]+-") + (progn (if smtpmail-debug-info + (message "%s" (car response-strings))) + (setq smtpmail-read-point match-end) + (setq response-continue t)) + (progn + (setq smtpmail-read-point match-end) (setq response-continue nil) (setq return-value - (cons (string-to-int - (buffer-substring begin end)) - (nreverse response-strings))))) - - (if (looking-at "[0-9]+-") - (progn (if smtpmail-debug-info - (message "%s" (car response-strings))) - (setq smtpmail-read-point match-end) - (setq response-continue t)) - (progn - (setq smtpmail-read-point match-end) - (setq response-continue nil) - (setq return-value - (cons nil (nreverse response-strings))) - ) - ))) - (setq smtpmail-read-point match-end) + (cons nil (nreverse response-strings))))))) + (setq smtpmail-read-point match-end)) return-value)) ＠＠ -853,31 +893,15 ＠＠ This is relative to `smtpmail-queue-dir' ) (defun smtpmail-send-data (process buffer) - (let - ((data-continue t) - (sending-data nil) - this-line - this-line-end) - + (let ((data-continue t) sending-data) (with-current-buffer buffer (goto-char (point-min))) - (while data-continue (with-current-buffer buffer - (beginning-of-line) - (setq this-line (point)) - (end-of-line) - (setq this-line-end (point)) - (setq sending-data nil) - (setq sending-data (buffer-substring this-line this-line-end)) - (if (/= (forward-line 1) 0) - (setq data-continue nil))) - - (smtpmail-send-data-1 process sending-data) - ) - ) - ) - + (setq sending-data (buffer-substring (point-at-bol) (point-at-eol))) + (end-of-line 2) + (setq data-continue (not (eobp)))) + (smtpmail-send-data-1 process sending-data)))) (defun smtpmail-deduce-address-list (smtpmail-text-buffer header-start header-end) "Get address list suitable for smtp RCPT TO: <address>." ＠＠ -955,4 +979,5 ＠＠ many continuation lines." (provide 'smtpmail) +;;; arch-tag: a76992df-6d71-43b7-9e72-4bacc6c05466 ;;; smtpmail.el ends here Index: starttls.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/mail-lib/starttls.el,v retrieving revision 1.4 retrieving revision 1.5 diff -u -p -r1.4 -r1.5 --- starttls.el 23 Sep 2005 13:01:15 -0000 1.4 +++ starttls.el 8 Mar 2006 09:59:10 -0000 1.5 ＠＠ -1,7 +1,7 ＠＠ ;;; starttls.el --- STARTTLS functions ;; Copyright (C) 1999, 2000, 2002, 2003, 2004, -;; 2005 Free Software Foundation, Inc. +;; 2005, 2006 Free Software Foundation, Inc. ;; Author: Daiki Ueno <ueno(a)unixuser.org&gt; ;; Author: Simon Josefsson <simon(a)josefsson.org&gt; ＠＠ -32,7 +32,7 ＠＠ ;; [RFC 2595] "Using TLS with IMAP, POP3 and ACAP" ;; by Chris Newman <chris.newman(a)innosoft.com&gt; (1999/06) -;; This file now contain a combination of the two previous +;; This file now contains a combination of the two previous ;; implementations both called "starttls.el". The first one is Daiki ;; Ueno's starttls.el which uses his own "starttls" command line tool, ;; and the second one is Simon Josefsson's starttls.el which uses ＠＠ -44,7 +44,7 ＠＠ ;; both tools installed. It is recommended to use GNUTLS, though, as ;; it performs more verification of the certificates. -;; The GNUTLS support require GNUTLS 0.9.90 (released 2003-10-08) or +;; The GNUTLS support requires GNUTLS 0.9.90 (released 2003-10-08) or ;; later, from <http://www.gnu.org/software/gnutls/>;, or "starttls" ;; from <ftp://ftp.opaopa.org/pub/elisp/>;. ＠＠ -58,7 +58,7 ＠＠ ;; (message "STARTTLS output:\n%s" (starttls-negotiate tmp)) ;; (process-send-string tmp "EHLO foo\n")) -;; An example run yield the following output: +;; An example run yields the following output: ;; ;; 220 yxa.extundo.com ESMTP Sendmail 8.12.11/8.12.11/Debian-3; Wed, 26 May 2004 19:12:29 +0200; (No UCE/UBE) logging access from: c494102a.s-bi.bostream.se(OK)-c494102a.s-bi.bostream.se [217.215.27.65] ;; 220 2.0.0 Ready to start TLS ＠＠ -144,15 +144,14 ＠＠ i.e. when `starttls-use-gnutls' is nil." (defcustom starttls-extra-args nil "Extra arguments to `starttls-program'. -This program is used when the `starttls' command is used, -i.e. when `starttls-use-gnutls' is nil." +These apply when the `starttls' command is used, i.e. when +`starttls-use-gnutls' is nil." :type '(repeat string) :group 'starttls) (defcustom starttls-extra-arguments nil "Extra arguments to `starttls-program'. -This program is used when GNUTLS is used, i.e. when -`starttls-use-gnutls' is non-nil. +These apply when GNUTLS is used, i.e. when `starttls-use-gnutls' is non-nil. For example, non-TLS compliant servers may require '(\"--protocols\" \"ssl3\"). Invoke \"gnutls-cli --help\" to ＠＠ -168,7 +167,7 ＠＠ find out which parameters are available. (defcustom starttls-connect "- Simple Client Mode:\n\n" "*Regular expression indicating successful connection. The default is what GNUTLS's \"gnutls-cli\" outputs." - ;; GNUTLS cli.c:main() print this string when it is starting to run + ;; GNUTLS cli.c:main() prints this string when it is starting to run ;; in the application read/write phase. If the logic, or the string ;; itself, is modified, this must be updated. :type 'regexp ＠＠ -177,7 +176,7 ＠＠ The default is what GNUTLS's \"gnutls-cl (defcustom starttls-failure "\\*\\*\\* Handshake has failed" "*Regular expression indicating failed TLS handshake. The default is what GNUTLS's \"gnutls-cli\" outputs." - ;; GNUTLS cli.c:do_handshake() print this string on failure. If the + ;; GNUTLS cli.c:do_handshake() prints this string on failure. If the ;; logic, or the string itself, is modified, this must be updated. :type 'regexp :group 'starttls) ＠＠ -193,10 +192,10 ＠＠ The default is what GNUTLS's \"gnutls-cl :group 'starttls) (defun starttls-negotiate-gnutls (process) - "Negotiate TLS on process opened by `open-starttls-stream'. -This should typically only be done once. It typically return a + "Negotiate TLS on PROCESS opened by `open-starttls-stream'. +This should typically only be done once. It typically returns a multi-line informational message with information about the -handshake, or NIL on failure." +handshake, or nil on failure." (let (buffer info old-max done-ok done-bad) (if (null (setq buffer (process-buffer process))) ;; XXX How to remove/extract the TLS negotiation junk? ＠＠ -236,16 +235,16 ＠＠ handshake, or NIL on failure." (defalias 'starttls-set-process-query-on-exit-flag 'process-kill-without-query))) -(defun starttls-open-stream-gnutls (name buffer host service) +(defun starttls-open-stream-gnutls (name buffer host port) (message "Opening STARTTLS connection to `%s'..." host) (let* (done (old-max (with-current-buffer buffer (point-max))) (process-connection-type starttls-process-connection-type) (process (apply #'start-process name buffer starttls-gnutls-program "-s" host - "-p" (if (integerp service) - (int-to-string service) - service) + "-p" (if (integerp port) + (int-to-string port) + port) starttls-extra-arguments))) (starttls-set-process-query-on-exit-flag process nil) (while (and (processp process) ＠＠ -266,11 +265,11 ＠＠ handshake, or NIL on failure." host (if done "done" "failed")) process)) -(defun starttls-open-stream (name buffer host service) - "Open a TLS connection for a service to a host. -Returns a subprocess-object to represent the connection. +(defun starttls-open-stream (name buffer host port) + "Open a TLS connection for a port to a host. +Returns a subprocess object to represent the connection. Input and output work as for subprocesses; `delete-process' closes it. -Args are NAME BUFFER HOST SERVICE. +Args are NAME BUFFER HOST PORT. NAME is name for process. It is modified if necessary to make it unique. BUFFER is the buffer (or `buffer-name') to associate with the process. Process output goes at end of that buffer, unless you specify ＠＠ -278,14 +277,15 ＠＠ BUFFER is the buffer (or `buffer-name') BUFFER may be also nil, meaning that this process is not associated with any buffer Third arg is name of the host to connect to, or its IP address. -Fourth arg SERVICE is name of the service desired, or an integer -specifying a port number to connect to." +Fourth arg PORT is an integer specifying a port to connect to. +If `starttls-use-gnutls' is nil, this may also be a service name, but +GNUTLS requires a port number." (if starttls-use-gnutls - (starttls-open-stream-gnutls name buffer host service) + (starttls-open-stream-gnutls name buffer host port) (let* ((process-connection-type starttls-process-connection-type) (process (apply #'start-process name buffer starttls-program - host (format "%s" service) + host (format "%s" port) starttls-extra-args))) (starttls-set-process-query-on-exit-flag process nil) process))) Index: tls.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/mail-lib/tls.el,v retrieving revision 1.2 retrieving revision 1.3 diff -u -p -r1.2 -r1.3 --- tls.el 16 Sep 2004 13:01:29 -0000 1.2 +++ tls.el 8 Mar 2006 10:00:35 -0000 1.3 ＠＠ -1,6 +1,7 ＠＠ ;;; tls.el --- TLS/SSL support via wrapper around GnuTLS -;; Copyright (C) 2003 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1998, 1999, 2002, 2003, 2004, +;; 2005, 2006 Free Software Foundation, Inc. ;; Author: Simon Josefsson <simon(a)josefsson.org&gt; ;; Keywords: comm, tls, gnutls, ssl ＠＠ -19,8 +20,8 ＠＠ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: ＠＠ -55,7 +56,8 ＠＠ :group 'comm) (defcustom tls-program '("gnutls-cli -p %p %h" - "gnutls-cli -p %p %h --protocols ssl3") + "gnutls-cli -p %p %h --protocols ssl3" + "openssl s_client -connect %h:%p -no_ssl2") "List of strings containing commands to start TLS stream to a host. Each entry in the list is tried until a connection is successful. %s is replaced with server hostname, %p with port to connect to. ＠＠ -70,17 +72,47 ＠＠ after successful negotiation." :type 'boolean :group 'tls) -(defcustom tls-success "- Handshake was completed" +(defcustom tls-success "- Handshake was completed\\|SSL handshake has read " "*Regular expression indicating completed TLS handshakes. -The default is what GNUTLS's \"gnutls-cli\" outputs." +The default is what GNUTLS's \"gnutls-cli\" or OpenSSL's +\"openssl s_client\" outputs." :type 'regexp :group 'tls) -(defun open-tls-stream (name buffer host service) - "Open a TLS connection for a service to a host. +(defcustom tls-certtool-program (executable-find "certtool") + "Name of GnuTLS certtool. +Used by `tls-certificate-information'." +:type '(repeat string) +:group 'tls) + +(defun tls-certificate-information (der) + "Parse X.509 certificate in DER format into an assoc list." + (let ((certificate (concat "-----BEGIN CERTIFICATE-----\n" + (base64-encode-string der) + "\n-----END CERTIFICATE-----\n")) + (exit-code 0)) + (with-current-buffer (get-buffer-create " *certtool*") + (erase-buffer) + (insert certificate) + (setq exit-code (condition-case () + (call-process-region (point-min) (point-max) + tls-certtool-program + t (list (current-buffer) nil) t + "--certificate-info") + (error -1))) + (if (/= exit-code 0) + nil + (let ((vals nil)) + (goto-char (point-min)) + (while (re-search-forward "^\\([^:]+\\): \\(.*\\)" nil t) + (push (cons (match-string 1) (match-string 2)) vals)) + (nreverse vals)))))) + +(defun open-tls-stream (name buffer host port) + "Open a TLS connection for a port to a host. Returns a subprocess-object to represent the connection. Input and output work as for subprocesses; `delete-process' closes it. -Args are NAME BUFFER HOST SERVICE. +Args are NAME BUFFER HOST PORT. NAME is name for process. It is modified if necessary to make it unique. BUFFER is the buffer (or buffer-name) to associate with the process. Process output goes at end of that buffer, unless you specify ＠＠ -88,8 +120,7 ＠＠ BUFFER is the buffer (or buffer-name) to BUFFER may be also nil, meaning that this process is not associated with any buffer Third arg is name of the host to connect to, or its IP address. -Fourth arg SERVICE is name of the service desired, or an integer -specifying a port number to connect to." +Fourth arg PORT is an integer specifying a port to connect to." (let ((cmds tls-program) cmd done) (message "Opening TLS connection to `%s'..." host) (while (and (not done) (setq cmd (pop cmds))) ＠＠ -101,9 +132,9 ＠＠ specifying a port number to connect to." cmd (format-spec-make ?h host - ?p (if (integerp service) - (int-to-string service) - service))))) + ?p (if (integerp port) + (int-to-string port) + port))))) response) (while (and process (memq (process-status process) '(open run))