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