34219
|
1 ;;; starttls.el --- STARTTLS functions
|
|
2
|
55783
|
3 ;; Copyright (C) 1999, 2000, 2003, 2004 Free Software Foundation, Inc.
|
34219
|
4
|
|
5 ;; Author: Daiki Ueno <ueno@unixuser.org>
|
55783
|
6 ;; Author: Simon Josefsson <simon@josefsson.org>
|
34219
|
7 ;; Created: 1999/11/20
|
55783
|
8 ;; Keywords: TLS, SSL, OpenSSL, GNUTLS, mail, news
|
34219
|
9
|
34220
|
10 ;; This file is part of GNU Emacs.
|
34219
|
11
|
34220
|
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)
|
|
15 ;; any later version.
|
34219
|
16
|
34220
|
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.
|
34219
|
21
|
|
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.
|
|
26
|
|
27 ;;; Commentary:
|
|
28
|
|
29 ;; This module defines some utility functions for STARTTLS profiles.
|
|
30
|
|
31 ;; [RFC 2595] "Using TLS with IMAP, POP3 and ACAP"
|
|
32 ;; by Chris Newman <chris.newman@innosoft.com> (1999/06)
|
|
33
|
55783
|
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.
|
|
39 ;;
|
|
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.
|
|
45
|
|
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/>.
|
|
49
|
|
50 ;; Usage is similar to `open-network-stream'. For example:
|
|
51 ;;
|
|
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"))
|
|
59
|
|
60 ;; An example run yield the following output:
|
|
61 ;;
|
|
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
|
|
66 ;; 250-PIPELINING
|
|
67 ;; 250-EXPN
|
|
68 ;; 250-VERB
|
|
69 ;; 250-8BITMIME
|
|
70 ;; 250-SIZE
|
|
71 ;; 250-DSN
|
|
72 ;; 250-ETRN
|
|
73 ;; 250-AUTH DIGEST-MD5 CRAM-MD5 PLAIN LOGIN
|
|
74 ;; 250-DELIVERBY
|
|
75 ;; 250 HELP
|
|
76 ;; nil
|
|
77 ;;
|
|
78 ;; With the message buffer containing:
|
|
79 ;;
|
|
80 ;; STARTTLS output:
|
|
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.
|
|
86 ;;
|
|
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
|
|
93 ;; # version: #1
|
|
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
|
|
98 ;;
|
|
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
|
|
104 ;; # version: #3
|
|
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
|
|
109 ;;
|
|
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
|
|
115 ;; - MAC: SHA
|
|
116 ;; - Compression: NULL
|
|
117
|
34219
|
118 ;;; Code:
|
|
119
|
|
120 (defgroup starttls nil
|
|
121 "Support for `Transport Layer Security' protocol."
|
34220
|
122 :version "21.1"
|
|
123 :group 'mail)
|
34219
|
124
|
55783
|
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."
|
57856
|
129 :version "21.4"
|
55783
|
130 :type 'string
|
|
131 :group 'starttls)
|
|
132
|
34219
|
133 (defcustom starttls-program "starttls"
|
55783
|
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."
|
34220
|
137 :type 'string
|
34219
|
138 :group 'starttls)
|
|
139
|
55783
|
140 (defcustom starttls-use-gnutls (not (executable-find starttls-program))
|
|
141 "*Whether to use GNUTLS instead of the `starttls' command."
|
57856
|
142 :version "21.4"
|
55783
|
143 :type 'boolean
|
|
144 :group 'starttls)
|
|
145
|
34219
|
146 (defcustom starttls-extra-args nil
|
55783
|
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)
|
|
151 :group 'starttls)
|
|
152
|
|
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.
|
|
157
|
|
158 For example, non-TLS compliant servers may require
|
|
159 '(\"--protocols\" \"ssl3\"). Invoke \"gnutls-cli --help\" to
|
|
160 find out which parameters are available."
|
57856
|
161 :version "21.4"
|
34220
|
162 :type '(repeat string)
|
34219
|
163 :group 'starttls)
|
|
164
|
55783
|
165 (defcustom starttls-process-connection-type nil
|
|
166 "*Value for `process-connection-type' to use when starting STARTTLS process."
|
57856
|
167 :version "21.4"
|
55783
|
168 :type 'boolean
|
|
169 :group 'starttls)
|
|
170
|
|
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.
|
57856
|
177 :version "21.4"
|
55783
|
178 :type 'regexp
|
|
179 :group 'starttls)
|
|
180
|
|
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.
|
57856
|
186 :version "21.4"
|
55783
|
187 :type 'regexp
|
|
188 :group 'starttls)
|
|
189
|
|
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
|
|
196 ;; must be updated.
|
57856
|
197 :version "21.4"
|
55783
|
198 :type 'regexp
|
|
199 :group 'starttls)
|
|
200
|
|
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
|
|
211 (save-excursion
|
|
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)
|
|
216 (save-excursion
|
|
217 (goto-char old-max)
|
|
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)
|
|
223 (sit-for 0.1))
|
|
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)))
|
|
229 info
|
|
230 (message "STARTTLS negotiation failed: %s" info)
|
|
231 nil))))))
|
|
232
|
34219
|
233 (defun starttls-negotiate (process)
|
55783
|
234 (if starttls-use-gnutls
|
|
235 (starttls-negotiate-gnutls process)
|
|
236 (signal-process (process-id process) 'SIGALRM)))
|
|
237
|
|
238 (defun starttls-open-stream-gnutls (name buffer host service)
|
|
239 (message "Opening STARTTLS connection to `%s'..." host)
|
|
240 (let* (done
|
|
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)
|
|
247 service)
|
|
248 starttls-extra-arguments)))
|
|
249 (process-kill-without-query process)
|
|
250 (while (and (processp process)
|
|
251 (eq (process-status process) 'run)
|
|
252 (save-excursion
|
|
253 (set-buffer buffer)
|
|
254 (goto-char old-max)
|
|
255 (not (setq done (re-search-forward
|
|
256 starttls-connect nil t)))))
|
|
257 (accept-process-output process 0 100)
|
|
258 (sit-for 0.1))
|
|
259 (if done
|
|
260 (with-current-buffer buffer
|
|
261 (delete-region old-max done))
|
|
262 (delete-process process)
|
|
263 (setq process nil))
|
|
264 (message "Opening STARTTLS connection to `%s'...%s"
|
|
265 host (if done "done" "failed"))
|
|
266 process))
|
34219
|
267
|
|
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
|
|
278 with any buffer
|
|
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."
|
55783
|
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)
|
|
290 process)))
|
34219
|
291
|
|
292 (provide 'starttls)
|
|
293
|
52401
|
294 ;;; arch-tag: 648b3bd8-63bd-47f5-904c-7c819aea2297
|
34219
|
295 ;;; starttls.el ends here
|