1 ;;; starttls.el --- STARTTLS functions
3 ;; Copyright (C) 1999, 2000, 2003, 2004, 2005
4 ;; Free Software Foundation, Inc.
6 ;; Author: Daiki Ueno <ueno@unixuser.org>
7 ;; Author: Simon Josefsson <simon@josefsson.org>
9 ;; Keywords: TLS, SSL, OpenSSL, GNUTLS, mail, news
11 ;; This file is part of GNU Emacs.
13 ;; GNU Emacs is free software; you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation; either version 2, or (at your option)
18 ;; GNU Emacs is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;; GNU General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with GNU Emacs; see the file COPYING. If not, write to the
25 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26 ;; Boston, MA 02111-1307, USA.
30 ;; This module defines some utility functions for STARTTLS profiles.
32 ;; [RFC 2595] "Using TLS with IMAP, POP3 and ACAP"
33 ;; by Chris Newman <chris.newman@innosoft.com> (1999/06)
35 ;; This file now contain a combination of the two previous
36 ;; implementations both called "starttls.el". The first one is Daiki
37 ;; Ueno's starttls.el which uses his own "starttls" command line tool,
38 ;; and the second one is Simon Josefsson's starttls.el which uses
39 ;; "gnutls-cli" from GNUTLS.
41 ;; If "starttls" is available, it is prefered by the code over
42 ;; "gnutls-cli", for backwards compatibility. Use
43 ;; `starttls-use-gnutls' to toggle between implementations if you have
44 ;; both tools installed. It is recommended to use GNUTLS, though, as
45 ;; it performs more verification of the certificates.
47 ;; The GNUTLS support require GNUTLS 0.9.90 (released 2003-10-08) or
48 ;; later, from <http://www.gnu.org/software/gnutls/>, or "starttls"
49 ;; from <ftp://ftp.opaopa.org/pub/elisp/>.
51 ;; Usage is similar to `open-network-stream'. For example:
53 ;; (when (setq tmp (starttls-open-stream
54 ;; "test" (current-buffer) "yxa.extundo.com" 25))
55 ;; (accept-process-output tmp 15)
56 ;; (process-send-string tmp "STARTTLS\n")
57 ;; (accept-process-output tmp 15)
58 ;; (message "STARTTLS output:\n%s" (starttls-negotiate tmp))
59 ;; (process-send-string tmp "EHLO foo\n"))
61 ;; An example run yield the following output:
63 ;; 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]
64 ;; 220 2.0.0 Ready to start TLS
65 ;; 250-yxa.extundo.com Hello c494102a.s-bi.bostream.se [217.215.27.65], pleased to meet you
66 ;; 250-ENHANCEDSTATUSCODES
74 ;; 250-AUTH DIGEST-MD5 CRAM-MD5 PLAIN LOGIN
79 ;; With the message buffer containing:
82 ;; *** Starting TLS handshake
83 ;; - Server's trusted authorities:
84 ;; [0]: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
85 ;; - Certificate type: X.509
86 ;; - Got a certificate list of 2 certificates.
88 ;; - Certificate[0] info:
89 ;; # The hostname in the certificate matches 'yxa.extundo.com'.
90 ;; # valid since: Wed May 26 12:16:00 CEST 2004
91 ;; # expires at: Wed Jul 26 12:16:00 CEST 2023
92 ;; # serial number: 04
93 ;; # fingerprint: 7c 04 4b c1 fa 26 9b 5d 90 22 52 3c 65 3d 85 3a
95 ;; # public key algorithm: RSA
96 ;; # Modulus: 1024 bits
97 ;; # Subject's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=Mail server,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
98 ;; # Issuer's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
100 ;; - Certificate[1] info:
101 ;; # valid since: Sun May 23 11:35:00 CEST 2004
102 ;; # expires at: Sun Jul 23 11:35:00 CEST 2023
103 ;; # serial number: 00
104 ;; # fingerprint: fc 76 d8 63 1a c9 0b 3b fa 40 fe ed 47 7a 58 ae
106 ;; # public key algorithm: RSA
107 ;; # Modulus: 1024 bits
108 ;; # Subject's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
109 ;; # Issuer's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
111 ;; - Peer's certificate issuer is unknown
112 ;; - Peer's certificate is NOT trusted
113 ;; - Version: TLS 1.0
114 ;; - Key Exchange: RSA
115 ;; - Cipher: ARCFOUR 128
117 ;; - Compression: NULL
121 (defgroup starttls nil
122 "Support for `Transport Layer Security' protocol."
126 (defcustom starttls-gnutls-program "gnutls-cli"
127 "Name of GNUTLS command line tool.
128 This program is used when GNUTLS is used, i.e. when
129 `starttls-use-gnutls' is non-nil."
134 (defcustom starttls-program "starttls"
135 "The program to run in a subprocess to open an TLSv1 connection.
136 This program is used when the `starttls' command is used,
137 i.e. when `starttls-use-gnutls' is nil."
141 (defcustom starttls-use-gnutls (not (executable-find starttls-program))
142 "*Whether to use GNUTLS instead of the `starttls' command."
147 (defcustom starttls-extra-args nil
148 "Extra arguments to `starttls-program'.
149 This program is used when the `starttls' command is used,
150 i.e. when `starttls-use-gnutls' is nil."
151 :type '(repeat string)
154 (defcustom starttls-extra-arguments nil
155 "Extra arguments to `starttls-program'.
156 This program is used when GNUTLS is used, i.e. when
157 `starttls-use-gnutls' is non-nil.
159 For example, non-TLS compliant servers may require
160 '(\"--protocols\" \"ssl3\"). Invoke \"gnutls-cli --help\" to
161 find out which parameters are available."
163 :type '(repeat string)
166 (defcustom starttls-process-connection-type nil
167 "*Value for `process-connection-type' to use when starting STARTTLS process."
172 (defcustom starttls-connect "- Simple Client Mode:\n\n"
173 "*Regular expression indicating successful connection.
174 The default is what GNUTLS's \"gnutls-cli\" outputs."
175 ;; GNUTLS cli.c:main() print this string when it is starting to run
176 ;; in the application read/write phase. If the logic, or the string
177 ;; itself, is modified, this must be updated.
182 (defcustom starttls-failure "\\*\\*\\* Handshake has failed"
183 "*Regular expression indicating failed TLS handshake.
184 The default is what GNUTLS's \"gnutls-cli\" outputs."
185 ;; GNUTLS cli.c:do_handshake() print this string on failure. If the
186 ;; logic, or the string itself, is modified, this must be updated.
191 (defcustom starttls-success "- Compression: "
192 "*Regular expression indicating completed TLS handshakes.
193 The default is what GNUTLS's \"gnutls-cli\" outputs."
194 ;; GNUTLS cli.c:do_handshake() calls, on success,
195 ;; common.c:print_info(), that unconditionally print this string
196 ;; last. If that logic, or the string itself, is modified, this
202 (defun starttls-negotiate-gnutls (process)
203 "Negotiate TLS on process opened by `open-starttls-stream'.
204 This should typically only be done once. It typically return a
205 multi-line informational message with information about the
206 handshake, or NIL on failure."
207 (let (buffer info old-max done-ok done-bad)
208 (if (null (setq buffer (process-buffer process)))
209 ;; XXX How to remove/extract the TLS negotiation junk?
210 (signal-process (process-id process) 'SIGALRM)
211 (with-current-buffer buffer
213 (setq old-max (goto-char (point-max)))
214 (signal-process (process-id process) 'SIGALRM)
215 (while (and (processp process)
216 (eq (process-status process) 'run)
219 (not (or (setq done-ok (re-search-forward
220 starttls-success nil t))
221 (setq done-bad (re-search-forward
222 starttls-failure nil t))))))
223 (accept-process-output process 1 100)
225 (setq info (buffer-substring-no-properties old-max (point-max)))
226 (delete-region old-max (point-max))
227 (if (or (and done-ok (not done-bad))
228 ;; Prevent mitm that fake success msg after failure msg.
229 (and done-ok done-bad (< done-ok done-bad)))
231 (message "STARTTLS negotiation failed: %s" info)
234 (defun starttls-negotiate (process)
235 (if starttls-use-gnutls
236 (starttls-negotiate-gnutls process)
237 (signal-process (process-id process) 'SIGALRM)))
239 (defun starttls-set-process-query-on-exit-flag (process flag)
240 "Run `set-process-query-on-exit-flag' if it is available.
241 Otherwise, run `process-kill-without-query'."
242 (let ((fn (if (fboundp 'set-process-query-on-exit-flag)
243 'set-process-query-on-exit-flag
244 'process-kill-without-query)))
245 (funcall fn process flag)))
247 (defun starttls-open-stream-gnutls (name buffer host service)
248 (message "Opening STARTTLS connection to `%s'..." host)
250 (old-max (with-current-buffer buffer (point-max)))
251 (process-connection-type starttls-process-connection-type)
252 (process (apply #'start-process name buffer
253 starttls-gnutls-program "-s" host
254 "-p" (if (integerp service)
255 (int-to-string service)
257 starttls-extra-arguments)))
258 (starttls-set-process-query-on-exit-flag process nil)
259 (while (and (processp process)
260 (eq (process-status process) 'run)
264 (not (setq done (re-search-forward
265 starttls-connect nil t)))))
266 (accept-process-output process 0 100)
269 (with-current-buffer buffer
270 (delete-region old-max done))
271 (delete-process process)
273 (message "Opening STARTTLS connection to `%s'...%s"
274 host (if done "done" "failed"))
277 (defun starttls-open-stream (name buffer host service)
278 "Open a TLS connection for a service to a host.
279 Returns a subprocess-object to represent the connection.
280 Input and output work as for subprocesses; `delete-process' closes it.
281 Args are NAME BUFFER HOST SERVICE.
282 NAME is name for process. It is modified if necessary to make it unique.
283 BUFFER is the buffer (or `buffer-name') to associate with the process.
284 Process output goes at end of that buffer, unless you specify
285 an output stream or filter function to handle the output.
286 BUFFER may be also nil, meaning that this process is not associated
288 Third arg is name of the host to connect to, or its IP address.
289 Fourth arg SERVICE is name of the service desired, or an integer
290 specifying a port number to connect to."
291 (if starttls-use-gnutls
292 (starttls-open-stream-gnutls name buffer host service)
293 (let* ((process-connection-type starttls-process-connection-type)
294 (process (apply #'start-process
295 name buffer starttls-program
296 host (format "%s" service)
297 starttls-extra-args)))
298 (starttls-set-process-query-on-exit-flag process nil)
301 (defun starttls-open-ssl-stream (name buffer host service)
302 (let ((starttls-extra-args (cons "--force" starttls-extra-args)))
303 (starttls-open-stream name buffer host service)))
307 ;;; starttls.el ends here