Commit | Line | Data |
---|---|---|
10b7b8fc DL |
1 | ;;; starttls.el --- STARTTLS functions |
2 | ||
acaf905b | 3 | ;; Copyright (C) 1999-2012 Free Software Foundation, Inc. |
10b7b8fc DL |
4 | |
5 | ;; Author: Daiki Ueno <ueno@unixuser.org> | |
cdf33cae | 6 | ;; Author: Simon Josefsson <simon@josefsson.org> |
10b7b8fc | 7 | ;; Created: 1999/11/20 |
321decc8 | 8 | ;; Keywords: TLS, SSL, OpenSSL, GnuTLS, mail, news |
10b7b8fc | 9 | |
020930fb | 10 | ;; This file is part of GNU Emacs. |
10b7b8fc | 11 | |
5e809f55 | 12 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
020930fb | 13 | ;; it under the terms of the GNU General Public License as published by |
5e809f55 GM |
14 | ;; the Free Software Foundation, either version 3 of the License, or |
15 | ;; (at your option) any later version. | |
10b7b8fc | 16 | |
020930fb DL |
17 | ;; GNU Emacs is distributed in the hope that it will be useful, |
18 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
5e809f55 | 19 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
020930fb | 20 | ;; GNU General Public License for more details. |
10b7b8fc DL |
21 | |
22 | ;; You should have received a copy of the GNU General Public License | |
5e809f55 | 23 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
10b7b8fc DL |
24 | |
25 | ;;; Commentary: | |
26 | ||
27 | ;; This module defines some utility functions for STARTTLS profiles. | |
28 | ||
29 | ;; [RFC 2595] "Using TLS with IMAP, POP3 and ACAP" | |
30 | ;; by Chris Newman <chris.newman@innosoft.com> (1999/06) | |
31 | ||
3031d8b0 | 32 | ;; This file now contains a combination of the two previous |
cdf33cae SJ |
33 | ;; implementations both called "starttls.el". The first one is Daiki |
34 | ;; Ueno's starttls.el which uses his own "starttls" command line tool, | |
35 | ;; and the second one is Simon Josefsson's starttls.el which uses | |
321decc8 | 36 | ;; "gnutls-cli" from GnuTLS. |
cdf33cae | 37 | ;; |
e4920bc9 | 38 | ;; If "starttls" is available, it is preferred by the code over |
cdf33cae SJ |
39 | ;; "gnutls-cli", for backwards compatibility. Use |
40 | ;; `starttls-use-gnutls' to toggle between implementations if you have | |
321decc8 | 41 | ;; both tools installed. It is recommended to use GnuTLS, though, as |
cdf33cae SJ |
42 | ;; it performs more verification of the certificates. |
43 | ||
321decc8 | 44 | ;; The GnuTLS support requires GnuTLS 0.9.90 (released 2003-10-08) or |
cdf33cae SJ |
45 | ;; later, from <http://www.gnu.org/software/gnutls/>, or "starttls" |
46 | ;; from <ftp://ftp.opaopa.org/pub/elisp/>. | |
47 | ||
48 | ;; Usage is similar to `open-network-stream'. For example: | |
49 | ;; | |
50 | ;; (when (setq tmp (starttls-open-stream | |
51 | ;; "test" (current-buffer) "yxa.extundo.com" 25)) | |
52 | ;; (accept-process-output tmp 15) | |
53 | ;; (process-send-string tmp "STARTTLS\n") | |
54 | ;; (accept-process-output tmp 15) | |
55 | ;; (message "STARTTLS output:\n%s" (starttls-negotiate tmp)) | |
56 | ;; (process-send-string tmp "EHLO foo\n")) | |
57 | ||
3031d8b0 | 58 | ;; An example run yields the following output: |
cdf33cae SJ |
59 | ;; |
60 | ;; 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] | |
61 | ;; 220 2.0.0 Ready to start TLS | |
62 | ;; 250-yxa.extundo.com Hello c494102a.s-bi.bostream.se [217.215.27.65], pleased to meet you | |
63 | ;; 250-ENHANCEDSTATUSCODES | |
64 | ;; 250-PIPELINING | |
65 | ;; 250-EXPN | |
66 | ;; 250-VERB | |
67 | ;; 250-8BITMIME | |
68 | ;; 250-SIZE | |
69 | ;; 250-DSN | |
70 | ;; 250-ETRN | |
71 | ;; 250-AUTH DIGEST-MD5 CRAM-MD5 PLAIN LOGIN | |
72 | ;; 250-DELIVERBY | |
73 | ;; 250 HELP | |
74 | ;; nil | |
75 | ;; | |
76 | ;; With the message buffer containing: | |
77 | ;; | |
78 | ;; STARTTLS output: | |
79 | ;; *** Starting TLS handshake | |
80 | ;; - Server's trusted authorities: | |
81 | ;; [0]: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com | |
82 | ;; - Certificate type: X.509 | |
83 | ;; - Got a certificate list of 2 certificates. | |
84 | ;; | |
85 | ;; - Certificate[0] info: | |
86 | ;; # The hostname in the certificate matches 'yxa.extundo.com'. | |
87 | ;; # valid since: Wed May 26 12:16:00 CEST 2004 | |
88 | ;; # expires at: Wed Jul 26 12:16:00 CEST 2023 | |
89 | ;; # serial number: 04 | |
90 | ;; # fingerprint: 7c 04 4b c1 fa 26 9b 5d 90 22 52 3c 65 3d 85 3a | |
91 | ;; # version: #1 | |
92 | ;; # public key algorithm: RSA | |
93 | ;; # Modulus: 1024 bits | |
94 | ;; # Subject's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=Mail server,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com | |
95 | ;; # Issuer's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com | |
96 | ;; | |
97 | ;; - Certificate[1] info: | |
98 | ;; # valid since: Sun May 23 11:35:00 CEST 2004 | |
99 | ;; # expires at: Sun Jul 23 11:35:00 CEST 2023 | |
100 | ;; # serial number: 00 | |
101 | ;; # fingerprint: fc 76 d8 63 1a c9 0b 3b fa 40 fe ed 47 7a 58 ae | |
102 | ;; # version: #3 | |
103 | ;; # public key algorithm: RSA | |
104 | ;; # Modulus: 1024 bits | |
105 | ;; # Subject's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com | |
106 | ;; # Issuer's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com | |
107 | ;; | |
108 | ;; - Peer's certificate issuer is unknown | |
109 | ;; - Peer's certificate is NOT trusted | |
110 | ;; - Version: TLS 1.0 | |
111 | ;; - Key Exchange: RSA | |
112 | ;; - Cipher: ARCFOUR 128 | |
113 | ;; - MAC: SHA | |
114 | ;; - Compression: NULL | |
115 | ||
10b7b8fc DL |
116 | ;;; Code: |
117 | ||
118 | (defgroup starttls nil | |
119 | "Support for `Transport Layer Security' protocol." | |
020930fb DL |
120 | :version "21.1" |
121 | :group 'mail) | |
10b7b8fc | 122 | |
cdf33cae | 123 | (defcustom starttls-gnutls-program "gnutls-cli" |
321decc8 GM |
124 | "Name of GnuTLS command line tool. |
125 | This program is used when GnuTLS is used, i.e. when | |
cdf33cae | 126 | `starttls-use-gnutls' is non-nil." |
bf247b6e | 127 | :version "22.1" |
cdf33cae SJ |
128 | :type 'string |
129 | :group 'starttls) | |
130 | ||
10b7b8fc | 131 | (defcustom starttls-program "starttls" |
cdf33cae SJ |
132 | "The program to run in a subprocess to open an TLSv1 connection. |
133 | This program is used when the `starttls' command is used, | |
134 | i.e. when `starttls-use-gnutls' is nil." | |
020930fb | 135 | :type 'string |
10b7b8fc DL |
136 | :group 'starttls) |
137 | ||
cdf33cae | 138 | (defcustom starttls-use-gnutls (not (executable-find starttls-program)) |
321decc8 | 139 | "*Whether to use GnuTLS instead of the `starttls' command." |
bf247b6e | 140 | :version "22.1" |
cdf33cae SJ |
141 | :type 'boolean |
142 | :group 'starttls) | |
143 | ||
10b7b8fc | 144 | (defcustom starttls-extra-args nil |
cdf33cae | 145 | "Extra arguments to `starttls-program'. |
3031d8b0 MB |
146 | These apply when the `starttls' command is used, i.e. when |
147 | `starttls-use-gnutls' is nil." | |
020930fb | 148 | :type '(repeat string) |
10b7b8fc DL |
149 | :group 'starttls) |
150 | ||
cdf33cae | 151 | (defcustom starttls-extra-arguments nil |
a31eeec2 | 152 | "Extra arguments to `starttls-gnutls-program'. |
321decc8 | 153 | These apply when GnuTLS is used, i.e. when `starttls-use-gnutls' is non-nil. |
cdf33cae SJ |
154 | |
155 | For example, non-TLS compliant servers may require | |
156 | '(\"--protocols\" \"ssl3\"). Invoke \"gnutls-cli --help\" to | |
157 | find out which parameters are available." | |
bf247b6e | 158 | :version "22.1" |
cdf33cae SJ |
159 | :type '(repeat string) |
160 | :group 'starttls) | |
161 | ||
162 | (defcustom starttls-process-connection-type nil | |
163 | "*Value for `process-connection-type' to use when starting STARTTLS process." | |
bf247b6e | 164 | :version "22.1" |
cdf33cae SJ |
165 | :type 'boolean |
166 | :group 'starttls) | |
167 | ||
168 | (defcustom starttls-connect "- Simple Client Mode:\n\n" | |
169 | "*Regular expression indicating successful connection. | |
321decc8 GM |
170 | The default is what GnuTLS's \"gnutls-cli\" outputs." |
171 | ;; GnuTLS cli.c:main() prints this string when it is starting to run | |
cdf33cae SJ |
172 | ;; in the application read/write phase. If the logic, or the string |
173 | ;; itself, is modified, this must be updated. | |
bf247b6e | 174 | :version "22.1" |
cdf33cae SJ |
175 | :type 'regexp |
176 | :group 'starttls) | |
177 | ||
178 | (defcustom starttls-failure "\\*\\*\\* Handshake has failed" | |
179 | "*Regular expression indicating failed TLS handshake. | |
321decc8 GM |
180 | The default is what GnuTLS's \"gnutls-cli\" outputs." |
181 | ;; GnuTLS cli.c:do_handshake() prints this string on failure. If the | |
cdf33cae | 182 | ;; logic, or the string itself, is modified, this must be updated. |
bf247b6e | 183 | :version "22.1" |
cdf33cae SJ |
184 | :type 'regexp |
185 | :group 'starttls) | |
186 | ||
187 | (defcustom starttls-success "- Compression: " | |
188 | "*Regular expression indicating completed TLS handshakes. | |
321decc8 GM |
189 | The default is what GnuTLS's \"gnutls-cli\" outputs." |
190 | ;; GnuTLS cli.c:do_handshake() calls, on success, | |
cdf33cae SJ |
191 | ;; common.c:print_info(), that unconditionally print this string |
192 | ;; last. If that logic, or the string itself, is modified, this | |
193 | ;; must be updated. | |
bf247b6e | 194 | :version "22.1" |
cdf33cae SJ |
195 | :type 'regexp |
196 | :group 'starttls) | |
197 | ||
198 | (defun starttls-negotiate-gnutls (process) | |
3031d8b0 MB |
199 | "Negotiate TLS on PROCESS opened by `open-starttls-stream'. |
200 | This should typically only be done once. It typically returns a | |
cdf33cae | 201 | multi-line informational message with information about the |
3031d8b0 | 202 | handshake, or nil on failure." |
cdf33cae SJ |
203 | (let (buffer info old-max done-ok done-bad) |
204 | (if (null (setq buffer (process-buffer process))) | |
205 | ;; XXX How to remove/extract the TLS negotiation junk? | |
206 | (signal-process (process-id process) 'SIGALRM) | |
207 | (with-current-buffer buffer | |
208 | (save-excursion | |
209 | (setq old-max (goto-char (point-max))) | |
210 | (signal-process (process-id process) 'SIGALRM) | |
211 | (while (and (processp process) | |
212 | (eq (process-status process) 'run) | |
213 | (save-excursion | |
214 | (goto-char old-max) | |
215 | (not (or (setq done-ok (re-search-forward | |
216 | starttls-success nil t)) | |
217 | (setq done-bad (re-search-forward | |
218 | starttls-failure nil t)))))) | |
219 | (accept-process-output process 1 100) | |
220 | (sit-for 0.1)) | |
221 | (setq info (buffer-substring-no-properties old-max (point-max))) | |
222 | (delete-region old-max (point-max)) | |
223 | (if (or (and done-ok (not done-bad)) | |
224 | ;; Prevent mitm that fake success msg after failure msg. | |
225 | (and done-ok done-bad (< done-ok done-bad))) | |
226 | info | |
227 | (message "STARTTLS negotiation failed: %s" info) | |
228 | nil)))))) | |
229 | ||
10b7b8fc | 230 | (defun starttls-negotiate (process) |
cdf33cae SJ |
231 | (if starttls-use-gnutls |
232 | (starttls-negotiate-gnutls process) | |
233 | (signal-process (process-id process) 'SIGALRM))) | |
234 | ||
0f69d598 MB |
235 | (eval-and-compile |
236 | (if (fboundp 'set-process-query-on-exit-flag) | |
237 | (defalias 'starttls-set-process-query-on-exit-flag | |
238 | 'set-process-query-on-exit-flag) | |
4a43ee9b | 239 | (defalias 'starttls-set-process-query-on-exit-flag |
0f69d598 | 240 | 'process-kill-without-query))) |
4a43ee9b | 241 | |
3031d8b0 | 242 | (defun starttls-open-stream-gnutls (name buffer host port) |
ed778fad | 243 | (message "Opening STARTTLS connection to `%s:%s'..." host port) |
cdf33cae SJ |
244 | (let* (done |
245 | (old-max (with-current-buffer buffer (point-max))) | |
246 | (process-connection-type starttls-process-connection-type) | |
247 | (process (apply #'start-process name buffer | |
248 | starttls-gnutls-program "-s" host | |
3031d8b0 MB |
249 | "-p" (if (integerp port) |
250 | (int-to-string port) | |
251 | port) | |
cdf33cae | 252 | starttls-extra-arguments))) |
4a43ee9b | 253 | (starttls-set-process-query-on-exit-flag process nil) |
cdf33cae SJ |
254 | (while (and (processp process) |
255 | (eq (process-status process) 'run) | |
20a673b2 | 256 | (with-current-buffer buffer |
cdf33cae SJ |
257 | (goto-char old-max) |
258 | (not (setq done (re-search-forward | |
259 | starttls-connect nil t))))) | |
260 | (accept-process-output process 0 100) | |
261 | (sit-for 0.1)) | |
262 | (if done | |
263 | (with-current-buffer buffer | |
264 | (delete-region old-max done)) | |
265 | (delete-process process) | |
266 | (setq process nil)) | |
ed778fad MB |
267 | (message "Opening STARTTLS connection to `%s:%s'...%s" |
268 | host port (if done "done" "failed")) | |
cdf33cae | 269 | process)) |
10b7b8fc | 270 | |
61b1af82 | 271 | ;;;###autoload |
3031d8b0 MB |
272 | (defun starttls-open-stream (name buffer host port) |
273 | "Open a TLS connection for a port to a host. | |
274 | Returns a subprocess object to represent the connection. | |
10b7b8fc | 275 | Input and output work as for subprocesses; `delete-process' closes it. |
3031d8b0 | 276 | Args are NAME BUFFER HOST PORT. |
10b7b8fc DL |
277 | NAME is name for process. It is modified if necessary to make it unique. |
278 | BUFFER is the buffer (or `buffer-name') to associate with the process. | |
279 | Process output goes at end of that buffer, unless you specify | |
280 | an output stream or filter function to handle the output. | |
281 | BUFFER may be also nil, meaning that this process is not associated | |
282 | with any buffer | |
283 | Third arg is name of the host to connect to, or its IP address. | |
3031d8b0 MB |
284 | Fourth arg PORT is an integer specifying a port to connect to. |
285 | If `starttls-use-gnutls' is nil, this may also be a service name, but | |
321decc8 | 286 | GnuTLS requires a port number." |
cdf33cae | 287 | (if starttls-use-gnutls |
3031d8b0 | 288 | (starttls-open-stream-gnutls name buffer host port) |
ed778fad | 289 | (message "Opening STARTTLS connection to `%s:%s'" host (format "%s" port)) |
cdf33cae SJ |
290 | (let* ((process-connection-type starttls-process-connection-type) |
291 | (process (apply #'start-process | |
292 | name buffer starttls-program | |
3031d8b0 | 293 | host (format "%s" port) |
cdf33cae | 294 | starttls-extra-args))) |
4a43ee9b | 295 | (starttls-set-process-query-on-exit-flag process nil) |
cdf33cae | 296 | process))) |
10b7b8fc | 297 | |
9a70f03d PE |
298 | (defun starttls-available-p () |
299 | "Say whether the STARTTLS programs are available." | |
8f30779d LMI |
300 | (and (not (memq system-type '(windows-nt ms-dos))) |
301 | (executable-find (if starttls-use-gnutls | |
302 | starttls-gnutls-program | |
303 | starttls-program)))) | |
ed778fad | 304 | |
4d9db491 G |
305 | (defalias 'starttls-any-program-available 'starttls-available-p) |
306 | (make-obsolete 'starttls-any-program-available 'starttls-available-p | |
307 | "2011-08-02") | |
308 | ||
10b7b8fc DL |
309 | (provide 'starttls) |
310 | ||
311 | ;;; starttls.el ends here |