changeset 55783:cbd20e241bd5

starttls.el: Merge with my GNUTLS based starttls.el. (starttls-gnutls-program, starttls-use-gnutls) (starttls-extra-arguments, starttls-process-connection-type) (starttls-connect, starttls-failure, starttls-success): New variables. (starttls-program, starttls-extra-args): Doc fix. (starttls-negotiate-gnutls, starttls-open-stream-gnutls): New functions. (starttls-negotiate, starttls-open-stream): Check `starttls-use-gnutls' and pass on to corresponding *-gnutls function if it is set.

--- a/lisp/gnus/starttls.el	Fri May 28 01:55:45 2004 +0000
+++ b/lisp/gnus/starttls.el	Fri May 28 05:27:52 2004 +0000
@@ -1,10 +1,11 @@
 ;;; starttls.el --- STARTTLS functions
 
-;; Copyright (C) 1999, 2000 Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2000, 2003, 2004 Free Software Foundation, Inc.
 
 ;; Author: Daiki Ueno <[e-mail]>
+;; Author: Simon Josefsson <[e-mail]>
 ;; Created: 1999/11/20
-;; Keywords: TLS, SSL, OpenSSL, mail, news
+;; Keywords: TLS, SSL, OpenSSL, GNUTLS, mail, news
 
 ;; This file is part of GNU Emacs.
 
@@ -30,6 +31,90 @@
 ;; [RFC 2595] "Using TLS with IMAP, POP3 and ACAP"
 ;;	by Chris Newman <[e-mail]> (1999/06)
 
+;; This file now contain 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
+;; "gnutls-cli" from GNUTLS.
+;;
+;; If "starttls" is available, it is prefered by the code over
+;; "gnutls-cli", for backwards compatibility.  Use
+;; `starttls-use-gnutls' to toggle between implementations if you have
+;; 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
+;; later, from <http://www.gnu.org/software/gnutls/>, or "starttls"
+;; from <ftp://ftp.opaopa.org/pub/elisp/>.
+
+;; Usage is similar to `open-network-stream'.  For example:
+;;
+;; (when (setq tmp (starttls-open-stream
+;;			"test" (current-buffer) "yxa.extundo.com" 25))
+;;   (accept-process-output tmp 15)
+;;   (process-send-string tmp "STARTTLS\n")
+;;   (accept-process-output tmp 15)
+;;   (message "STARTTLS output:\n%s" (starttls-negotiate tmp))
+;;   (process-send-string tmp "EHLO foo\n"))
+
+;; An example run yield 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
+;; 250-yxa.extundo.com Hello c494102a.s-bi.bostream.se [217.215.27.65], pleased to meet you
+;; 250-ENHANCEDSTATUSCODES
+;; 250-PIPELINING
+;; 250-EXPN
+;; 250-VERB
+;; 250-8BITMIME
+;; 250-SIZE
+;; 250-DSN
+;; 250-ETRN
+;; 250-AUTH DIGEST-MD5 CRAM-MD5 PLAIN LOGIN
+;; 250-DELIVERBY
+;; 250 HELP
+;; nil
+;;
+;; With the message buffer containing:
+;;
+;; STARTTLS output:
+;; *** Starting TLS handshake
+;; - Server's trusted authorities:
+;;    [0]: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=[e-mail]
+;; - Certificate type: X.509
+;;  - Got a certificate list of 2 certificates.
+;;
+;;  - Certificate[0] info:
+;;  # The hostname in the certificate matches 'yxa.extundo.com'.
+;;  # valid since: Wed May 26 12:16:00 CEST 2004
+;;  # expires at: Wed Jul 26 12:16:00 CEST 2023
+;;  # serial number: 04
+;;  # fingerprint: 7c 04 4b c1 fa 26 9b 5d 90 22 52 3c 65 3d 85 3a
+;;  # version: #1
+;;  # public key algorithm: RSA
+;;  #   Modulus: 1024 bits
+;;  # Subject's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=Mail server,CN=yxa.extundo.com,EMAIL=[e-mail]
+;;  # Issuer's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=[e-mail]
+;;
+;;  - Certificate[1] info:
+;;  # valid since: Sun May 23 11:35:00 CEST 2004
+;;  # expires at: Sun Jul 23 11:35:00 CEST 2023
+;;  # serial number: 00
+;;  # fingerprint: fc 76 d8 63 1a c9 0b 3b fa 40 fe ed 47 7a 58 ae
+;;  # version: #3
+;;  # public key algorithm: RSA
+;;  #   Modulus: 1024 bits
+;;  # Subject's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=[e-mail]
+;;  # Issuer's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=[e-mail]
+;;
+;; - Peer's certificate issuer is unknown
+;; - Peer's certificate is NOT trusted
+;; - Version: TLS 1.0
+;; - Key Exchange: RSA
+;; - Cipher: ARCFOUR 128
+;; - MAC: SHA
+;; - Compression: NULL
+
 ;;; Code:
 
 (defgroup starttls nil
@@ -37,18 +122,141 @@
   :version "21.1"
   :group 'mail)
 
+(defcustom starttls-gnutls-program "gnutls-cli"
+  "Name of GNUTLS command line tool.
+This program is used when GNUTLS is used, i.e. when
+`starttls-use-gnutls' is non-nil."
+  :type 'string
+  :group 'starttls)
+
 (defcustom starttls-program "starttls"
-  "The program to run in a subprocess to open an TLSv1 connection."
+  "The program to run in a subprocess to open an TLSv1 connection.
+This program is used when the `starttls' command is used,
+i.e. when `starttls-use-gnutls' is nil."
   :type 'string
   :group 'starttls)
 
+(defcustom starttls-use-gnutls (not (executable-find starttls-program))
+  "*Whether to use GNUTLS instead of the `starttls' command."
+  :type 'boolean
+  :group 'starttls)
+
 (defcustom starttls-extra-args nil
-  "Extra arguments to `starttls-program'."
+  "Extra arguments to `starttls-program'.
+This program is used 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.
+
+For example, non-TLS compliant servers may require
+'(\"--protocols\" \"ssl3\").  Invoke \"gnutls-cli --help\" to
+find out which parameters are available."
   :type '(repeat string)
   :group 'starttls)
 
+(defcustom starttls-process-connection-type nil
+  "*Value for `process-connection-type' to use when starting STARTTLS process."
+  :type 'boolean
+  :group 'starttls)
+
+(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
+  ;; in the application read/write phase.  If the logic, or the string
+  ;; itself, is modified, this must be updated.
+  :type 'regexp
+  :group 'starttls)
+
+(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
+  ;; logic, or the string itself, is modified, this must be updated.
+  :type 'regexp
+  :group 'starttls)
+
+(defcustom starttls-success "- Compression: "
+  "*Regular expression indicating completed TLS handshakes.
+The default is what GNUTLS's \"gnutls-cli\" outputs."
+  ;; GNUTLS cli.c:do_handshake() calls, on success,
+  ;; common.c:print_info(), that unconditionally print this string
+  ;; last.  If that logic, or the string itself, is modified, this
+  ;; must be updated.
+  :type 'regexp
+  :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
+multi-line informational message with information about the
+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?
+	(signal-process (process-id process) 'SIGALRM)
+      (with-current-buffer buffer
+	(save-excursion
+	  (setq old-max (goto-char (point-max)))
+	  (signal-process (process-id process) 'SIGALRM)
+	  (while (and (processp process)
+		      (eq (process-status process) 'run)
+		      (save-excursion
+			(goto-char old-max)
+			(not (or (setq done-ok (re-search-forward
+						starttls-success nil t))
+				 (setq done-bad (re-search-forward
+						 starttls-failure nil t))))))
+	    (accept-process-output process 1 100)
+	    (sit-for 0.1))
+	  (setq info (buffer-substring-no-properties old-max (point-max)))
+	  (delete-region old-max (point-max))
+	  (if (or (and done-ok (not done-bad))
+		  ;; Prevent mitm that fake success msg after failure msg.
+		  (and done-ok done-bad (< done-ok done-bad)))
+	      info
+	    (message "STARTTLS negotiation failed: %s" info)
+	    nil))))))
+
 (defun starttls-negotiate (process)
-  (signal-process (process-id process) 'SIGALRM))
+  (if starttls-use-gnutls
+      (starttls-negotiate-gnutls process)
+    (signal-process (process-id process) 'SIGALRM)))
+
+(defun starttls-open-stream-gnutls (name buffer host service)
+  (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)
+			 starttls-extra-arguments)))
+    (process-kill-without-query process)
+    (while (and (processp process)
+		(eq (process-status process) 'run)
+		(save-excursion
+		  (set-buffer buffer)
+		  (goto-char old-max)
+		  (not (setq done (re-search-forward
+				   starttls-connect nil t)))))
+      (accept-process-output process 0 100)
+      (sit-for 0.1))
+    (if done
+	(with-current-buffer buffer
+	  (delete-region old-max done))
+      (delete-process process)
+      (setq process nil))
+    (message "Opening STARTTLS connection to `%s'...%s"
+	     host (if done "done" "failed"))
+    process))
 
 (defun starttls-open-stream (name buffer host service)
   "Open a TLS connection for a service to a host.
@@ -64,13 +272,15 @@
 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."
-  (let* ((process-connection-type nil)
-	 (process (apply #'start-process
-			 name buffer starttls-program
-			 host (format "%s" service)
-			 starttls-extra-args)))
-    (process-kill-without-query process)
-    process))
+  (if starttls-use-gnutls
+      (starttls-open-stream-gnutls name buffer host service)
+    (let* ((process-connection-type starttls-process-connection-type)
+	   (process (apply #'start-process
+			   name buffer starttls-program
+			   host (format "%s" service)
+			   starttls-extra-args)))
+      (process-kill-without-query process)
+      process)))
 
 (provide 'starttls)