Commit | Line | Data |
---|---|---|
da91b5f2 | 1 | ;;; network-stream.el --- open network processes, possibly with encryption |
a33a2868 | 2 | |
73b0cd50 | 3 | ;; Copyright (C) 2010-2011 Free Software Foundation, Inc. |
ed797193 G |
4 | |
5 | ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> | |
6 | ;; Keywords: network | |
7 | ||
8 | ;; This file is part of GNU Emacs. | |
9 | ||
a33a2868 | 10 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
ed797193 | 11 | ;; it under the terms of the GNU General Public License as published by |
a33a2868 GM |
12 | ;; the Free Software Foundation, either version 3 of the License, or |
13 | ;; (at your option) any later version. | |
ed797193 G |
14 | |
15 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
a33a2868 | 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
ed797193 G |
18 | ;; GNU General Public License for more details. |
19 | ||
20 | ;; You should have received a copy of the GNU General Public License | |
a33a2868 | 21 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
ed797193 G |
22 | |
23 | ;;; Commentary: | |
24 | ||
da91b5f2 CY |
25 | ;; This library provides the function `open-network-stream', which provides a |
26 | ;; higher-level interface for opening TCP network processes than the built-in | |
27 | ;; function `make-network-process'. In addition to plain connections, it | |
28 | ;; supports TLS/SSL and STARTTLS connections. | |
ed797193 G |
29 | |
30 | ;; Usage example: | |
31 | ||
da91b5f2 | 32 | ;; (open-network-stream |
ed797193 | 33 | ;; "*nnimap*" buffer address port |
e742e117 | 34 | ;; :type 'network |
ed797193 G |
35 | ;; :capability-command "1 CAPABILITY\r\n" |
36 | ;; :success " OK " | |
37 | ;; :starttls-function | |
38 | ;; (lambda (capabilities) | |
39 | ;; (if (not (string-match "STARTTLS" capabilities)) | |
40 | ;; nil | |
41 | ;; "1 STARTTLS\r\n"))) | |
42 | ||
43 | ;;; Code: | |
44 | ||
ed797193 G |
45 | (require 'tls) |
46 | (require 'starttls) | |
4ea31e07 | 47 | (require 'auth-source) |
ed797193 | 48 | |
2db18f3f LMI |
49 | (autoload 'gnutls-negotiate "gnutls") |
50 | (autoload 'open-gnutls-stream "gnutls") | |
ed797193 G |
51 | |
52 | ;;;###autoload | |
da91b5f2 CY |
53 | (defun open-network-stream (name buffer host service &rest parameters) |
54 | "Open a TCP connection to HOST, optionally with encryption. | |
f2eefd24 CY |
55 | Normally, return a network process object; with a non-nil |
56 | :return-list parameter, return a list instead (see below). | |
da91b5f2 CY |
57 | Input and output work as for subprocesses; `delete-process' |
58 | closes it. | |
59 | ||
60 | NAME is the name for the process. It is modified if necessary to | |
61 | make it unique. | |
62 | BUFFER is a buffer or buffer name to associate with the process. | |
63 | Process output goes at end of that buffer. BUFFER may be nil, | |
64 | meaning that the process is not associated with any buffer. | |
65 | HOST is the name or IP address of the host to connect to. | |
66 | SERVICE is the name of the service desired, or an integer specifying | |
67 | a port number to connect to. | |
f2eefd24 | 68 | |
da91b5f2 CY |
69 | The remaining PARAMETERS should be a sequence of keywords and |
70 | values: | |
f2eefd24 CY |
71 | |
72 | :type specifies the connection type, one of the following: | |
e742e117 CY |
73 | nil or `network' |
74 | -- Begin with an ordinary network connection, and if | |
75 | the parameters :success and :capability-command | |
76 | are also supplied, try to upgrade to an encrypted | |
77 | connection via STARTTLS. Even if that | |
78 | fails (e.g. if HOST does not support TLS), retain | |
79 | an unencrypted connection. | |
80 | `plain' -- An ordinary, unencrypted network connection. | |
81 | `starttls' -- Begin with an ordinary connection, and try | |
82 | upgrading via STARTTLS. If that fails for any | |
83 | reason, drop the connection; in that case the | |
84 | returned object is a killed process. | |
85 | `tls' -- A TLS connection. | |
86 | `ssl' -- Equivalent to `tls'. | |
f2eefd24 CY |
87 | `shell' -- A shell connection. |
88 | ||
89 | :return-list specifies this function's return value. | |
90 | If omitted or nil, return a process object. A non-nil means to | |
91 | return (PROC . PROPS), where PROC is a process object and PROPS | |
92 | is a plist of connection properties, with these keywords: | |
93 | :greeting -- the greeting returned by HOST (a string), or nil. | |
94 | :capabilities -- a string representing HOST's capabilities, | |
95 | or nil if none could be found. | |
e742e117 CY |
96 | :type -- the resulting connection type; `plain' (unencrypted) |
97 | or `tls' (TLS-encrypted). | |
f2eefd24 CY |
98 | |
99 | :end-of-command specifies a regexp matching the end of a command. | |
f2eefd24 | 100 | |
2b216704 LMI |
101 | :end-of-capability specifies a regexp matching the end of the |
102 | response to the command specified for :capability-command. | |
103 | It defaults to the regexp specified for :end-of-command. | |
104 | ||
f2eefd24 CY |
105 | :success specifies a regexp matching a message indicating a |
106 | successful STARTTLS negotiation. For instance, the default | |
e742e117 | 107 | should be \"^3\" for an NNTP connection. |
f2eefd24 CY |
108 | |
109 | :capability-command specifies a command used to query the HOST | |
110 | for its capabilities. For instance, for IMAP this should be | |
111 | \"1 CAPABILITY\\r\\n\". | |
112 | ||
113 | :starttls-function specifies a function for handling STARTTLS. | |
114 | This function should take one parameter, the response to the | |
115 | capability command, and should return the command to switch on | |
8de66e05 LMI |
116 | STARTTLS if the server supports STARTTLS, and nil otherwise. |
117 | ||
4bba86e6 | 118 | :always-query-capabilies says whether to query the server for |
4ea31e07 LMI |
119 | capabilities, even if we're doing a `plain' network connection. |
120 | ||
121 | :client-certificate should either be a list where the first | |
122 | element is the certificate key file name, and the second | |
123 | element is the certificate file name itself, or `t', which | |
124 | means that `auth-source' will be queried for the key and the | |
125 | certificate. This parameter will only be used when doing TLS | |
126 | or STARTTLS connections. | |
4bba86e6 | 127 | |
6af7a784 LMI |
128 | If :use-starttls-if-possible is non-nil, do opportunistic |
129 | STARTTLS upgrades even if Emacs doesn't have built-in TLS | |
130 | functionality. | |
131 | ||
8de66e05 | 132 | :nowait is a boolean that says the connection should be made |
4ea31e07 | 133 | asynchronously, if possible." |
da91b5f2 CY |
134 | (unless (featurep 'make-network-process) |
135 | (error "Emacs was compiled without networking support")) | |
f2eefd24 CY |
136 | (let ((type (plist-get parameters :type)) |
137 | (return-list (plist-get parameters :return-list))) | |
e742e117 CY |
138 | (if (and (not return-list) |
139 | (or (eq type 'plain) | |
140 | (and (memq type '(nil network)) | |
141 | (not (and (plist-get parameters :success) | |
142 | (plist-get parameters :capability-command)))))) | |
da91b5f2 CY |
143 | ;; The simplest case: wrapper around `make-network-process'. |
144 | (make-network-process :name name :buffer buffer | |
8de66e05 LMI |
145 | :host host :service service |
146 | :nowait (plist-get parameters :nowait)) | |
da91b5f2 CY |
147 | (let ((work-buffer (or buffer |
148 | (generate-new-buffer " *stream buffer*"))) | |
4bba86e6 LMI |
149 | (fun (cond ((and (eq type 'plain) |
150 | (not (plist-get parameters | |
151 | :always-query-capabilities))) | |
152 | 'network-stream-open-plain) | |
153 | ((memq type '(nil network starttls plain)) | |
da91b5f2 CY |
154 | 'network-stream-open-starttls) |
155 | ((memq type '(tls ssl)) 'network-stream-open-tls) | |
156 | ((eq type 'shell) 'network-stream-open-shell) | |
157 | (t (error "Invalid connection type %s" type)))) | |
158 | result) | |
159 | (unwind-protect | |
160 | (setq result (funcall fun name work-buffer host service parameters)) | |
161 | (unless buffer | |
162 | (and (processp (car result)) | |
163 | (set-process-buffer (car result) nil)) | |
164 | (kill-buffer work-buffer))) | |
f2eefd24 CY |
165 | (if return-list |
166 | (list (car result) | |
167 | :greeting (nth 1 result) | |
168 | :capabilities (nth 2 result) | |
468d09d4 LMI |
169 | :type (nth 3 result) |
170 | :error (nth 4 result)) | |
f2eefd24 CY |
171 | (car result)))))) |
172 | ||
4ea31e07 LMI |
173 | (defun network-stream-certificate (host service parameters) |
174 | (let ((spec (plist-get :client-certificate parameters))) | |
175 | (cond | |
176 | ((listp spec) | |
177 | ;; Either nil or a list with a key/certificate pair. | |
178 | spec) | |
179 | ((eq spec t) | |
180 | (let* ((auth-info | |
181 | (car (auth-source-search :max 1 | |
182 | :host host | |
183 | :port service))) | |
eb8c9362 LMI |
184 | (key (plist-get auth-info :key)) |
185 | (cert (plist-get auth-info :cert))) | |
4ea31e07 LMI |
186 | (and key cert |
187 | (list key cert))))))) | |
188 | ||
da91b5f2 CY |
189 | ;;;###autoload |
190 | (defalias 'open-protocol-stream 'open-network-stream) | |
191 | ||
192 | (defun network-stream-open-plain (name buffer host service parameters) | |
07176b2a | 193 | (let ((start (with-current-buffer buffer (point))) |
da91b5f2 | 194 | (stream (make-network-process :name name :buffer buffer |
8de66e05 LMI |
195 | :host host :service service |
196 | :nowait (plist-get parameters :nowait)))) | |
07176b2a | 197 | (list stream |
da91b5f2 | 198 | (network-stream-get-response stream start |
8de66e05 | 199 | (plist-get parameters :end-of-command)) |
008cad90 | 200 | nil |
e742e117 | 201 | 'plain))) |
3b84b005 | 202 | |
da91b5f2 | 203 | (defun network-stream-open-starttls (name buffer host service parameters) |
ed797193 | 204 | (let* ((start (with-current-buffer buffer (point))) |
e742e117 | 205 | (require-tls (eq (plist-get parameters :type) 'starttls)) |
f2eefd24 CY |
206 | (starttls-function (plist-get parameters :starttls-function)) |
207 | (success-string (plist-get parameters :success)) | |
208 | (capability-command (plist-get parameters :capability-command)) | |
209 | (eoc (plist-get parameters :end-of-command)) | |
2b216704 LMI |
210 | (eo-capa (or (plist-get parameters :end-of-capability) |
211 | eoc)) | |
f2eefd24 | 212 | ;; Return (STREAM GREETING CAPABILITIES RESULTING-TYPE) |
da91b5f2 CY |
213 | (stream (make-network-process :name name :buffer buffer |
214 | :host host :service service)) | |
215 | (greeting (network-stream-get-response stream start eoc)) | |
2b216704 LMI |
216 | (capabilities (network-stream-command stream capability-command |
217 | eo-capa)) | |
e742e117 | 218 | (resulting-type 'plain) |
2db18f3f LMI |
219 | (builtin-starttls (and (fboundp 'gnutls-available-p) |
220 | (gnutls-available-p))) | |
468d09d4 | 221 | starttls-command error) |
f2eefd24 | 222 | |
468d09d4 LMI |
223 | ;; First check whether the server supports STARTTLS at all. |
224 | (when (and capabilities success-string starttls-function) | |
225 | (setq starttls-command | |
226 | (funcall starttls-function capabilities))) | |
1e3b6001 G |
227 | ;; If we have built-in STARTTLS support, try to upgrade the |
228 | ;; connection. | |
468d09d4 LMI |
229 | (when (and starttls-command |
230 | (or builtin-starttls | |
6af7a784 LMI |
231 | (and (or require-tls |
232 | (plist-get parameters :use-starttls-if-possible)) | |
9a70f03d | 233 | (starttls-available-p))) |
4bba86e6 | 234 | (not (eq (plist-get parameters :type) 'plain))) |
f2eefd24 CY |
235 | ;; If using external STARTTLS, drop this connection and start |
236 | ;; anew with `starttls-open-stream'. | |
2db18f3f | 237 | (unless builtin-starttls |
f2eefd24 CY |
238 | (delete-process stream) |
239 | (setq start (with-current-buffer buffer (point-max))) | |
240 | (let* ((starttls-use-gnutls t) | |
241 | (starttls-extra-arguments | |
e742e117 CY |
242 | (if require-tls |
243 | starttls-extra-arguments | |
244 | ;; For opportunistic TLS upgrades, we don't really | |
245 | ;; care about the identity of the peer. | |
4ea31e07 LMI |
246 | (cons "--insecure" starttls-extra-arguments))) |
247 | (cert (network-stream-certificate host service parameters))) | |
248 | ;; There are client certificates requested, so add them to | |
249 | ;; the command line. | |
250 | (when cert | |
251 | (setq starttls-extra-arguments | |
eb8c9362 LMI |
252 | (nconc (list "--x509keyfile" (expand-file-name (nth 0 cert)) |
253 | "--x509certfile" (expand-file-name (nth 1 cert))) | |
4ea31e07 | 254 | starttls-extra-arguments))) |
f2eefd24 | 255 | (setq stream (starttls-open-stream name buffer host service))) |
f6ab314e LMI |
256 | (network-stream-get-response stream start eoc) |
257 | ;; Requery capabilities for protocols that require it; i.e., | |
258 | ;; EHLO for SMTP. | |
259 | (when (plist-get parameters :always-query-capabilities) | |
2b216704 | 260 | (network-stream-command stream capability-command eo-capa))) |
f2eefd24 | 261 | (when (string-match success-string |
da91b5f2 | 262 | (network-stream-command stream starttls-command eoc)) |
f2eefd24 | 263 | ;; The server said it was OK to begin STARTTLS negotiations. |
2db18f3f | 264 | (if builtin-starttls |
4ea31e07 | 265 | (let ((cert (network-stream-certificate host service parameters))) |
12b9eb35 LMI |
266 | (condition-case nil |
267 | (gnutls-negotiate :process stream :hostname host | |
268 | :keylist (and cert (list cert))) | |
269 | ;; If we get a gnutls-specific error (for instance if | |
270 | ;; the certificate the server gives us is completely | |
271 | ;; syntactically invalid), then close the connection | |
272 | ;; and possibly (further down) try to create a | |
273 | ;; non-encrypted connection. | |
274 | (gnutls-error | |
275 | (delete-process stream)))) | |
f2eefd24 CY |
276 | (unless (starttls-negotiate stream) |
277 | (delete-process stream))) | |
278 | (if (memq (process-status stream) '(open run)) | |
279 | (setq resulting-type 'tls) | |
280 | ;; We didn't successfully negotiate STARTTLS; if TLS | |
281 | ;; isn't demanded, reopen an unencrypted connection. | |
e742e117 | 282 | (unless require-tls |
da91b5f2 CY |
283 | (setq stream |
284 | (make-network-process :name name :buffer buffer | |
285 | :host host :service service)) | |
286 | (network-stream-get-response stream start eoc))) | |
f2eefd24 CY |
287 | ;; Re-get the capabilities, which may have now changed. |
288 | (setq capabilities | |
2b216704 | 289 | (network-stream-command stream capability-command eo-capa)))) |
f2eefd24 CY |
290 | |
291 | ;; If TLS is mandatory, close the connection if it's unencrypted. | |
1f2b92cb | 292 | (when (and require-tls |
468d09d4 LMI |
293 | ;; ... but Emacs wasn't able to -- either no built-in |
294 | ;; support, or no gnutls-cli installed. | |
295 | (eq resulting-type 'plain)) | |
1f2b92cb LMI |
296 | (setq error |
297 | (if require-tls | |
298 | "Server does not support TLS" | |
299 | "Server supports STARTTLS, but Emacs does not have support for it")) | |
468d09d4 LMI |
300 | (delete-process stream) |
301 | (setq stream nil)) | |
f2eefd24 | 302 | ;; Return value: |
468d09d4 | 303 | (list stream greeting capabilities resulting-type error))) |
ed797193 | 304 | |
da91b5f2 CY |
305 | (defun network-stream-command (stream command eoc) |
306 | (when command | |
307 | (let ((start (with-current-buffer (process-buffer stream) (point-max)))) | |
308 | (process-send-string stream command) | |
309 | (network-stream-get-response stream start eoc)))) | |
310 | ||
311 | (defun network-stream-get-response (stream start end-of-command) | |
312 | (when end-of-command | |
313 | (with-current-buffer (process-buffer stream) | |
314 | (save-excursion | |
315 | (goto-char start) | |
316 | (while (and (memq (process-status stream) '(open run)) | |
317 | (not (re-search-forward end-of-command nil t))) | |
318 | (accept-process-output stream 0 50) | |
319 | (goto-char start)) | |
320 | ;; Return the data we got back, or nil if the process died. | |
321 | (unless (= start (point)) | |
322 | (buffer-substring start (point))))))) | |
323 | ||
324 | (defun network-stream-open-tls (name buffer host service parameters) | |
ed797193 | 325 | (with-current-buffer buffer |
da91b5f2 | 326 | (let* ((start (point-max)) |
2db18f3f LMI |
327 | (use-builtin-gnutls (and (fboundp 'gnutls-available-p) |
328 | (gnutls-available-p))) | |
da91b5f2 CY |
329 | (stream |
330 | (funcall (if use-builtin-gnutls | |
331 | 'open-gnutls-stream | |
332 | 'open-tls-stream) | |
333 | name buffer host service)) | |
334 | (eoc (plist-get parameters :end-of-command))) | |
516aa569 | 335 | (if (null stream) |
e742e117 | 336 | (list nil nil nil 'plain) |
516aa569 G |
337 | ;; If we're using tls.el, we have to delete the output from |
338 | ;; openssl/gnutls-cli. | |
2db18f3f LMI |
339 | (when (and (null use-builtin-gnutls) |
340 | eoc) | |
da91b5f2 | 341 | (network-stream-get-response stream start eoc) |
516aa569 | 342 | (goto-char (point-min)) |
f2eefd24 | 343 | (when (re-search-forward eoc nil t) |
516aa569 G |
344 | (goto-char (match-beginning 0)) |
345 | (delete-region (point-min) (line-beginning-position)))) | |
da91b5f2 CY |
346 | (let* ((capability-command (plist-get parameters :capability-command))) |
347 | (list stream | |
348 | (network-stream-get-response stream start eoc) | |
349 | (network-stream-command stream capability-command eoc) | |
350 | 'tls)))))) | |
ed797193 | 351 | |
da91b5f2 | 352 | (defun network-stream-open-shell (name buffer host service parameters) |
f2eefd24 | 353 | (require 'format-spec) |
f2eefd24 CY |
354 | (let* ((capability-command (plist-get parameters :capability-command)) |
355 | (eoc (plist-get parameters :end-of-command)) | |
da91b5f2 CY |
356 | (start (with-current-buffer buffer (point))) |
357 | (stream (let ((process-connection-type nil)) | |
358 | (start-process name buffer shell-file-name | |
359 | shell-command-switch | |
360 | (format-spec | |
361 | (plist-get parameters :shell-command) | |
362 | (format-spec-make | |
363 | ?s host | |
364 | ?p service)))))) | |
365 | (list stream | |
366 | (network-stream-get-response stream start eoc) | |
2b216704 LMI |
367 | (network-stream-command stream capability-command |
368 | (or (plist-get parameters :end-of-capability) | |
369 | eoc)) | |
da91b5f2 | 370 | 'plain))) |
ed797193 | 371 | |
da91b5f2 | 372 | (provide 'network-stream) |
ed797193 | 373 | |
da91b5f2 | 374 | ;;; network-stream.el ends here |