1 ;;; starttls.el --- STARTTLS support via wrapper around GNU TLS
3 ;; Copyright (C) 2003, 2004 Free Software Foundation, Inc.
5 ;; Author: Simon Josefsson <simon@josefsson.org>
6 ;; Keywords: comm, tls, gnutls, ssl
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
27 ;; This package implements a simple wrapper around the GNU TLS command
28 ;; line application "gnutls-cli" to make Emacs support STARTTLS. It
29 ;; is backwards compatible (same API functions) with the "starttls.el"
30 ;; that is part of Emacs 21 written by Daiki Ueno <ueno@unixuser.org>.
31 ;; (That version used an external program "starttls" that isn't widely
32 ;; installed, and was based on OpenSSL.)
34 ;; This package require GNUTLS 0.9.90 (released 2003-10-08) or later.
36 ;; Usage is similar to `open-network-stream'. Evaluating the following:
39 ;; (setq tmp (open-starttls-stream "test" (current-buffer) "mail.example.com" 143))
40 ;; (process-send-string tmp ". starttls\n")
42 ;; (message "STARTTLS output:\n%s" (negotiate-starttls tmp))
43 ;; (process-send-string tmp ". capability\n"))
45 ;; in, e.g., the *scratch* buffer, yields the following output:
47 ;; * OK imap.example.com Cyrus IMAP4 v2.1.15 server ready
\r
48 ;; . OK Begin TLS negotiation now
\r
49 ;; * CAPABILITY IMAP4 IMAP4rev1 ACL QUOTA ...
53 ;; And the message buffer contains:
56 ;; *** Starting TLS handshake
57 ;; - Server's trusted authorities:
58 ;; [0]: O=Sendmail,OU=Sendmail Server,CN=imap.example.com,EMAIL=admin@imap.example.com
59 ;; - Certificate type: X.509
60 ;; - Got a certificate list of 1 certificates.
62 ;; - Certificate[0] info:
63 ;; # The hostname in the certificate matches 'imap.example.com'.
64 ;; # valid since: Wed Aug 28 12:47:00 CEST 2002
65 ;; # expires at: Thu Aug 28 12:47:00 CEST 2003
66 ;; # serial number: 00
67 ;; # fingerprint: 06 3f 25 cb 44 aa 5c 1e 79 d7 63 86 f8 b1 9a cf
69 ;; # public key algorithm: RSA
70 ;; # Modulus: 1024 bits
71 ;; # Subject's DN: O=Sendmail,OU=Sendmail Server,CN=imap.example.com,EMAIL=admin@imap.example.com
72 ;; # Issuer's DN: O=Sendmail,OU=Sendmail Server,CN=imap.example.com,EMAIL=admin@imap.example.com
75 ;; - Peer's certificate issuer is unknown
76 ;; - Peer's certificate is NOT trusted
78 ;; - Key Exchange: RSA
79 ;; - Cipher: ARCFOUR 128
81 ;; - Compression: NULL
85 ;; 2003-09-20: Added to Gnus CVS.
86 ;; 2003-10-02: Minor fixes.
87 ;; 2003-11-15: Cleanup, and posted to gnu.emacs.sources.
88 ;; 2003-11-28: Fixes variable name conflicts, various other fixes, posted g.e.s.
92 (defgroup starttls nil
93 "Negotiated Transport Layer Security (STARTTLS) parameters."
96 (defcustom starttls-file-name "gnutls-cli"
97 "Name of the program to run in a subprocess to open an STARTTLS connection.
98 The program should read input on stdin, write output to stdout,
99 and initiate TLS negotiation when receiving the SIGALRM signal.
100 Also see `starttls-connect', `starttls-failure', and
101 `starttls-success' for what the program should output after
102 initial connection and successful negotiation respectively."
106 (defcustom starttls-extra-arguments nil
107 "List of extra arguments to `starttls-file-name'.
108 E.g., (\"--protocols\" \"ssl3\")."
109 :type '(repeat string)
112 (defcustom starttls-process-connection-type nil
113 "*Value for `process-connection-type' to use when starting STARTTLS process."
117 (defcustom starttls-connect "- Simple Client Mode:\n\n"
118 "*Regular expression indicating successful connection.
119 The default is what GNUTLS's \"gnutls-cli\" outputs."
120 ;; GNUTLS cli.c:main() print this string when it is starting to run
121 ;; in the application read/write phase. If the logic, or the string
122 ;; itself, is modified, this must be updated.
126 (defcustom starttls-failure "\\*\\*\\* Handshake has failed"
127 "*Regular expression indicating failed TLS handshake.
128 The default is what GNUTLS's \"gnutls-cli\" outputs."
129 ;; GNUTLS cli.c:do_handshake() print this string on failure. If the
130 ;; logic, or the string itself, is modified, this must be updated.
134 (defcustom starttls-success "- Compression: "
135 "*Regular expression indicating completed TLS handshakes.
136 The default is what GNUTLS's \"gnutls-cli\" outputs."
137 ;; GNUTLS cli.c:do_handshake() calls, on success,
138 ;; common.c:print_info(), that unconditionally print this string
139 ;; last. If that logic, or the string itself, is modified, this
144 (defun negotiate-starttls (process)
145 "Negotiate TLS on process opened by `open-starttls-stream'.
146 This should typically only be done once. It typically return a
147 multi-line informational message with information about the
148 handshake, or NIL on failure."
149 (let (buffer info old-max done-ok done-bad)
150 (if (null (setq buffer (process-buffer process)))
151 ;; XXX How to remove/extract the TLS negotiation junk?
152 (signal-process (process-id process) 'SIGALRM)
153 (with-current-buffer buffer
155 (setq old-max (goto-char (point-max)))
156 (signal-process (process-id process) 'SIGALRM)
157 (while (and (processp process)
158 (eq (process-status process) 'run)
161 (not (or (setq done-ok (re-search-forward
162 starttls-success nil t))
163 (setq done-bad (re-search-forward
164 starttls-failure nil t))))))
165 (accept-process-output process 1 100)
167 (setq info (buffer-substring-no-properties old-max (point-max)))
168 (delete-region old-max (point-max))
169 (if (or (and done-ok (not done-bad))
170 ;; Prevent mitm that fake success msg after failure msg.
171 (and done-ok done-bad (< done-ok done-bad)))
173 (message "STARTTLS negotiation failed: %s" info)
176 (defun open-starttls-stream (name buffer host service)
177 "Open a TLS connection for a service to a host.
178 Returns a subprocess-object to represent the connection.
179 Input and output work as for subprocesses; `delete-process' closes it.
180 Args are NAME BUFFER HOST SERVICE.
181 NAME is name for process. It is modified if necessary to make it unique.
182 BUFFER is the buffer (or buffer-name) to associate with the process.
183 Process output goes at end of that buffer, unless you specify
184 an output stream or filter function to handle the output.
185 Third arg is name of the host to connect to, or its IP address.
186 Fourth arg SERVICE is name of the service desired, or an integer
187 specifying a port number to connect to."
188 (message "Opening STARTTLS connection to `%s'..." host)
190 (old-max (with-current-buffer buffer (point-max)))
191 (process-connection-type starttls-process-connection-type)
192 (process (apply #'start-process name buffer
193 starttls-file-name "-s" host
194 "-p" (if (integerp service)
195 (int-to-string service)
197 starttls-extra-arguments)))
198 (process-kill-without-query process)
199 (while (and (processp process)
200 (eq (process-status process) 'run)
204 (not (setq done (re-search-forward
205 starttls-connect nil t)))))
206 (accept-process-output process 0 100)
209 (with-current-buffer buffer
210 (delete-region old-max done))
211 (delete-process process)
213 (message "Opening STARTTLS connection to `%s'...%s"
214 host (if done "done" "failed"))
217 ;; Compatibility with starttls.el by Daiki Ueno <ueno@unixuser.org>:
218 (defvaralias 'starttls-program 'starttls-file-name)
219 (make-obsolete-variable 'starttls-program 'starttls-file-name)
220 (defvaralias 'starttls-extra-args 'starttls-extra-arguments)
221 (make-obsolete-variable 'starttls-extra-args 'starttls-extra-arguments)
222 (defalias 'starttls-open-stream 'open-starttls-stream)
223 (defalias 'starttls-negotiate 'negotiate-starttls)
227 ;;; starttls.el ends here