Commit | Line | Data |
---|---|---|
01b2d1dd SJ |
1 | ;;; tls.el --- TLS/SSL support via wrapper around GnuTLS |
2 | ||
5fd6d89f | 3 | ;; Copyright (C) 1996, 1997, 1998, 1999, 2002, 2003, 2004, |
d7a0267c | 4 | ;; 2005, 2006, 2007 Free Software Foundation, Inc. |
01b2d1dd SJ |
5 | |
6 | ;; Author: Simon Josefsson <simon@josefsson.org> | |
7 | ;; Keywords: comm, tls, gnutls, ssl | |
8 | ||
9 | ;; This file is part of GNU Emacs. | |
10 | ||
11 | ;; GNU Emacs is free software; you can redistribute it and/or modify | |
12 | ;; it under the terms of the GNU General Public License as published by | |
ceaeecb0 | 13 | ;; the Free Software Foundation; either version 3, or (at your option) |
01b2d1dd SJ |
14 | ;; any later version. |
15 | ||
16 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
19 | ;; GNU General Public License for more details. | |
20 | ||
21 | ;; You should have received a copy of the GNU General Public License | |
22 | ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
3a35cf56 LK |
23 | ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
24 | ;; Boston, MA 02110-1301, USA. | |
01b2d1dd SJ |
25 | |
26 | ;;; Commentary: | |
27 | ||
28 | ;; This package implements a simple wrapper around "gnutls-cli" to | |
29 | ;; make Emacs support TLS/SSL. | |
30 | ;; | |
31 | ;; Usage is the same as `open-network-stream', i.e.: | |
32 | ;; | |
33 | ;; (setq tmp (open-tls-stream "test" (current-buffer) "news.mozilla.org" 563)) | |
34 | ;; ... | |
35 | ;; #<process test> | |
36 | ;; (process-send-string tmp "mode reader\n") | |
37 | ;; 200 secnews.netscape.com Netscape-Collabra/3.52 03615 NNRP ready ... | |
38 | ;; nil | |
39 | ;; (process-send-string tmp "quit\n") | |
40 | ;; 205 | |
41 | ;; nil | |
42 | ||
43 | ;; To use this package as a replacement for ssl.el by William M. Perry | |
44 | ;; <wmperry@cs.indiana.edu>, you need to evaluate the following: | |
45 | ;; | |
46 | ;; (defalias 'open-ssl-stream 'open-tls-stream) | |
47 | ||
48 | ;;; Code: | |
49 | ||
50 | (eval-and-compile | |
51 | (autoload 'format-spec "format-spec") | |
52 | (autoload 'format-spec-make "format-spec")) | |
53 | ||
54 | (defgroup tls nil | |
55 | "Transport Layer Security (TLS) parameters." | |
56 | :group 'comm) | |
57 | ||
59c95dc2 | 58 | (defcustom tls-end-of-info |
cd6db47c GM |
59 | (concat |
60 | "\\(" | |
61 | ;; `openssl s_client' regexp. See ssl/ssl_txt.c lines 219-220. | |
62 | ;; According to apps/s_client.c line 1515 `---' is always the last | |
63 | ;; line that is printed by s_client before the real data. | |
64 | "^ Verify return code: .+\n---\n\\|" | |
65 | ;; `gnutls' regexp. See src/cli.c lines 721-. | |
66 | "^- Simple Client Mode:\n" | |
67 | "\\(\n\\|" ; ignore blank lines | |
68 | ;; XXX: We have no way of knowing if the STARTTLS handshake sequence | |
69 | ;; has completed successfully, because `gnutls' will only report | |
70 | ;; failure. | |
71 | "^\\*\\*\\* Starting TLS handshake\n\\)*" | |
72 | "\\)") | |
59c95dc2 GM |
73 | "Regexp matching end of TLS client informational messages. |
74 | Client data stream begins after the last character matched by | |
75 | this. The default matches `openssl s_client' (version 0.9.8c) | |
76 | and `gnutls-cli' (version 2.0.1) output." | |
77 | :version "22.2" | |
78 | :type 'regexp | |
79 | :group 'tls) | |
80 | ||
01b2d1dd | 81 | (defcustom tls-program '("gnutls-cli -p %p %h" |
3031d8b0 MB |
82 | "gnutls-cli -p %p %h --protocols ssl3" |
83 | "openssl s_client -connect %h:%p -no_ssl2") | |
01b2d1dd SJ |
84 | "List of strings containing commands to start TLS stream to a host. |
85 | Each entry in the list is tried until a connection is successful. | |
4a3c7686 | 86 | %h is replaced with server hostname, %p with port to connect to. |
01b2d1dd SJ |
87 | The program should read input on stdin and write output to |
88 | stdout. Also see `tls-success' for what the program should output | |
89 | after successful negotiation." | |
90 | :type '(repeat string) | |
3031d8b0 | 91 | :version "22.1" |
01b2d1dd SJ |
92 | :group 'tls) |
93 | ||
94 | (defcustom tls-process-connection-type nil | |
23f87bed | 95 | "*Value for `process-connection-type' to use when starting TLS process." |
bf247b6e | 96 | :version "22.1" |
01b2d1dd SJ |
97 | :type 'boolean |
98 | :group 'tls) | |
99 | ||
3031d8b0 | 100 | (defcustom tls-success "- Handshake was completed\\|SSL handshake has read " |
01b2d1dd | 101 | "*Regular expression indicating completed TLS handshakes. |
3031d8b0 MB |
102 | The default is what GNUTLS's \"gnutls-cli\" or OpenSSL's |
103 | \"openssl s_client\" outputs." | |
bf247b6e | 104 | :version "22.1" |
01b2d1dd SJ |
105 | :type 'regexp |
106 | :group 'tls) | |
107 | ||
18965008 SJ |
108 | (defcustom tls-certtool-program (executable-find "certtool") |
109 | "Name of GnuTLS certtool. | |
110 | Used by `tls-certificate-information'." | |
bf247b6e | 111 | :version "22.1" |
9bdd0e16 | 112 | :type 'string |
18965008 SJ |
113 | :group 'tls) |
114 | ||
115 | (defun tls-certificate-information (der) | |
116 | "Parse X.509 certificate in DER format into an assoc list." | |
117 | (let ((certificate (concat "-----BEGIN CERTIFICATE-----\n" | |
118 | (base64-encode-string der) | |
119 | "\n-----END CERTIFICATE-----\n")) | |
120 | (exit-code 0)) | |
121 | (with-current-buffer (get-buffer-create " *certtool*") | |
122 | (erase-buffer) | |
123 | (insert certificate) | |
124 | (setq exit-code (condition-case () | |
125 | (call-process-region (point-min) (point-max) | |
126 | tls-certtool-program | |
127 | t (list (current-buffer) nil) t | |
128 | "--certificate-info") | |
129 | (error -1))) | |
130 | (if (/= exit-code 0) | |
131 | nil | |
132 | (let ((vals nil)) | |
133 | (goto-char (point-min)) | |
134 | (while (re-search-forward "^\\([^:]+\\): \\(.*\\)" nil t) | |
135 | (push (cons (match-string 1) (match-string 2)) vals)) | |
136 | (nreverse vals)))))) | |
137 | ||
3031d8b0 MB |
138 | (defun open-tls-stream (name buffer host port) |
139 | "Open a TLS connection for a port to a host. | |
01b2d1dd SJ |
140 | Returns a subprocess-object to represent the connection. |
141 | Input and output work as for subprocesses; `delete-process' closes it. | |
3031d8b0 | 142 | Args are NAME BUFFER HOST PORT. |
01b2d1dd SJ |
143 | NAME is name for process. It is modified if necessary to make it unique. |
144 | BUFFER is the buffer (or buffer-name) to associate with the process. | |
145 | Process output goes at end of that buffer, unless you specify | |
146 | an output stream or filter function to handle the output. | |
147 | BUFFER may be also nil, meaning that this process is not associated | |
148 | with any buffer | |
149 | Third arg is name of the host to connect to, or its IP address. | |
3031d8b0 | 150 | Fourth arg PORT is an integer specifying a port to connect to." |
0ad32c54 CY |
151 | (let ((cmds tls-program) |
152 | (use-temp-buffer (null buffer)) | |
153 | process cmd done) | |
154 | (if use-temp-buffer | |
155 | (setq buffer (generate-new-buffer " TLS"))) | |
cd6db47c | 156 | (with-current-buffer buffer |
59c95dc2 GM |
157 | (message "Opening TLS connection to `%s'..." host) |
158 | (while (and (not done) (setq cmd (pop cmds))) | |
159 | (message "Opening TLS connection with `%s'..." cmd) | |
160 | (let ((process-connection-type tls-process-connection-type) | |
161 | response) | |
162 | (setq process (start-process | |
163 | name buffer shell-file-name shell-command-switch | |
164 | (format-spec | |
165 | cmd | |
166 | (format-spec-make | |
167 | ?h host | |
168 | ?p (if (integerp port) | |
169 | (int-to-string port) | |
170 | port))))) | |
171 | (while (and process | |
172 | (memq (process-status process) '(open run)) | |
173 | (progn | |
174 | (goto-char (point-min)) | |
175 | (not (setq done (re-search-forward tls-success nil t))))) | |
176 | (unless (accept-process-output process 1) | |
177 | (sit-for 1))) | |
178 | (message "Opening TLS connection with `%s'...%s" cmd | |
179 | (if done "done" "failed")) | |
180 | (if (not done) | |
181 | (delete-process process) | |
182 | ;; advance point to after all informational messages that | |
183 | ;; `openssl s_client' and `gnutls' print | |
184 | (let ((start-of-data nil)) | |
185 | (while | |
186 | (not (setq start-of-data | |
187 | ;; the string matching `tls-end-of-info' | |
188 | ;; might come in separate chunks from | |
189 | ;; `accept-process-output', so start the | |
190 | ;; search where `tls-success' ended | |
191 | (save-excursion | |
192 | (if (re-search-forward tls-end-of-info nil t) | |
193 | (match-end 0))))) | |
194 | (accept-process-output process 1)) | |
195 | (if start-of-data | |
196 | ;; move point to start of client data | |
197 | (goto-char start-of-data))) | |
198 | (setq done process)))) | |
199 | (message "Opening TLS connection to `%s'...%s" | |
200 | host (if done "done" "failed"))) | |
0ad32c54 | 201 | (when use-temp-buffer |
b7131d2f | 202 | (if done (set-process-buffer process nil)) |
0ad32c54 | 203 | (kill-buffer buffer)) |
01b2d1dd SJ |
204 | done)) |
205 | ||
206 | (provide 'tls) | |
207 | ||
ab5796a9 | 208 | ;;; arch-tag: 5596d1c4-facc-4bc4-94a9-9863b928d7ac |
01b2d1dd | 209 | ;;; tls.el ends here |