1 ;;; starttls.el --- STARTTLS support via wrapper around GNU TLS
3 ;; Copyright (C) 2003 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 (that version used an external program
31 ;; "starttls" that isn't widely installed, and was based on OpenSSL).
33 ;; This package require GNUTLS 0.9.90 (released 2003-10-08) or later.
35 ;; Usage is similar to `open-network-stream'. Evaluating the following:
38 ;; (setq tmp (open-starttls-stream "test" (current-buffer) "mail.example.com" 143))
39 ;; (process-send-string tmp ". starttls\n")
41 ;; (message "STARTTLS output:\n%s" (negotiate-starttls tmp))
42 ;; (process-send-string tmp ". capability\n"))
44 ;; in, e.g., the *scratch* buffer, yields the following output:
46 ;; * OK imap.example.com Cyrus IMAP4 v2.1.15 server ready
\r
47 ;; . OK Begin TLS negotiation now
\r
48 ;; * CAPABILITY IMAP4 IMAP4rev1 ACL QUOTA ...
52 ;; And the message buffer contains:
55 ;; *** Starting TLS handshake
56 ;; - Server's trusted authorities:
57 ;; [0]: O=Sendmail,OU=Sendmail Server,CN=imap.example.com,EMAIL=admin@imap.example.com
58 ;; - Certificate type: X.509
59 ;; - Got a certificate list of 1 certificates.
61 ;; - Certificate[0] info:
62 ;; # The hostname in the certificate matches 'imap.example.com'.
63 ;; # valid since: Wed Aug 28 12:47:00 CEST 2002
64 ;; # expires at: Thu Aug 28 12:47:00 CEST 2003
65 ;; # serial number: 00
66 ;; # fingerprint: 06 3f 25 cb 44 aa 5c 1e 79 d7 63 86 f8 b1 9a cf
68 ;; # public key algorithm: RSA
69 ;; # Modulus: 1024 bits
70 ;; # Subject's DN: O=Sendmail,OU=Sendmail Server,CN=imap.example.com,EMAIL=admin@imap.example.com
71 ;; # Issuer's DN: O=Sendmail,OU=Sendmail Server,CN=imap.example.com,EMAIL=admin@imap.example.com
74 ;; - Peer's certificate issuer is unknown
75 ;; - Peer's certificate is NOT trusted
77 ;; - Key Exchange: RSA
78 ;; - Cipher: ARCFOUR 128
80 ;; - Compression: NULL
84 ;; 2003-11-15: cleanup, and posted to gnu.emacs.sources.
88 (defgroup starttls nil
89 "Negotiated Transport Layer Security (STARTTLS) parameters."
92 (defcustom starttls-file-name "gnutls-cli"
93 "Name of the program to run in a subprocess to open an STARTTLS connection.
94 The program should read input on stdin, write output to stdout,
95 and initiate TLS negotiation when receiving the SIGALRM signal.
96 Also see `starttls-connect', `starttls-failure', and
97 `starttls-success' for what the program should output after
98 initial connection and successful negotiation respectively."
102 (defcustom starttls-extra-arguments nil
103 "List of extra arguments to `starttls-file-name'.
104 E.g., (\"--protocols\" \"ssl3\")."
105 :type '(repeat string)
108 (defcustom starttls-process-connection-type nil
109 "*Value for `process-connection-type' to use when starting STARTTLS process."
113 (defcustom starttls-connect "- Simple Client Mode:\n\n"
114 "*Regular expression indicating successful connection.
115 The default is what GNUTLS's \"gnutls-cli\" outputs."
116 ;; GNUTLS cli.c:main() print this string when it is starting to run
117 ;; in the application read/write phase. If the logic, or the string
118 ;; itself, is modified, this must be updated.
122 (defcustom starttls-failure "*** Handshake has failed"
123 "*Regular expression indicating failed TLS handshake.
124 The default is what GNUTLS's \"gnutls-cli\" outputs."
125 ;; GNUTLS cli.c:do_handshake() print this string on failure. If the
126 ;; logic, or the string itself, is modified, this must be updated.
130 (defcustom starttls-success "- Compression: "
131 "*Regular expression indicating completed TLS handshakes.
132 The default is what GNUTLS's \"gnutls-cli\" outputs."
133 ;; GNUTLS cli.c:do_handshake() calls, on success,
134 ;; common.c:print_info(), that unconditionally print this string
135 ;; last. If that logic, or the string itself, is modified, this
140 (defun negotiate-starttls (process)
141 "Negotiate TLS on process opened by `open-starttls-stream'.
142 This should typically only be done once. It typically return a
143 multi-line informational message with information about the
144 handshake, or NIL on failure."
145 (let (buffer info old-max done-ok done-bad)
146 (if (null (setq buffer (process-buffer process)))
147 ;; XXX How to remove/extract the TLS negotiation junk?
148 (signal-process (process-id process) 'SIGALRM)
149 (with-current-buffer buffer
151 (setq old-max (goto-char (point-max)))
152 (signal-process (process-id process) 'SIGALRM)
153 (while (and (processp process)
154 (eq (process-status process) 'run)
157 (not (or (setq done-ok (re-search-forward
158 starttls-success nil t))
159 (setq done-bad (re-search-forward
160 starttls-failure nil t))))))
161 (accept-process-output process 1 100)
163 (setq info (buffer-substring-no-properties old-max (point-max)))
164 (delete-region old-max (point-max))
165 (if (or (and done-ok (not done-bad))
166 ;; Prevent mitm that fake success msg after failure msg.
167 (and done-ok done-bad (< done-ok done-bad)))
169 (message "STARTTLS negotiation failed: %s" info)
172 (defun open-starttls-stream (name buffer host service)
173 "Open a TLS connection for a service to a host.
174 Returns a subprocess-object to represent the connection.
175 Input and output work as for subprocesses; `delete-process' closes it.
176 Args are NAME BUFFER HOST SERVICE.
177 NAME is name for process. It is modified if necessary to make it unique.
178 BUFFER is the buffer (or buffer-name) to associate with the process.
179 Process output goes at end of that buffer, unless you specify
180 an output stream or filter function to handle the output.
181 Third arg is name of the host to connect to, or its IP address.
182 Fourth arg SERVICE is name of the service desired, or an integer
183 specifying a port number to connect to."
184 (message "Opening STARTTLS connection to `%s'..." host)
186 (old-max (with-current-buffer buffer (point-max)))
187 (process-connection-type starttls-process-connection-type)
188 (process (apply #'start-process name buffer
189 starttls-file-name "-s" host
190 "-p" (if (integerp service)
191 (int-to-string service)
193 starttls-extra-arguments)))
194 (process-kill-without-query process)
195 (while (and (processp process)
196 (eq (process-status process) 'run)
200 (not (setq done (re-search-forward
201 starttls-connect nil t)))))
202 (accept-process-output process 0 100)
205 (with-current-buffer buffer
206 (delete-region old-max done))
207 (delete-process process)
209 (message "Opening STARTTLS connection to `%s'...%s"
210 host (if done "done" "failed"))
213 ;; Compatibility with starttls.el by Daiki Ueno <ueno@unixuser.org>:
214 (defvaralias 'starttls-program 'starttls-file-name)
215 (make-obsolete-variable 'starttls-program 'starttls-file-name)
216 (defvaralias 'starttls-extra-args 'starttls-extra-arguments)
217 (make-obsolete-variable 'starttls-extra-args 'starttls-extra-arguments)
218 (defalias 'starttls-open-stream 'open-starttls-stream)
219 (defalias 'starttls-negotiate 'negotiate-starttls)
223 ;;; starttls.el ends here