Commit | Line | Data |
---|---|---|
da91b5f2 | 1 | ;;; network-stream.el --- open network processes, possibly with encryption |
a33a2868 | 2 | |
ba318903 | 3 | ;; Copyright (C) 2010-2014 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 | ||
fa463103 | 118 | :always-query-capabilities 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 | |
016a35df GM |
128 | :use-starttls-if-possible is a boolean that says to do opportunistic |
129 | STARTTLS upgrades even if Emacs doesn't have built-in TLS functionality. | |
6af7a784 | 130 | |
ac38e731 LMI |
131 | :nogreeting is a boolean that can be used to inhibit waiting for |
132 | a greeting from the server. | |
133 | ||
8de66e05 | 134 | :nowait is a boolean that says the connection should be made |
4ea31e07 | 135 | asynchronously, if possible." |
da91b5f2 CY |
136 | (unless (featurep 'make-network-process) |
137 | (error "Emacs was compiled without networking support")) | |
f2eefd24 CY |
138 | (let ((type (plist-get parameters :type)) |
139 | (return-list (plist-get parameters :return-list))) | |
e742e117 CY |
140 | (if (and (not return-list) |
141 | (or (eq type 'plain) | |
142 | (and (memq type '(nil network)) | |
143 | (not (and (plist-get parameters :success) | |
144 | (plist-get parameters :capability-command)))))) | |
da91b5f2 CY |
145 | ;; The simplest case: wrapper around `make-network-process'. |
146 | (make-network-process :name name :buffer buffer | |
8de66e05 LMI |
147 | :host host :service service |
148 | :nowait (plist-get parameters :nowait)) | |
da91b5f2 CY |
149 | (let ((work-buffer (or buffer |
150 | (generate-new-buffer " *stream buffer*"))) | |
4bba86e6 LMI |
151 | (fun (cond ((and (eq type 'plain) |
152 | (not (plist-get parameters | |
153 | :always-query-capabilities))) | |
154 | 'network-stream-open-plain) | |
155 | ((memq type '(nil network starttls plain)) | |
da91b5f2 CY |
156 | 'network-stream-open-starttls) |
157 | ((memq type '(tls ssl)) 'network-stream-open-tls) | |
158 | ((eq type 'shell) 'network-stream-open-shell) | |
159 | (t (error "Invalid connection type %s" type)))) | |
160 | result) | |
161 | (unwind-protect | |
162 | (setq result (funcall fun name work-buffer host service parameters)) | |
163 | (unless buffer | |
164 | (and (processp (car result)) | |
165 | (set-process-buffer (car result) nil)) | |
166 | (kill-buffer work-buffer))) | |
f2eefd24 CY |
167 | (if return-list |
168 | (list (car result) | |
169 | :greeting (nth 1 result) | |
170 | :capabilities (nth 2 result) | |
468d09d4 LMI |
171 | :type (nth 3 result) |
172 | :error (nth 4 result)) | |
f2eefd24 CY |
173 | (car result)))))) |
174 | ||
4ea31e07 LMI |
175 | (defun network-stream-certificate (host service parameters) |
176 | (let ((spec (plist-get :client-certificate parameters))) | |
177 | (cond | |
178 | ((listp spec) | |
179 | ;; Either nil or a list with a key/certificate pair. | |
180 | spec) | |
181 | ((eq spec t) | |
182 | (let* ((auth-info | |
183 | (car (auth-source-search :max 1 | |
184 | :host host | |
185 | :port service))) | |
eb8c9362 LMI |
186 | (key (plist-get auth-info :key)) |
187 | (cert (plist-get auth-info :cert))) | |
4ea31e07 LMI |
188 | (and key cert |
189 | (list key cert))))))) | |
190 | ||
da91b5f2 CY |
191 | ;;;###autoload |
192 | (defalias 'open-protocol-stream 'open-network-stream) | |
193 | ||
194 | (defun network-stream-open-plain (name buffer host service parameters) | |
07176b2a | 195 | (let ((start (with-current-buffer buffer (point))) |
da91b5f2 | 196 | (stream (make-network-process :name name :buffer buffer |
8de66e05 LMI |
197 | :host host :service service |
198 | :nowait (plist-get parameters :nowait)))) | |
07176b2a | 199 | (list stream |
da91b5f2 | 200 | (network-stream-get-response stream start |
8de66e05 | 201 | (plist-get parameters :end-of-command)) |
008cad90 | 202 | nil |
e742e117 | 203 | 'plain))) |
3b84b005 | 204 | |
da91b5f2 | 205 | (defun network-stream-open-starttls (name buffer host service parameters) |
ed797193 | 206 | (let* ((start (with-current-buffer buffer (point))) |
e742e117 | 207 | (require-tls (eq (plist-get parameters :type) 'starttls)) |
f2eefd24 CY |
208 | (starttls-function (plist-get parameters :starttls-function)) |
209 | (success-string (plist-get parameters :success)) | |
210 | (capability-command (plist-get parameters :capability-command)) | |
211 | (eoc (plist-get parameters :end-of-command)) | |
2b216704 LMI |
212 | (eo-capa (or (plist-get parameters :end-of-capability) |
213 | eoc)) | |
f2eefd24 | 214 | ;; Return (STREAM GREETING CAPABILITIES RESULTING-TYPE) |
da91b5f2 CY |
215 | (stream (make-network-process :name name :buffer buffer |
216 | :host host :service service)) | |
ac38e731 LMI |
217 | (greeting (and (not (plist-get parameters :nogreeting)) |
218 | (network-stream-get-response stream start eoc))) | |
2b216704 LMI |
219 | (capabilities (network-stream-command stream capability-command |
220 | eo-capa)) | |
e742e117 | 221 | (resulting-type 'plain) |
2db18f3f LMI |
222 | (builtin-starttls (and (fboundp 'gnutls-available-p) |
223 | (gnutls-available-p))) | |
ec5c990d | 224 | starttls-available starttls-command error) |
f2eefd24 | 225 | |
468d09d4 LMI |
226 | ;; First check whether the server supports STARTTLS at all. |
227 | (when (and capabilities success-string starttls-function) | |
228 | (setq starttls-command | |
229 | (funcall starttls-function capabilities))) | |
1e3b6001 G |
230 | ;; If we have built-in STARTTLS support, try to upgrade the |
231 | ;; connection. | |
468d09d4 | 232 | (when (and starttls-command |
ec5c990d CY |
233 | (setq starttls-available |
234 | (or builtin-starttls | |
235 | (and (or require-tls | |
236 | (plist-get parameters :use-starttls-if-possible)) | |
237 | (starttls-available-p)))) | |
4bba86e6 | 238 | (not (eq (plist-get parameters :type) 'plain))) |
f2eefd24 CY |
239 | ;; If using external STARTTLS, drop this connection and start |
240 | ;; anew with `starttls-open-stream'. | |
2db18f3f | 241 | (unless builtin-starttls |
f2eefd24 CY |
242 | (delete-process stream) |
243 | (setq start (with-current-buffer buffer (point-max))) | |
57173b96 | 244 | (let* ((starttls-extra-arguments |
3986af6c DS |
245 | (if (or require-tls |
246 | (member "--insecure" starttls-extra-arguments)) | |
e742e117 CY |
247 | starttls-extra-arguments |
248 | ;; For opportunistic TLS upgrades, we don't really | |
249 | ;; care about the identity of the peer. | |
4ea31e07 | 250 | (cons "--insecure" starttls-extra-arguments))) |
57173b96 | 251 | (starttls-extra-args starttls-extra-args) |
4ea31e07 LMI |
252 | (cert (network-stream-certificate host service parameters))) |
253 | ;; There are client certificates requested, so add them to | |
254 | ;; the command line. | |
255 | (when cert | |
256 | (setq starttls-extra-arguments | |
eb8c9362 LMI |
257 | (nconc (list "--x509keyfile" (expand-file-name (nth 0 cert)) |
258 | "--x509certfile" (expand-file-name (nth 1 cert))) | |
57173b96 LMI |
259 | starttls-extra-arguments) |
260 | starttls-extra-args | |
261 | (nconc (list "--key-file" (expand-file-name (nth 0 cert)) | |
262 | "--cert-file" (expand-file-name (nth 1 cert))) | |
263 | starttls-extra-args))) | |
f2eefd24 | 264 | (setq stream (starttls-open-stream name buffer host service))) |
f6ab314e LMI |
265 | (network-stream-get-response stream start eoc) |
266 | ;; Requery capabilities for protocols that require it; i.e., | |
267 | ;; EHLO for SMTP. | |
268 | (when (plist-get parameters :always-query-capabilities) | |
2b216704 | 269 | (network-stream-command stream capability-command eo-capa))) |
e5b246e9 DV |
270 | (when (let ((response |
271 | (network-stream-command stream starttls-command eoc))) | |
272 | (and response (string-match success-string response))) | |
f2eefd24 | 273 | ;; The server said it was OK to begin STARTTLS negotiations. |
2db18f3f | 274 | (if builtin-starttls |
4ea31e07 | 275 | (let ((cert (network-stream-certificate host service parameters))) |
12b9eb35 LMI |
276 | (condition-case nil |
277 | (gnutls-negotiate :process stream :hostname host | |
278 | :keylist (and cert (list cert))) | |
279 | ;; If we get a gnutls-specific error (for instance if | |
280 | ;; the certificate the server gives us is completely | |
281 | ;; syntactically invalid), then close the connection | |
282 | ;; and possibly (further down) try to create a | |
283 | ;; non-encrypted connection. | |
284 | (gnutls-error | |
285 | (delete-process stream)))) | |
f2eefd24 CY |
286 | (unless (starttls-negotiate stream) |
287 | (delete-process stream))) | |
288 | (if (memq (process-status stream) '(open run)) | |
289 | (setq resulting-type 'tls) | |
290 | ;; We didn't successfully negotiate STARTTLS; if TLS | |
291 | ;; isn't demanded, reopen an unencrypted connection. | |
e742e117 | 292 | (unless require-tls |
da91b5f2 CY |
293 | (setq stream |
294 | (make-network-process :name name :buffer buffer | |
295 | :host host :service service)) | |
296 | (network-stream-get-response stream start eoc))) | |
f2eefd24 CY |
297 | ;; Re-get the capabilities, which may have now changed. |
298 | (setq capabilities | |
2b216704 | 299 | (network-stream-command stream capability-command eo-capa)))) |
f2eefd24 CY |
300 | |
301 | ;; If TLS is mandatory, close the connection if it's unencrypted. | |
1f2b92cb | 302 | (when (and require-tls |
468d09d4 LMI |
303 | ;; ... but Emacs wasn't able to -- either no built-in |
304 | ;; support, or no gnutls-cli installed. | |
305 | (eq resulting-type 'plain)) | |
1f2b92cb | 306 | (setq error |
96f8741e CY |
307 | (if (or (null starttls-command) |
308 | starttls-available) | |
1f2b92cb | 309 | "Server does not support TLS" |
c676576a LMI |
310 | ;; See `starttls-available-p'. If this predicate |
311 | ;; changes to allow running under Windows, the error | |
312 | ;; message below should be amended. | |
313 | (if (memq system-type '(windows-nt ms-dos)) | |
314 | (concat "Emacs does not support TLS") | |
315 | (concat "Emacs does not support TLS, and no external `" | |
316 | (if starttls-use-gnutls | |
317 | starttls-gnutls-program | |
318 | starttls-program) | |
319 | "' program was found")))) | |
468d09d4 LMI |
320 | (delete-process stream) |
321 | (setq stream nil)) | |
f2eefd24 | 322 | ;; Return value: |
468d09d4 | 323 | (list stream greeting capabilities resulting-type error))) |
ed797193 | 324 | |
da91b5f2 CY |
325 | (defun network-stream-command (stream command eoc) |
326 | (when command | |
327 | (let ((start (with-current-buffer (process-buffer stream) (point-max)))) | |
328 | (process-send-string stream command) | |
329 | (network-stream-get-response stream start eoc)))) | |
330 | ||
331 | (defun network-stream-get-response (stream start end-of-command) | |
332 | (when end-of-command | |
333 | (with-current-buffer (process-buffer stream) | |
334 | (save-excursion | |
335 | (goto-char start) | |
336 | (while (and (memq (process-status stream) '(open run)) | |
337 | (not (re-search-forward end-of-command nil t))) | |
338 | (accept-process-output stream 0 50) | |
339 | (goto-char start)) | |
340 | ;; Return the data we got back, or nil if the process died. | |
341 | (unless (= start (point)) | |
342 | (buffer-substring start (point))))))) | |
343 | ||
344 | (defun network-stream-open-tls (name buffer host service parameters) | |
ed797193 | 345 | (with-current-buffer buffer |
da91b5f2 | 346 | (let* ((start (point-max)) |
2db18f3f LMI |
347 | (use-builtin-gnutls (and (fboundp 'gnutls-available-p) |
348 | (gnutls-available-p))) | |
da91b5f2 CY |
349 | (stream |
350 | (funcall (if use-builtin-gnutls | |
351 | 'open-gnutls-stream | |
352 | 'open-tls-stream) | |
353 | name buffer host service)) | |
354 | (eoc (plist-get parameters :end-of-command))) | |
516aa569 | 355 | (if (null stream) |
e742e117 | 356 | (list nil nil nil 'plain) |
516aa569 G |
357 | ;; If we're using tls.el, we have to delete the output from |
358 | ;; openssl/gnutls-cli. | |
2db18f3f LMI |
359 | (when (and (null use-builtin-gnutls) |
360 | eoc) | |
da91b5f2 | 361 | (network-stream-get-response stream start eoc) |
516aa569 | 362 | (goto-char (point-min)) |
f2eefd24 | 363 | (when (re-search-forward eoc nil t) |
516aa569 G |
364 | (goto-char (match-beginning 0)) |
365 | (delete-region (point-min) (line-beginning-position)))) | |
da91b5f2 CY |
366 | (let* ((capability-command (plist-get parameters :capability-command))) |
367 | (list stream | |
368 | (network-stream-get-response stream start eoc) | |
369 | (network-stream-command stream capability-command eoc) | |
370 | 'tls)))))) | |
ed797193 | 371 | |
da91b5f2 | 372 | (defun network-stream-open-shell (name buffer host service parameters) |
f2eefd24 | 373 | (require 'format-spec) |
f2eefd24 CY |
374 | (let* ((capability-command (plist-get parameters :capability-command)) |
375 | (eoc (plist-get parameters :end-of-command)) | |
da91b5f2 CY |
376 | (start (with-current-buffer buffer (point))) |
377 | (stream (let ((process-connection-type nil)) | |
378 | (start-process name buffer shell-file-name | |
379 | shell-command-switch | |
380 | (format-spec | |
381 | (plist-get parameters :shell-command) | |
382 | (format-spec-make | |
383 | ?s host | |
384 | ?p service)))))) | |
385 | (list stream | |
386 | (network-stream-get-response stream start eoc) | |
2b216704 LMI |
387 | (network-stream-command stream capability-command |
388 | (or (plist-get parameters :end-of-capability) | |
389 | eoc)) | |
da91b5f2 | 390 | 'plain))) |
ed797193 | 391 | |
da91b5f2 | 392 | (provide 'network-stream) |
ed797193 | 393 | |
da91b5f2 | 394 | ;;; network-stream.el ends here |