[Emacs-diffs] Changes to emacs/lisp/gnus/starttls.el

[Simon Josefsson]

Index: emacs/lisp/gnus/starttls.el
diff -c emacs/lisp/gnus/starttls.el:1.3 emacs/lisp/gnus/starttls.el:1.4
*** emacs/lisp/gnus/starttls.el:1.3     Mon Sep  1 15:45:28 2003
--- emacs/lisp/gnus/starttls.el Fri May 28 05:27:52 2004
***************
*** 1,10 ****
  ;;; starttls.el --- STARTTLS functions
  
! ;; Copyright (C) 1999, 2000 Free Software Foundation, Inc.
  
  ;; Author: Daiki Ueno <address@hidden>
  ;; Created: 1999/11/20
! ;; Keywords: TLS, SSL, OpenSSL, mail, news
  
  ;; This file is part of GNU Emacs.
  
--- 1,11 ----
  ;;; starttls.el --- STARTTLS functions
  
! ;; Copyright (C) 1999, 2000, 2003, 2004 Free Software Foundation, Inc.
  
  ;; Author: Daiki Ueno <address@hidden>
+ ;; Author: Simon Josefsson <address@hidden>
  ;; Created: 1999/11/20
! ;; Keywords: TLS, SSL, OpenSSL, GNUTLS, mail, news
  
  ;; This file is part of GNU Emacs.
  
***************
*** 30,35 ****
--- 31,120 ----
  ;; [RFC 2595] "Using TLS with IMAP, POP3 and ACAP"
  ;;    by Chris Newman <address@hidden> (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,address@hidden
+ ;; - 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,address@hidden
+ ;;  # Issuer's DN: 
C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,address@hidden
+ ;;
+ ;;  - 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,address@hidden
+ ;;  # Issuer's DN: 
C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,address@hidden
+ ;;
+ ;; - 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,54 ****
    :version "21.1"
    :group 'mail)
  
  (defcustom starttls-program "starttls"
!   "The program to run in a subprocess to open an TLSv1 connection."
    :type 'string
    :group 'starttls)
  
  (defcustom starttls-extra-args nil
!   "Extra arguments to `starttls-program'."
    :type '(repeat string)
    :group 'starttls)
  
  (defun starttls-negotiate (process)
!   (signal-process (process-id process) 'SIGALRM))
  
  (defun starttls-open-stream (name buffer host service)
    "Open a TLS connection for a service to a host.
--- 122,262 ----
    :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.
! 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'.
! 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)
!   (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,76 ****
  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))
  
  (provide 'starttls)
  
--- 272,286 ----
  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."
!   (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)