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